source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFRPC1.m@ 1757

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

initial load of FOIAVistA 6/30/08 version
File size: 5.2 KB
Line 
1IBDFRPC1 ;ALB/AAS - Return list of selections ; 2-JAN-96
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**25**;APR 24, 1997
3 ;
4 ; -- used by AICS Data Entry Systems, IBDFDE2, IBDFDE3, IBDFDE4
5 ;
6OBJLST(RESULT,IBDF) ; -- Procedure
7 ; -- Broker call to return any specified selection list, handprint field or multiple choice field
8 ; rpc := IBD GET ONE INPUT OBJECT
9 ;
10 ; -- input RESULT := see output
11 ; IBDF("PI") := package interface name or pointer
12 ; IBDF("TYPE") := type of input object
13 ; IBDF("IEN") := internal entry number of object
14 ; IBDF("DFN") := pointer to patient (2) (required for patient active problems only)
15 ; IBDF("CLINIC") := pointer to hospital location (44) (required for provider list only)
16 ; IBDF("KILL") := 1 to kill results array prior to setting (Default) (optional)
17 ;
18 ; -- Output RESULT (called by reference)
19 ; new for version 3.0 RESULT may be a closed global, i.e. ^tmp($j)
20 ; and the data will be returned in ^tmp($j,n)
21 ; For Lists:
22 ; RESULT(0) := number of entries^type of input object (LIST)^qualifier;;selection rule[::qualifier;;selection rule)^no scannable bubbles(1 if not scannable)
23 ; RESULTS(N) $P1 := Display text
24 ; $P2 := Display code
25 ; $P3 := input value (value to return)
26 ; $P4 := input transform
27 ; $P5 := optional caption
28 ; $P6 := optional Term pointer
29 ; $P7 := Selectable
30 ;
31 ; For Hand Print Fields
32 ; RESULT(0) := 1^type of object (HP)^label^vitals type
33 ; RESULT(1) := Text from form^print format in 359.1^MAX lenght^units^vitals Type^PCE DIM Units
34 ;
35 ; For Multiple Choice fields
36 ; RESULT(0) := count of choices^type (MC)^display text^selection rule
37 ; RESULT(n) := display text^label^value to return^qualifier^^^selectable (1)
38 ;
39 N IBQUIT,LIST,CLINIC,CL1,PI,PKG,PKG1,DYN,ARRY,VALUE
40 S (IBQUIT,LIST)=0
41 ;
42 I $E($G(RESULT),1)="^" S ARRY=RESULT
43 E S ARRY="RESULT"
44 I $G(IBDF("KILL"))="" S IBDF("KILL")=1
45 K:IBDF("KILL") @ARRY
46 ;
47 S @ARRY@(0)="No package Interface found, 1"
48 ; -- set pkg = ien of pkg interface from either b or e x-ref
49 S PKG=$G(IBDF("PI"))
50 I +PKG'=PKG,PKG'="" S PKG1=+$O(^IBE(357.6,"B",$E(PKG,1,30),0)) I 'PKG1 S PKG1=+$O(^IBE(357.6,"E",$E(PKG,1,40),0))
51 I $G(PKG1),'PKG S IBDF("PI")=PKG1
52 G:'$G(IBDF("PI")) OBJLSTQ
53 G:$G(^IBE(357.6,+IBDF("PI"),0))="" OBJLSTQ
54 ;
55 I $G(IBDF("TYPE"))="" D
56 .S ITYP=$P($G(^IBE(357.6,+IBDF("PI"),0)),"^")
57 .S IBDF("TYPE")=$S(ITYP=3:"LIST",ITYP=4:"MC",ITYP=5:"HP",1:"")
58 I $G(IBDF("TYPE"))="" S @ARRY@(0)="Object Type not determined" G OBJLSTQ
59 I "^LIST^MC^HP^"'[("^"_IBDF("TYPE")_"^") S @ARRY@(0)="Object type Unknown" G OBJLSTQ
60 ;
61 ;S FRM=$G(IBDF("FRM"))
62 ;I +FRM'=FRM,FRM'="" S FRM=+$O(^IBE(357,"B",FRM,0))
63 ;I 'FRM S FRM=$$DEFAULT^IBDFRPC S:FRM @ARRY@(0)="Using default form",IBDF("FRM")=FRM G:'FRM OBJLSTQ
64 ;
65 ; -- if type is selection list
66 I IBDF("TYPE")="LIST" D G OBJLSTQ
67 .S DYN=$P(^IBE(357.6,IBDF("PI"),0),"^",14)
68 .I 'DYN D SEL^IBDFRPC2(.RESULT,.IBDF)
69 .I DYN D DYN^IBDFRPC2(.RESULT,.IBDF)
70 ;
71 ; -- if type is multiple choice
72 I IBDF("TYPE")="MC" D MC G OBJLSTQ
73 ;
74 ; -- If type is Hand Print
75 I IBDF("TYPE")="HP" D HP G OBJLSTQ
76 ;
77 S @ARRY@(0)="Processing did not occur"
78 ;
79OBJLSTQ Q
80 ;
81MC ; -- returns list from multiple choice fields
82 N X,DTEXT,SRULE,CHOICE,CH,CTEXT,CHLBL,CHID,CHQLF,CNT
83 S @ARRY@(0)="Multiple Choice Field not found"
84 G:'$G(IBDF("IEN")) MCQ
85 S X=$G(^IBE(357.93,IBDF("IEN"),0)) G:X="" MCQ
86 ;
87 S DTEXT=$P(X,"^",2),SRULE=$P(X,"^",9)
88 ;
89 S (CHOICE,CNT)=0
90 F S CHOICE=$O(^IBE(357.93,IBDF("IEN"),1,CHOICE)) Q:'CHOICE D
91 .S CH=$G(^IBE(357.93,IBDF("IEN"),1,CHOICE,0)) Q:CH=""
92 .S CTEXT=$P(CH,"^"),CHLBL=$P(CH,"^",5),CHID=$P(CH,"^",8)
93 .S CHQLF=$P(CH,"^",9),VALUE=$P($G(^IBD(357.98,+$G(CHQLF),0)),"^")
94 .S CNT=CNT+1
95 .S @ARRY@(CNT)=CTEXT_"^"_CHLBL_"^"_VALUE_"^"_CHQLF_"^^^1"
96 .Q
97 S @ARRY@(0)=CNT_"^MC^"_DTEXT_"^"_SRULE
98MCQ Q
99 ;
100HP ; -- returns information on hand print field
101 N X,HNODE,HTEXT,HTYPE,HLEN,HPIC,HMEAS,VTYPE,VUNIT
102 S @ARRY@(0)="Hand Print field not found"
103 G:'$G(IBDF("IEN")) HPQ
104 S HNODE=$G(^IBE(359.94,IBDF("IEN"),0))
105 G:$G(HNODE)="" HPQ
106 S HTEXT=$P(HNODE,"^",2)
107 S HTYPE=$G(^IBE(359.1,+$P(HNODE,"^",10),0))
108 S HLEN=$P(HTYPE,"^",2),HPIC=$$FRMT^IBDF2F(HTYPE,$G(IBAPPT)),HMEAS=$P(HTYPE,"^",11),VTYPE=$P(HTYPE,"^",12),VUNIT=$P(HTYPE,"^",13)
109 S @ARRY@(1)=HTEXT_"^"_HPIC_"^"_HLEN_"^"_HMEAS_"^"_VTYPE_"^"_VUNIT
110 S @ARRY@(0)="1^HP^"_HTEXT_"^0"
111 ;
112HPQ Q
113 ;
1143 ; -- return lists of providers/cpts/diagnosis from form
115 ; format as in 2
116 Q
117 ;
1184 ; -- provide list of other input items/and parameters
119 Q
120 ;
121TESTD ; -- test dynamic list
122 S IBDF("PI")=61
123 S IBDF("IEN")=1729
124 S IBDF("TYPE")="LIST"
125 S IBDF("CLINIC")=300
126 S IBDF("DFN")=1
127 D OBJLST(.TEST,.IBDF)
128 X "ZW TEST"
129 Q
130 ;
131TESTL ; -- test list
132 K TEST
133 S IBDF("PI")=7
134 S IBDF("IEN")=488
135 S IBDF("TYPE")="LIST"
136 D OBJLST("^TMP($J,""TESTL"")",.IBDF)
137 X "ZW TEST"
138 Q
139 ;
140TESTM ; -- test Multiple choice
141 K TEST
142 S IBDF("PI")=7
143 S IBDF("TYPE")="MC"
144 S IBDF("IEN")=161
145 D OBJLST("^TMP($J,""TESTM"")",.IBDF)
146 X "ZW TEST"
147 Q
148TESTH ; -- test Hand Print
149 K TEST
150 S IBDF("PI")=95
151 S IBDF("TYPE")="HP"
152 S IBDF("IEN")=352
153 D OBJLST(.TEST,.IBDF)
154 X "ZW TEST"
155 Q
Note: See TracBrowser for help on using the repository browser.