source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFDE5.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 8.6 KB
Line 
1IBDFDE5 ;ALB/AAS - AICS Manual Data Entry, Loader routine for 357.6 ; 19-APR-96
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**40**;APR 24, 1997
3 ;
4% G ^IBDFDE
5 ;
6 ;
7COMPLST ; -- procedure, compile form list arrays in ^tmp
8 ; ^tmp("ibd-lText",$j,form,package interface,list,text,cnt,n)=entry number
9 ; ^tmp("ibd-lCode",$j,form,package interface,list," "_code,cnt,n)= entry number
10 ; ^tmp("ibd-lst",$j,form,package inteface,list)=display text^display code^input value^ optional caption^ optional term^selectable?
11 ;
12 N IBDI,FORM,PI,IEN,CNT,CH,CODE
13 I '$G(IBDF("PI"))!('$G(IBDF("IEN")))!('$G(IBDFMIEN)) G COMPQ
14 S PI=IBDF("PI"),IEN=IBDF("IEN"),FORM=IBDFMIEN
15 ;
16 ;K ^TMP("IBD-LST",$J,FORM,PI,IEN),^TMP("IBD-LTEXT",$J,FORM,PI,IEN),^TMP("IBD-LCODE",$J,FORM,PI,IEN)
17 K ^TMP("IBD-LTEXT",$J,FORM,PI,IEN),^TMP("IBD-LCODE",$J,FORM,PI,IEN)
18 ;
19 ;M ^TMP("IBD-LST",$J,FORM,PI,IEN)=CHOICE
20 K CHOICE
21 ;
22 ; -- Expand choices
23 S HDR=""
24 S IBDI=0 F S IBDI=$O(^TMP("IBD-LST",$J,FORM,PI,IEN,IBDI)) Q:'IBDI S CH=$G(^(IBDI)) D
25 .I $P(CH,"^",7)=0 S HDR=$P(CH,"^") Q
26 .I $P(CH,"^",8)="" S $P(^TMP("IBD-LST",$J,FORM,PI,IEN,IBDI),"^",8)=HDR
27 .;
28 .; -- build array of text
29 .I $P(CH,"^",1)'="" D
30 ..I '$D(^TMP("IBD-LTEXT",$J,FORM,PI,IEN,$E($$UP^XLFSTR($P(CH,"^",1)),1,80))) S ^TMP("IBD-LTEXT",$J,FORM,PI,IEN,$E($$UP^XLFSTR($P(CH,"^",1)),1,80),1)=IBDI Q
31 ..S CNT=$O(^TMP("IBD-LTEXT",$J,FORM,PI,IEN,$E($$UP^XLFSTR($P(CH,"^",1)),1,80),""),-1)
32 ..S ^TMP("IBD-LTEXT",$J,FORM,PI,IEN,$E($$UP^XLFSTR($P(CH,"^",1)),1,80),CNT+1)=IBDI
33 .;
34 .; -- build array of codes
35 .S CODE=$S($P(CH,"^",2)'="":$P(CH,"^",2),1:$P(CH,"^",3)) Q:CODE=""
36 .I '$D(^TMP("IBD-LCODE",$J,FORM,PI,IEN," "_CODE,1)) S ^TMP("IBD-LCODE",$J,FORM,PI,IEN," "_CODE,1)=IBDI Q
37 .S CNT=$O(^TMP("IBD-LCODE",$J,FORM,PI,IEN," "_CODE,""),-1) S ^TMP("IBD-LCODE",$J,FORM,PI,IEN," "_CODE,CNT+1)=IBDI
38 ;
39COMPQ Q
40 ;
41MDCOMP(FORM) ; -- compile form for manual data entry into ^xtmp
42 ; -- ^xtmp("ibd"_form,0) := date ^ date
43 ; ^xtmp("ibd"_form, "ibd-obj", n) := object listing for form
44 ; ^xtmp("ibd"_form, "ibd-lst", pkg interface, list, n) := listing of each list
45 ; ^xtmp("ibd"_form, "ibd-lst", pkg interface, list ,"code", " "_code, n) := code index
46 ; ^xtmp("ibd"_form, "ibd-lst", pkg interface, list "text", text, n) := text index
47 ;
48 ; -- before converting to xtmp must resolve compile issues,
49 ; such as when form is in use for data entry etc.
50 ; need schema for locks...think about this
51 ; remember to check old logic for changes
52 ;
53 N I,J,X,Y,NAM,IBDOBJ
54 G:$G(^IBE(357,+$G(FORM),0))="" MDCQ
55 S NAM="IBD"_FORM
56 L +^XTMP(NAM):10 I '$T W !!,"form is in use, data entry compile failed",! S IBQUIT=1 G MDCQ
57 K ^XTMP(NAM) ; make sure ibdfde locks so doesn't kill when in use
58 S ^XTMP(NAM,0)=$$FMADD^XLFDT(DT,90)_"^"_DT
59 D FRMLSTI^IBDFRPC(.IBDOBJ,FORM,"",1)
60 M ^XTMP(NAM,"IBD-OBJ")=IBDOBJ
61 K IBDOBJ
62 ;
63 ; -- build entry for lists
64 S X=0 F S X=$O(^XTMP(NAM,"IBD-OBJ",X)) Q:'X S Y=^(X) D
65 .Q:$P($G(^IBE(357.6,+$P(Y,"^",2),0)),"^",14) ;dyanamic lists get compiled by ibdfde2 and then killed
66 .I $P(Y,"^",5)="LIST" D MDCLIST(FORM,$P(Y,"^",2),$P(Y,"^",6))
67 ;
68MDCQ L -^XTMP(NAM)
69 Q
70 ;
71MDCLIST(FORM,PI,LIST) ; -- Compile one list
72 N I,J,X,Y,IBDF,CH,CODE
73 G:$G(^IBE(357.6,+$G(PI),0))=""!($G(^IBE(357.2,+$G(LIST),0))="")!($G(^IBE(357,+$G(FORM),0))="") MDCLQ
74 S IBDF("PI")=PI,IBDF("IEN")=LIST,IBDF("TYPE")="LIST"
75 K ^XTMP("IBD"_FORM,"IBD-LST",PI,LIST)
76 D OBJLST^IBDFRPC1(.CH,.IBDF)
77 M ^XTMP("IBD"_FORM,"IBD-LST",PI,LIST)=CH
78 ;
79 ; -- Expand choices
80 S HDR=""
81 S IBDI=0 F S IBDI=$O(^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,IBDI)) Q:'IBDI S CH=^(IBDI) D
82 .I $P(CH,"^",7)=0 S HDR=$P(CH,"^") Q
83 .I $P(CH,"^",8)="" S $P(^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,I),"^",8)=HDR
84 .;
85 .; -- build array of text
86 .I $P(CH,"^",1)'="" D
87 ..I '$D(^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"TEXT",$$UP^XLFSTR($P(CH,"^",1)))) S ^XTMP("IBD"_FORM,PI,LIST,"TEXT",$$UP^XLFSTR($P(CH,"^",1)),1)=IBDI Q
88 ..S CNT=$O(^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"TEXT",$$UP^XLFSTR($P(CH,"^",1)),""),-1)
89 ..S ^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"TEXT",$$UP^XLFSTR($P(CH,"^",1)),CNT+1)=IBDI
90 .;
91 .; -- build array of codes
92 .S CODE=$S($P(CH,"^",2)'="":$P(CH,"^",2),1:$P(CH,"^",3)) Q:CODE=""
93 .I '$D(^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"CODE"," "_CODE,1)) S ^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"CODE"," "_CODE,1)=IBDI Q
94 .S CNT=$O(^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"CODE"," "_CODE,""),-1) S ^XTMP("IBD"_FORM,"IBD-LST",PI,LIST,"CODE"," "_CODE,CNT+1)=IBDI
95 .Q
96 ;
97MDCLQ Q
98 ;
9918 ; -- Post init for data entry patch
100 D 14,CLNTMP,XREF,PIDIM,PIUP
101 Q
102 ;
10314 ;Populate the .14 FIELD IN FILE 357.96
104 S ZTIO="",ZTDTH=$H,ZTRTN="DQ^IBDFDE5",ZTDESC="IBD-Patch 2 populate 357.96;.14" D ^%ZTLOAD
105 D BMES^XPDUTL("Queing the Conversion to populate the .14 field (NO APPOINTMENT ENTRY) of file 357.96 ENCOUNTER FORM TRACKING......")
106 Q
107 ;
108DQ ;
109 N IBDFIFN,IBDFCLIN,IBDFAPPT,IBDFDFN
110 S IBDFIFN=0
111 F S IBDFIFN=$O(^IBD(357.96,IBDFIFN)) Q:'IBDFIFN S IBDFNODE=$G(^IBD(357.96,IBDFIFN,0)) S IBDFDFN=$P(IBDFNODE,"^",2),IBDFAPPT=$P(IBDFNODE,"^",3) I IBDFDFN,IBDFAPPT D
112 .S DIE="^IBD(357.96,",DA=IBDFIFN
113 .I $D(^DPT(+IBDFIFN,"S",IBDFAPPT)) S DR=".14////0"
114 .E S DR=".14////1"
115 .D ^DIE K DA,DR,DIE
116 ;W !!,"DONE"
117 Q
118CLNTMP ; -- kill tmp globals, on load, forces rebuild with updates
119 K ^TMP("IBD-LST"),^TMP("IBD-OBJ")
120 Q
121 ;
122XREF ;
123 D BMES^XPDUTL("Removing 'RECD' cross-reference on PRINTED FORM ID field")
124 S DA=0
125 F S DA=$O(^DD(357.96,.01,1,DA)) Q:DA<1 I $G(^(DA,0))="357.96^RECD^MUMPS" S DIK="^DD(357.96,.01,1,",DA(2)=357.96,DA(1)=.01 D ^DIK K DIK
126 ;
127 D BMES^XPDUTL("Removing 'RECD2' cross-reference on DATE/TIME RECEIVED IN VISTA field")
128 S DA=0
129 F S DA=$O(^DD(357.96,.06,1,DA)) Q:DA<1 I $G(^(DA,0))="357.96^RECD2^MUMPS" S DIK="^DD(357.96,.06,1,",DA(2)=357.96,DA(1)=.06 D ^DIK K DIK
130 ;
131 D BMES^XPDUTL("Removing 'RECD3' cross-reference on DATE/TIME PRINTED field")
132 S DA=0
133 F S DA=$O(^DD(357.96,.05,1,DA)) Q:DA<1 I $G(^(DA,0))="357.96^RECD3^MUMPS" S DIK="^DD(357.96,.05,1,",DA(2)=357.96,DA(1)=.05 D ^DIK K DIK
134 K DA
135 K ^IBD(357.96,"RECD")
136 Q
137 ;
138PIDIM ;
139 D BMES^XPDUTL("Updating PCE DIM OUTPUT TRANSFORM in file 357.6")
140 N IBD,LINE,PKG,NOD14,IEN
141 F IBD=1:1 S LINE=$P($T(OUTTRANS+IBD),";;",2) Q:LINE="" D
142 .S PKG=$P(LINE,"^",2)
143 .S NOD14=$P(LINE,"^",3,99)
144 .S IEN=+$O(^IBE(357.6,"B",$E(PKG,1,30),0))
145 .Q:IEN<1
146 .I $P($G(^IBE(357.6,IEN,0)),"^")=PKG S ^IBE(357.6,IEN,14)=NOD14
147 Q
148OUTTRANS ;;
149 ;;61^INPUT PROVIDER^S Y=$$DSPLYPRV^IBDFN9(Y)
150 ;;62^INPUT VISIT TYPE^S Y=$$DSPLYCPT^IBDFN9(Y)
151 ;;102^PX INPUT VISIT TYPE^S Y=$$DSPLYCPT^IBDFN9(Y)
152 ;;
153PIUP ;
154 D BMES^XPDUTL("Updating Package Interface File for Data Entry")
155 N PKG,ENT,RTN,DYN,NODE18,IEN
156 F IBD=1:1 S LINE=$P($T(UPDATE+IBD),";;",2) Q:LINE="" D
157 .S PKG=$P(LINE,"^",2)
158 .S ENT=$P(LINE,"^",3)
159 .S RTN=$P(LINE,"^",4)
160 .S DYN=$P(LINE,"^",5)
161 .S NOD18=$P(LINE,"^",6,99)
162 .S IEN=+$O(^IBE(357.6,"B",$E(PKG,1,30),0))
163 .Q:IEN<1
164 .I $P($G(^IBE(357.6,IEN,0)),"^")=PKG D
165 ..S ^IBE(357.6,IEN,18)=NOD18
166 ..I $G(ENT)'="" S $P(^IBE(357.6,IEN,0),"^",2)=ENT
167 ..I $G(RTN)'="" S $P(^IBE(357.6,IEN,0),"^",3)=RTN
168 ..I $G(DYN)'="" S $P(^IBE(357.6,IEN,0),"^",14)=DYN
169 Q
170 ;
171UPDATE ;;
172 ;;59^INPUT PROCEDURE CODE (CPT4)^^^^S IBDF("OTHER")="81^I '$P(^(0),U,4)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"CPT Procedure Code")
173 ;;61^INPUT PROVIDER^PRVDR^IBDFN4^1^S IBDF("OTHER")="200^$$SCREEN^IBDFDE10(+Y)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Provider")
174 ;;62^INPUT VISIT TYPE^^^^S IBDF("OTHER")="357.69^I '$P(^(0),U,4)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Visit Type (EM) Code")
175 ;;69^INPUT DIAGNOSIS CODE (ICD9)^^^^S IBDF("OTHER")="80^I '$P(^(0),U,9)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Diagnosis Code")
176 ;;74^PX INPUT PATIENT ACTIVE PROBLEM^DSELECT^GMPLENFM^1^D LIST^IBDFDE2(.IBDSEL,.IBDF,"Active Problem")
177 ;;91^PX INPUT EDUCATION TOPICS^^^^S IBDF("OTHER")="9999999.09^I '$P(^(0),U,3)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Patient Education")
178 ;;92^PX INPUT EXAMS^^^^S IBDF("OTHER")="9999999.15^I '$P(^(0),U,4)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Exam")
179 ;;93^PX INPUT HEALTH FACTORS^^^^S IBDF("OTHER")="9999999.64^I '$P(^(0),U,10),$P(^(0),U,10)=""F"",'$P(^(0),U,11)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Health Factors")
180 ;;94^PX INPUT IMMUNIZATION^^^^S IBDF("OTHER")="9999999.14^I '$P(^(0),U,7)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Immunizations")
181 ;;97^PX INPUT SKIN TESTS^^^^S IBDF("OTHER")="9999999.28^I '$P(^(0),U,3)" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Skin Tests")
182 ;;99^PX INPUT VITALS^^^^D HNDPR^IBDFDE3(.IBDSEL,.IBDF)
183 ;;103^GMP INPUT CLINIC COMMON PROBLEMS^^^^S IBDF("LEXICON")=1,IBDF("OTHER")="757.01^" D LIST^IBDFDE2(.IBDSEL,.IBDF,"Diagnosis, Problem, or Term")
184 ;;
185 ;; -- Example of setting up a date/time prompt
186 ;;95^PX INPUT CHECKOUT TIME^^^^S IBDF("ASKDATE")=1 D HNDPR^IBDFDE3(.IBDSEL,.IBDF) K IBDF("ASKDATE")
187 ;;
188 ;; -- Example of setting up a multiple choice field
189 ;;100^PX INPUT VISIT CLASSIFICATION^^^^D MULT^IBDFDE4(.IBDSEL,.IBDF)
190 ;;
Note: See TracBrowser for help on using the repository browser.