source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFDE1.m@ 619

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

initial load of WorldVistAEHR

File size: 7.3 KB
Line 
1IBDFDE1 ;ALB/AAS - AICS Data Entry, Final check; 24-FEB-96 [ 11/12/96 2:12 PM ]
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**38,36**;APR 24, 1997
3 ; -- calls IBDFRPC4 to pass data to pce
4 ;
5% G ^IBDFDE
6 ;
7FINAL ; -- display everything selected and check okay
8 ; -- input IBDSEL :
9 ; $p1 := package interface ien (for input)
10 ; $p2 := code to send (may be internal or external)
11 ; $p3 := text to send
12 ; $p4 := hdr to send (optional)
13 ; $p5 := clinic lexicon pointer (optional)
14 ; $p6 := qualifier (i.e. primary or secondary)
15 ; $P7 :=
16 ; $p8 :=
17 ; $p9 :=
18 ; $p10 := external value of code (optional)
19 ;
20 N I,X,DIR,DIRUT,DUOUT,DTOUT,PARAM,IBDCNT,MODSAVE,XX
21 K IBDREDIT
22 I $G(IBDSEL(0))<1,$G(IBDCO("CO"))="",$G(IBDCO("SC"))="",$G(IBDCO("AO"))="",$G(IBDCO("IR"))="",$G(IBDCO("EC"))="",$G(IBDCO("MST"))="" W !!,"Nothing Selected!!" S IBDF("NOTHING")=1 Q
23 ;
24 S (IBDCNT,IBQUIT)=0
25 W !!,"You have entered the following:"
26 D WRITE^IBDFDE0(IBDF("SDOE"),.IBDCNT)
27 S I=0 F S I=$O(IBDSEL(I)) Q:I="" D
28 . S IBDCNT=IBDCNT+1
29 . K MODSAVE
30 . D LINE(IBDCNT,IBDSEL(I)) D
31 .. I $D(IBDSEL(I,"MODIFIER")) D MODLIST(I)
32 S DIR(0)="Y",DIR("B")="No",DIR("A")="Is this Okay" D ^DIR
33 I $D(DIRUT) S IBQUIT=1 W !!,"No action Taken",! G FINALQ
34 I Y<1 D DEL S:'IBQUIT IBDREDIT=1 G FINALQ
35 I Y'=1 G FINALQ
36 M IBDF=IBDSEL
37 ;I $G(^DPT(DFN,"S",IBDF("APPT"),0))="" D FNDAPPT I 'IBDOK W !!,"No action Taken",! Q
38 I $G(IBDF("SAVE")) M ^TMP("IBD-SAVED",$J)=IBDF ;don't save checkout data
39 M IBDF=IBDCO
40 W !!,"Sending Data to PCE..."
41 D SEND^IBDFRPC4(.RESULT,.IBDF)
42 W $S($G(RESULT(0)):" Successful",1:" Unsuccessful"),!!
43 I $D(IBDSTRT) S IBDFIN=$H S IBDTIME=$$HDIFF^XLFDT(IBDFIN,IBDSTRT,2)
44 S PARAM=$P($G(^IBD(357.09,1,0)),"^",7)
45 I PARAM=3 D DISP
46 I PARAM,$D(PXCA("ERROR"))!($D(PXCA("WARNING"))) D ERR
47 I $G(IBDTIME) D
48 .W !!,"Elapsed time for data entry: ",IBDTIME," seconds.",!!
49 .S IBDF("SECONDS")=IBDTIME,IBDF("USER")=DUZ
50 .D ETIME^IBDFBK1(.RESULT,.IBDF)
51 I '$G(IBDREDIT),$P($G(^IBD(357.09,1,0)),"^",6) D MAKAPPT
52FINALQ K SDFN,ZTSK,SECONDS,LEX,ORVP,SEL1,PXCAVSIT,PXCA,PXCASTAT
53 Q
54 ;
55DEL ; -- delete selected entry
56 N I,J,DIR,DIRUT,DUOUT,DTOUT,CNT,CNTD,IBD,IBD1,IBDEL
57 S CNT=0
58 W !
59 S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to delete an item"
60 S DIR("?")="Enter 'Yes' if you want to delete an item or 'No' to just add more items."
61 D ^DIR K DIR
62 I $D(DIRUT) S IBQUIT=1 Q
63 Q:Y<1
64 S IBD=0 F S IBD=$O(IBDSEL(IBD)) Q:IBD="" S CNT=CNT+1,IBDEL(CNT)=IBD D LINE(CNT,IBDSEL(IBD)) D
65 . I $D(IBDSEL(IBD,"MODIFIER")) D MODLIST(IBD)
66 Q:CNT<1
67 S DIR(0)="L^1:"_CNT D ^DIR K DIR
68 I $D(DIRUT) W !,"Nothing Deleted" Q
69 F IBD1=1:1 S IBDEL=$P(Y,",",IBD1) Q:IBDEL="" D
70 .W !,"Deleting "_IBDEL
71 .S QLFR=$P(IBDSEL(IBDEL(IBDEL)),"^",6)
72 .I QLFR'="" K IBDPI(+IBDSEL(IBDEL(IBDEL)),QLFR)
73 .K IBDPI(+IBDSEL(IBDEL(IBDEL)),IBDEL(IBDEL))
74 .K IBDSEL(IBDEL(IBDEL))
75 .K IBDEL(IBDEL)
76 .S CNTD=$G(CNTD)+1
77 I $G(CNTD)=CNT S IBDSEL(0)=0
78 W !
79DELQ Q
80 ;
81LINE(CNT,IBD) ; -- write one line of text
82 W !,?3,CNT,?7,$S($P(IBD,"^",8)'="":$P(IBD,"^",8),1:$E($P($P($G(^IBE(357.6,+IBD,0)),"^"),"INPUT ",2),1,22)),?31,$E($P(IBD,"^",3),1,30)
83 W ?62,$S($P(IBD,"^",10)'="":$P(IBD,"^",10),$P($G(^IBE(357.6,+IBD,0)),"^")="GMP INPUT CLINIC COMMON PROBLEMS":$$LEX($P(IBD,"^",2)),1:$P(IBD,"^",2))
84 W ?70,$E($S($P(IBD,"^",9)'="":$P(IBD,"^",9),1:$P(IBD,"^",6)),1,10)
85 S SLCTN=$P(IBD,"^",12) I SLCTN'="" D
86 . ;list modifiers
87 . N CODE
88 . Q:'$D(^IBE(357.3,SLCTN,3))
89 . S CODE=$P($G(^IBE(357.3,SLCTN,0)),"^") Q:CODE=""
90 . W !?11,"Associated Modifier(s): "
91 . S MOD=0 F S MOD=$O(^IBE(357.3,SLCTN,3,MOD)) Q:'MOD D
92 .. S MODSAVE=$P($G(^IBE(357.3,SLCTN,3,MOD,0)),"^")
93 .. S MODSAVE(MODSAVE)=""
94 .. S XX=$P($$MODP^ICPTMOD(CODE,MODSAVE,"E"),"^",2)
95 .. W !,?15,MODSAVE,?20,XX
96 Q
97 ;
98MODLIST(I) ; -- list modifiers if in array
99 ;
100 W !?11,"Selected during Data Entry Modifier(s): "
101 N CODE
102 S CODE=$P($G(IBDSEL(I)),"^",2)
103 S MOD=0 F S MOD=$O(IBDSEL(I,"MODIFIER",MOD)) Q:'MOD D
104 .; --quitting if duplicate entry
105 . Q:$D(MODSAVE(IBDSEL(I,"MODIFIER",MOD)))
106 . S MODSAVE=IBDSEL(I,"MODIFIER",MOD)
107 . S XX=$P($$MODP^ICPTMOD(CODE,MODSAVE,"E"),"^",2)
108 . W !,?15,MODSAVE,?20,XX
109 Q
110LEX(VAL) ; -- get output of lexicon entry
111 I $D(^LEX)>1 S X="LEXU" X ^%ZOSF("TEST") I $T S VAL=$$ICDONE^LEXU(VAL) S:$L(VAL)<1 VAL=799.9 Q VAL ;clinical lexicon next version to be in ^LEX
112 S X="GMPTU" X ^%ZOSF("TEST") I $T S VAL=$$ICDONE^GMPTU(VAL) S:$L(VAL)<1 VAL=799.9 Q VAL
113 Q 799.9
114 ;
115MAKAPPT ; -- ask make appointment stuff
116 N %I,%T,I,J,X,Y,DIC,DA,DIR,DIRUT,DUOUT,IBDFN,RTCLEX,SDALLE,SDATD,SDAV,SDCLN,SDDECOD,SDEC,SDEMP,SDFN,SDHX,SDLOCK,SDMADE,SDNOT,SDOEL,SDPL,SDRE,SDRT,SDSOH,SDT,SDTTM,SDY,VSITON,VSIT,XQXFLG
117 ;
118 I $G(IBDF("NOAPPT")) G MAKAPQ
119 S DIR("?")="Enter 'Yes' to make another appointment for this patient or 'No' if no appointment is to be made."
120 S DIR(0)="Y",DIR("A")="Do you wish to make a follow-up appointment for "_$P(^DPT(IBDF("DFN"),0),"^")
121 D ^DIR K DIR
122 I $D(DUOUT)!($D(DTOUT)) S IBQUIT=1 G MAKAPQ
123 I Y<1 G MAKAPQ
124 ;
125 S (SDFN,IBDFN,DFN)=$G(IBDF("DFN")) ;use same patient, don't ask patient, ask clinic
126 ;S SDCLN=IBDF("CLINIC") ;use same clinic, don't ask clinic
127 D ^SDM
128 S DFN=IBDFN K SDFN
129MAKAPQ Q
130 ;
131ERR ; -- if processing of errors is on do display
132 ; ask if want to re-edit
133 N I,J,ERR,LCNT,DIR,DIRUT,DUOUT
134 S LCNT=0
135 D EW^IBDFBK2(.ERR,.PXCA,.LCNT)
136 ;
137 W !!!,"The following Error(s) occurred while validating data in PCE for: ",$P($G(^DPT(IBDF("DFN"),0)),"^")
138 S I=0 F S I=$O(ERR(I)) Q:'I W !?4,$E(ERR(I),1,75) I $L(ERR(I))>75 W !?10,$E(ERR(I),76,140)
139 W !
140 Q:$G(IBDF("SAVE"))
141 S DIR(0)="Y",DIR("B")="Yes",DIR("A")="Do you want to Re-Edit"
142 D ^DIR K DIR
143 I Y=1 D
144 .S IBDREDIT=1
145 .K IBDF("CO"),IBDF("IR"),IBDF("SC"),IBDF("EC"),IBDF("AO"),IBDF("MST")
146 .S I=0 F S I=$O(IBDF(I)) Q:'I K IBDF(I)
147 I $D(DIRUT) S IBQUIT=1
148 Q
149 ;
150DISP ; -- display data based on pxca array
151 N I,LST,LCNT
152 S LCNT=0
153 D LSTDATA^IBDFBK3(.LST,.PXCA,.LCNT)
154 W !!!,"The following data was sent to PCE for: ",$P($G(^DPT(IBDF("DFN"),0)),"^")
155 W !,?4,"Clinic: ",$P($G(^SC(+$P($G(PXCA("ENCOUNTER")),"^",3),0)),"^")," at ",$$FMTE^XLFDT(+$G(PXCA("ENCOUNTER")))
156 S I=0 F S I=$O(LST(I)) Q:'I W !?4,$E(LST(I),1,75) I $L(LST(I))>75 W !?10,$E(LST(I),76,140)
157 W !
158 Q
159 ;
160FNDAPPT ; -- if form is not associated with an appointment see any in clinic
161 I $G(IBDSAEOK) S IBDOK=1 G FNDQ
162 N IBDI,IBDJ,X,NODE,CNT,IOINHI,IOINORM,NEWAPPT,CLNAM,FORMLST,DIR,DIRUT,DUOUT,DTOUT
163 S X="IOINHI;IOINORM" D ENDR^%ZISS
164 S IBDI=$E(IBDF("APPT"),1,7),IBDJ=IBDI+.24,CNT=0
165 F S IBDI=$O(^DPT(DFN,"S",IBDI)) Q:'IBDI!(IBDI>IBDJ) D G:CNT<1 FNDQ
166 .S NODE=$G(^DPT(DFN,"S",IBDI,0))
167 .Q:+NODE'=IBDF("CLINIC")
168 .S CNT=CNT+1,CLNAM=$E($P(^SC(IBDF("CLINIC"),0),"^"),1,20),NEWAPPT(CNT)=IBDI
169 .I CNT=1 W $C(7),!!,IOINHI,"Warning:"," You are about to create a stand alone visit for: ",IOINORM,!,$E($P(^DPT(DFN,0),"^"),1,25),?27,CLNAM,?49,$$FMTE^XLFDT(IBDF("APPT"))
170 .S FORMLST=$$FINDID^IBDF18C(DFN,IBDI,"",1)
171 .W !,IOINHI,"Patient has appointment in ",CLNAM,?49,$$FMTE^XLFDT(IBDI)," ID: ",$TR($E(FORMLST,1,($L(FORMLST)-1)),"^",","),IOINORM
172 ;
173 W ! S IBDOK=$$ASKYN^IBDFDE0("Okay to Create Stand Alone Encounter",0) W !
174 I $G(IBDOK)<0 S IBDOK=0
175 G:IBDOK FNDQ
176 ;
177 ; -- ask if want to use appt. date time
178 I CNT=1 D
179 .S IBDOK=$$ASKYN^IBDFDE0("Okay to use "_$$FMTE^XLFDT(NEWAPPT(1))_" appointment date/time",1) W !
180 .I $G(IBDOK)<0 S IBDOK=0
181 .I IBDOK S IBDF("APPT")=NEWAPPT(1)
182 ;
183 I CNT>1 D
184 .S DIR("A")=""
185 .S DIR(0)=""
186FNDQ Q
Note: See TracBrowser for help on using the repository browser.