home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e051 / 2.ddi / EXAMPLES / FEVER.OPS next >
Encoding:
Text File  |  1987-02-03  |  4.3 KB  |  174 lines
  1.  
  2. ;          ****Fever System****
  3.  
  4. ;Declarations
  5.  
  6. ;Data Base Elements
  7. (literalize  question   name  text)
  8. (literalize  selection  name  text)
  9.  
  10. ;Answer Elements
  11. (literalize  answer     qname result)
  12.  
  13. ;Print Text Elements
  14. (literalize  print-text           what  which  text)
  15. (literalize  print-text-finished  what  which)
  16.  
  17. ;Declare Text to be a vector element  
  18. (vector-attribute  text)
  19.  
  20.  
  21. ;*********Initialization production to build the data base**********
  22. (p  INIT
  23.   (start)
  24. -->
  25.   (remove 1)
  26.  
  27. ; Questions
  28.   (make   question    ^name  question1  
  29.           ^text "Is the child's temp 105 or higher?  *"    stop)  
  30.   (make   question   ^name  question2  
  31.           ^text "Is the child no older than 4 months?  *"  stop)
  32.   (make   question   ^name  question3  
  33.           ^text "Has temp of 104 degrees or more persisted for"
  34.                 " 4 hours or longer?  *"  stop)  
  35.   (make   question   ^name  question4
  36.           ^text  "Has an oral temp greater than 101 or rectal temp"
  37.                  "greater than 102 persisted more than 24hrs? *"  stop)
  38.   (make   question   ^name  question5  
  39.           ^text "Has a temp greater than normal persisted for"
  40.                 "4 or more days?  *"  stop)
  41.   (make   question   ^name  question6  
  42.     ^text  "Does the child have any of: stiff neck, sore throat,"
  43.            "earache, bad cough, trouble breathing, extreme lethargy,"
  44.            "vomiting, or diarrhea? *"  stop)
  45.  
  46. ; Selections
  47.   (make  selection  ^name call
  48.          ^text  "Best call the doctor...." stop)
  49.   (make  selection  ^name ok
  50.          ^text "Probably not serious at this time. " stop)
  51.   
  52. ;   *****Pass Control to the Expert Rules*****
  53.   (make answer start0 any) )
  54.  
  55.  
  56.  
  57. ;  The Expert Rules.
  58.  
  59. (p  RULE0 
  60.   (answer  ^qname  start0)        ;  Rule to ask the first question
  61. -->
  62.  (remove 1)
  63.  (make ask-question ^name question1))
  64.  
  65. ;  All of the following rules say:  
  66. ;   if then answer to the nth question is "no", 
  67. ;    then ask the n+1st question.
  68. (p  RULE1
  69.   (answer  ^qname question1 ^result n)
  70. -->  
  71.   (make ask-question ^name question2))
  72.  
  73. (p  RULE2 
  74.   (answer  ^qname question2 ^result n)
  75. -->  
  76.   (make ask-question ^name question3))
  77.  
  78. (p  RULE3 
  79.   (answer  ^qname question3 ^result n)
  80. -->  
  81.   (make ask-question ^name question4))
  82.  
  83. (p  RULE4 
  84.   (answer  ^qname question4 ^result n)
  85. -->  
  86.   (make ask-question ^name question5))
  87.  
  88. (p  RULE5 
  89.   (answer  ^qname question5 ^result n)
  90. -->  
  91.   (make ask-question ^name question6))
  92.  
  93. ;  If the answer to the last question is "no",
  94. ;  then tell them it is probably not serious.
  95. (p  RULE6 
  96.   (answer  ^qname question6  ^result n)
  97. -->  
  98.   (make give-selection ^name ok))
  99.  
  100. ;  If any answer is "yes", then tell them to call the doctor.
  101. (p  RULE-YES 
  102.   (answer  ^result y)
  103. -->  
  104.   (make give-selection ^name call))
  105.  
  106.  
  107.  
  108. ;    ***System Interpretation Rules***
  109.  
  110. ;  Rules for asking questions.
  111. (p QUERY1
  112.    (ask-question <name>)
  113.    (question ^name <name>)
  114. -->
  115.    (remove 1)
  116.    (bind <first> (litval text))
  117.    (make print-text 
  118.          ^what   question 
  119.          ^which  <name>
  120.          ^text   (substr 2 <first> inf)))
  121.  
  122. (p  QUERY2
  123.    (print-text-finished ^what question ^which <name>)
  124. -->
  125.    (remove 1)
  126.    (bind <ans> (accept))
  127.    (make answer ^name <name> ^result <ans>))
  128.  
  129.  
  130. ;  Rules for giving selections (diagnoses).
  131. (p  SELECT1
  132.   (give-selection  ^name <name>)
  133.   (selection       ^name <name>)
  134. -->
  135.   (remove 1)
  136.   (bind  <first>  (litval text))
  137.   (make  print-text 
  138.          ^what   selection 
  139.          ^which  <name>
  140.          ^text   (substr 2 <first> inf)))
  141.  
  142. (p  SELECT2
  143.    (print-text-finished  ^what selection)
  144. -->
  145.    (remove 1)
  146.    (halt))
  147.  
  148.  
  149.  
  150. ;  Rules for printing text vectors.
  151. ;  These rules (and the corresponding text elements in the
  152. ;  data base) use a special symbolic atom `stop' to determine 
  153. ;  when to stop printing.  
  154.  
  155. (p  PRINT-TEXT
  156.    (print-text ^what <what> ^which <name> ^text {<val> <> stop})
  157. -->
  158.    (remove 1)
  159.    (write (crlf))
  160.    (write <val>)
  161.    (bind <current> (litval text)) 
  162.    (bind <first> (compute <current> + 1))
  163.    (make print-text 
  164.          ^what   <what> 
  165.          ^which  <name>
  166.          ^text   (substr 1 <first> inf)))
  167.  
  168. (p PRINT-TEXT0
  169.    (print-text ^what <what> ^which <name> ^text {<val> = stop})
  170. -->
  171.    (remove 1)
  172.    (make print-text-finished ^what <what> ^which <name>)) 
  173.  
  174.