source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF18.m@ 1361

Last change on this file since 1361 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.5 KB
RevLine 
[613]1IBDF18 ;A;B/CJM - ENCOUNTER FORM - utilities for Problem List ;15OCT93
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4GETFORM() ;allows the user to select an encounter form with a Clinic Common Problem List
5 ;returns <the form ien, or 0 if none selected>^<form name>
6 N FORM,LIST,QUIT,ANS
7 S (LIST,QUIT)=0 F D Q:QUIT
8 .S FORM=$$SLCTFORM^IBDFU4(0)
9 .I 'FORM S QUIT=1 Q
10 .D FIND(FORM,0,.LIST,0)
11 .I LIST S QUIT=1 Q
12 .W !,"The form you selected doesn't contain a Clinic Common Problem List!",!,"Do you want to select another form? "
13 .R ANS:DTIME
14 .S:'$T!(ANS="")!(ANS["^")!(ANS["N")!(ANS["n") QUIT=1,FORM=0
15 Q FORM_"^"_$P($G(^IBE(357,FORM,0)),"^")
16 ;
17 ;
18COPYFORM(FORM,ARY) ;creates a list of problem groups and problems found in FORM on the list of clinic common problems
19 ;returns the length of the returned list
20 ;FORM is the ien of an encounter form
21 ;@ARY is the array where the list should be placed
22 ;each problem will have the format 'problem ien^problem text'
23 ;each group will have the format '^header text to display (could be null)'
24 ;following each group will be the problems on it
25 ;
26 ;the ruturned list will look like this:
27 ;@ARY@(1)=^group header
28 ;@ARY@(2)=problem ien^problem text
29 ;@ARY@(3)=problem ien^problem text
30 ;
31 ;
32 ;@ARY@(k)=^next group header
33 ;@ARY@(k+1)=problem ien^problem text
34 ;....
35 ;
36 Q:'$G(FORM) 0
37 Q:'$L($G(ARY)) 0
38 N BLOCK,LIST,INTRFACE,COUNT
39 S (BLOCK,LIST,INTRFACE,COUNT)=0
40 F D FIND(FORM,.BLOCK,.LIST,.INTRFACE) Q:'LIST D COPYLIST(LIST,ARY,.COUNT)
41 Q COUNT
42 ;
43COPYLIST(LIST,ARY,COUNT) ;copies the entries from LIST to @ARY, starting subscript at COUNT+1
44 ;
45 N SLCTN,SUBCOL,TEXT,IEN,NODE,TSUBCOL,NOTREAL,NODE,GROUP,ORDER,HDR
46 ;
47 D SUBCOL(LIST,.TSUBCOL) ;find the subcolumn containing the text
48 ;don't bother returning list of problems if there is no subcolumn containing the problem text
49 Q:'$G(TSUBCOL)
50 ;
51 S GROUP=0 F S GROUP=$O(^IBE(357.3,"APO",LIST,GROUP)) Q:'GROUP D
52 .S HDR=$P($G(^IBE(357.4,GROUP,0)),"^") I HDR="BLANK" S HDR=""
53 .S COUNT=COUNT+1,@ARY@(COUNT)="^"_HDR
54 .S ORDER="" F S ORDER=$O(^IBE(357.3,"APO",LIST,GROUP,ORDER)) Q:ORDER="" S SLCTN=0 F S SLCTN=$O(^IBE(357.3,"APO",LIST,GROUP,ORDER,SLCTN)) Q:'SLCTN D
55 ..S NODE=$G(^IBE(357.3,SLCTN,0)),IEN=$P(NODE,"^"),NOTREAL=$P(NODE,"^",2)
56 ..Q:'IEN!(NOTREAL)
57 ..S SUBCOL=$O(^IBE(357.3,SLCTN,1,"B",TSUBCOL,0)) Q:'SUBCOL S NODE=$G(^IBE(357.3,SLCTN,1,SUBCOL,0)) S:$P(NODE,"^")=TSUBCOL TEXT=$P(NODE,"^",2) I $L(TEXT) S COUNT=COUNT+1,@ARY@(COUNT)=IEN_"^"_TEXT Q
58 Q
59 ;
60 ;
61SUBCOL(LIST,TSUBCOL) ;finds the subcolumn containing the text
62 ;TSUBCOL should be passed by reference - used to return the subcolumn
63 ;LIST is the selection list to search
64 S TSUBCOL=""
65 ;
66 N SC,PIECE,NODE S SC=0
67 ;
68 ;refering to the data returned by the package interface, piece 2 is the description
69 F S SC=$O(^IBE(357.2,LIST,2,SC)) Q:'SC S NODE=$G(^IBE(357.2,LIST,2,SC,0)),PIECE=$P(NODE,"^",5) I PIECE=2 S TSUBCOL=$P(NODE,"^") Q
70 Q
71 ;
72FIND(FORM,BLK,LIST,INTRFACE) ;finds the block & list containing the Clinic Common Problem List
73 N INTRFACE,QUIT
74 S BLK=+$G(BLK),LIST=+$G(LIST),INTRFACE=+$G(INTRFACE)
75 ;
76 ;if not already found,find the package interface for selecting PROBLEMS
77 I 'INTRFACE S INTRFACE=$O(^IBE(357.6,"B","GMP SELECT CLINIC COMMON PROBL",0))
78 I 'INTRFACE S (BLK,LIST)=0 QUIT
79 ;
80 I BLK D
81 .F S LIST=$O(^IBE(357.2,"C",BLK,LIST)) Q:'LIST I $P($G(^IBE(357.2,LIST,0)),"^",11)=INTRFACE Q
82 I BLK,LIST QUIT
83 S QUIT=0
84 F S BLK=$O(^IBE(357.1,"C",FORM,BLK)) Q:'BLK D Q:QUIT
85 .S LIST=0 F S LIST=$O(^IBE(357.2,"C",BLK,LIST)) Q:'LIST I $P($G(^IBE(357.2,LIST,0)),"^",11)=INTRFACE S QUIT=1 Q
86 I 'BLK!('LIST) S (BLK,LIST)=0
87 Q
Note: See TracBrowser for help on using the repository browser.