source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFDE6.m@ 1607

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

initial load of FOIAVistA 6/30/08 version
File size: 8.8 KB
Line 
1IBDFDE6 ;ALB/AAS - AICS Manual Data Entry, Entry point by clinic ; 29-APR-96
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**11,51**;APR 24, 1997
3 ;
4 W !,?4,"** This option is OUT OF ORDER **" QUIT ;Code set Versioning
5 ;
6% N %,%H,C,I,J,X,Y,ADD,DEL,ASKOTHER,DIR,DIC,DA,CNT,DFN,DIRUT,DUOUT,DTOUT,POP,RTN,FRMDATA,IBY,IBQUIT,IBDF,IBDOBJ,IBDPTSTI,IBDPTSTE,IBDPTNM,IBDPTDTI,SEL,IBD,IBDCKOUT
7 N IBDPTDTE,IBDFMNME,IBDFMIEN,IBDFMSTI,IBDFMSTE,IBDFMIDI,IBDCLNME,IBFORM,IBDCLNPH,IBDPID,IBDPTPRI,IBDSEL,IBDPI,IBDCO,PXCA,SDCLST,PXCASTAT,PXKNODA,PXKNODB,IBDREDIT,IBDASK,IBDPRE,IBDX,ANS,CLNAME,CLSETUP,IBDSC,FORM,FORMLST,IBDFDT,IBD
8 ;
9 I '$D(DT) D DT^DICRW
10 D HOME^%ZIS
11 W !!,"Data Entry of Encounter Forms (by Clinic)",!!
12 ;
13STRT ; -- ask for Clinic, date then patient.
14 ; Only list patients w/no data entry
15 ; find all forms for appt., then go through 1 at a time
16 ;
17 D END
18 S IBQUIT=0
19 S (IBDSC,IBDF("CLINIC"))=$$SELCL G:IBQUIT STRTQ
20 I IBDSC<1 S IBQUIT=1 G STRTQ
21 S CLNAME=$P($G(^SC(+IBDSC,0)),"^")
22 S CLSETUP=$G(^SD(409.95,+$O(^SD(409.95,"B",+IBDSC,0)),0))
23 ;
24APPT W ! S IBDFDT=$$SELAP(.IBDF) G:IBQUIT STRTQ
25 I IBDFDT<0 W !! G STRT
26 ;
27 D BLD
28 I '$D(^TMP("IBD-PL",$J,IBDF("CLINIC"))) W !!,"No appointments on that Date!",!! G APPT
29 ;
30OVER D HDR ;,LIST
31 W !! D SELPT G:IBQUIT STRTQ
32 S IBDF("OPTION")=1
33 I $G(RESULT)="" G APPT
34 I $G(RESULT)=-1 G OVERQ
35 S (DFN,IBDF("DFN"))=+RESULT,IBDF("APPT")=$P(RESULT,"^",2)
36 S FORMLST=$$FINDID^IBDF18C(DFN,IBDF("APPT"),"",1)
37 I FORMLST]"" I IBDF("CLINIC")'=$P(^IBD(357.96,+FORMLST,0),"^",10) S FORMLST=""
38 I FORMLST="" W !,"No forms Printed for Patient" D ANYWAY I IBQUIT G STRTQ
39 I FORMLST="" G OVERQ ;D PAUSE^IBDFDE G OVERQ
40 F IBDX=1:1 S IBDF("FORM")=$P(FORMLST,"^",IBDX) Q:IBDF("FORM")="" I IBDF("FORM")'="" D EN^IBDFDE K IBDSEL,IBDPI Q:IBQUIT
41 W !!
42 ;S IBDF("CLINIC")=IBDSC
43OVERQ G OVER
44 ;
45STRTQ ;D PAUSE^IBDFDE
46 G:IBQUIT END
47 G APPT
48 ;
49ANYWAY ; -- if no forms available ask if want to enter form anyway
50 ; all to use default form, clinic setup,or any form
51 ;
52 N X,Y,DIR,DIRUT
53 S DIR("?")="If you wish to enter data for this patient anyway, chose whether to use the default form, select any form, or use the clinic setup. Answer None if you don't wish to enter any data."
54 S DIR("A")="Enter Data from [A]ny form, [C]linic Setup, [D]efault, [N]one: "
55 S DIR(0)="SA^A:ANYFORM;C:CLINIC SETUP;D:DEFAULT;N:NONE",DIR("B")="CLINIC SETUP"
56 I '$D(CLSETUP),+$G(IBDF("CLINIC")) S CLNAME=$P($G(^SC(+IBDF("CLINIC"),0)),"^"),CLSETUP=$G(^SD(409.95,+$O(^SD(409.95,"B",+IBDF("CLINIC"),0)),0))
57 I CLSETUP="" S DIR("B")="DEFAULT" W !,"No Forms Defined for Clinic"
58 D ^DIR K DIR
59 I $D(DUOUT)!($D(DTOUT)) S IBQUIT=1 G ANYWAYQ
60 I $D(DIRUT) G ANYWAYQ
61 S ANS=Y
62 I ANS="N" G ANYWAYQ
63 ;
64 I ANS="D" D G ANYWAYQ
65 .S IBFORM=$P($G(^IBD(357.09,1,0)),"^",4)
66 .I IBFORM="" S IBFORM=$O(^IBE(357,"B","PRIMARY CARE SAMPLE V2.1",0))
67 .S FORMLST=$$OTHFRM(IBFORM)
68 .Q
69 ;
70 I ANS="A" D G ANYWAYQ
71 .S DIC("S")="I $P(^(0),U)'=""GARBAGE"",$P(^(0),U)'=""TOOL KIT"""
72 .S DIC="^IBE(357,",DIC(0)="AEQM" D ^DIC K DIC Q:+Y<1
73 .S IBFORM=+Y
74 .S FORMLST=$$OTHFRM(IBFORM)
75 .Q
76 ;
77 I ANS="C" D G ANYWAYQ
78 .F IBD=2,6,8,9,3,4 S IBFORM=$P(CLSETUP,"^",IBD) I IBFORM W ! S FORMLST=FORMLST_$$OTHFRM(IBFORM)_"^"
79 .I FORMLST="" W !!,"No forms defined for clinic"
80 .Q
81ANYWAYQ Q
82 ;
83OTHFRM(IBFORM) ; -- if no form printed, add form tracking entry,
84 ; -- compile form if necessary return form list
85 N FORMID,FORMLST
86 S FORMID=$P($G(^IBE(357,IBFORM,0)),"^",13)
87 I FORMID="" D
88 .W !,"Please wait, Creating the necessary entry..."
89 .L +^IBE(357,IBFORM):1
90 .S FORMID=$$FORMTYPE^IBDF18D(1) W "."
91 .S $P(^IBD(357.95,FORMID,0),"^",21)=IBFORM W "."
92 .S $P(^IBE(357,IBFORM,0),"^",13)=FORMID
93 .S:$P(^IBE(357,IBFORM,0),"^",13) ^IBE(357,"ADEF",$P(^IBE(357,IBFORM,0),"^",13),IBFORM)=""
94 .L -^IBE(357,IBFORM)
95 S FORMLST=+$$FID^IBDF18C(DFN,IBDF("APPT"),1,FORMID,IBDF("CLINIC"))
96 S DIE="^IBD(357.96,",DR=".11////20",DA=FORMLST D ^DIE K DA,DR,DIC,DIE
97 ;
98 Q FORMLST
99 ;
100SELCL() ; -- select clinic
101 S IBQUIT=0
102 N DIR,DA,DR,DIC,DIE,X,Y,ANS,DIRUT
103 S ANS=-1
104 S DIR("?")="Enter the name of the clinic that you are entering encounter forms for."
105 S DIR("S")="I $P(^(0),U,3)=""C"""
106 S DIR(0)="PO^44:AEQM",DIR("A")="Select Clinic" D ^DIR K DIR,DA,DR,DIC
107 I $D(DUOUT)!($D(DTOUT)) S IBQUIT=1 G SELCLQ
108 I $D(DIRUT) G SELCLQ
109 S ANS=+Y
110SELCLQ Q ANS
111 ;
112 ;
113SELAP(IBDF) ; -- select appointment date for a clinic
114 S IBQUIT=0
115 N DIR,DA,DR,DIC,DIE,X,Y,ANS,DIRUT
116 S ANS=-1
117 ;I $G(LASTDATE)?7N S DIR("B")=$$FMTE^XLFDT(LASTDATE)
118 ;R !,"Appointment Date: ",X:$G(DTIME)
119 S DIR(0)="DO^:DT:EX",DIR("A")="Appointment Date"
120 S DIR("?")="Enter the date for the clinic that you wish to enter encounter forms for"
121 S DIR("??")="^D APDT^IBDFDE6"
122 D ^DIR K DIR
123 I $D(DUOUT)!($D(DTOUT)) S IBQUIT=1 G SELAPQ
124 I $D(DIRUT) G SELAPQ
125 S ANS=+Y
126SELAPQ Q ANS
127 ;
128SELPT ; -- select patient(s) to process
129 S IBDCLIN=IBDF("CLINIC") N ARRAY,CNT,IBD K IBDF,IBDCO,PXCA,SEL S IBDF("CLINIC")=IBDCLIN K IBDCLIN
130 S (ARRAY,RESULT,ANS)="",(IBQUIT,CNT)=0
131 S DIR("?")="Enter the listed number or the name of the patient or the last 4 number of the SSN or the first letter of the last name with the last 4 numbers of the SSN."
132 S DIR("??")="^D LIST^IBDFDE6"
133 S DIR(0)="FO^1:30",DIR("A")="Select Patient"
134 D ^DIR K DIR
135 I $D(DUOUT)!($D(DTOUT)) S IBQUIT=1 G SELQ
136 S ANS=$$UP^XLFSTR(Y)
137 I ANS="" G SELQ
138 I $D(DIRUT) S IBQUIT=1 G SELQ
139 I ANS=+ANS S ARRAY="IBD-PL" I $D(^TMP(ARRAY,$J,IBDF("CLINIC"),ANS)) S RESULT=^(ANS) W " ",$P($G(^DPT(+RESULT,0)),"^") G SELQ
140 ;
141 I ANS?4N S ARRAY="IBD-PL4" D ARRAY(ARRAY,ANS) G FIND
142 I ANS?1A4N S ARRAY="IBD-PLB" D ARRAY(ARRAY,ANS) G FIND
143 S ARRAY="IBD-PLN" D ARRAY(ARRAY,ANS) D G FIND
144 .S NAME=ANS F S NAME=$O(^TMP(ARRAY,$J,IBDF("CLINIC"),NAME)) Q:$E(NAME,1,$L(ANS))'=ANS D ARRAY(ARRAY,NAME)
145 G SELQ
146FIND ;find appropriate pt appt from array
147 I CNT=1 S RESULT=$G(^TMP(ARRAY,$J,IBDF("CLINIC"),$P(IBD(CNT),"^",2),+IBD(CNT))) D:$D(RESULT) G SELQ
148 .I ARRAY="IBD-PLN" W " ",$E($P($G(^DPT(+RESULT,0)),"^"),($L(ANS)+1),999) Q
149 .W " ",$P($G(^DPT(+RESULT,0)),"^")
150 S RESULT=$$MULT^IBDFDE61(CNT,.IBD) D:$D(RESULT)
151 .W " ",$P($G(^DPT(+RESULT,0)),"^")
152 I RESULT="" W $C(7)," ?? Not Found" S RESULT=-1
153 ;
154SELQ Q
155 ;
156ARRAY(ARRAY,ANS) ; -- bld array of multiple patients
157 ; -- required variables: array = name x-ref; ans = name of selection
158 S A=0 F S A=$O(^TMP(ARRAY,$J,IBDF("CLINIC"),ANS,A)) Q:'A S CNT=CNT+1,IBD(CNT)=A_"^"_ANS
159 Q
160BLD ; -- Find all appointments for a date
161 K ^TMP("IBD-PL",$J),^TMP("IBD-PLN",$J)
162 N SC,IBD,IBD1,NODE,SNODE
163 S IBD=IBDFDT,SC=IBDF("CLINIC"),CNT=0
164 F S IBD=$O(^SC(SC,"S",IBD)) Q:'IBD!(IBD>(IBDFDT+.24)) D
165 .S IBD1=0 F S IBD1=$O(^SC(SC,"S",IBD,1,IBD1)) Q:'IBD1 D
166 ..S NODE=$G(^SC(SC,"S",IBD,1,IBD1,0))
167 ..S SNODE=$G(^DPT(+NODE,"S",IBD,0))
168 ..S X=$P(SNODE,"^",2)
169 ..I X'="","CNAPCA"[X Q ;inpatient appointments are okay
170 ..S (DFN,IBDF("DFN"))=+NODE
171 ..S CNT=CNT+1
172 ..S ^TMP("IBD-PL",$J,SC,CNT)=DFN_"^"_IBD_"^"_SNODE
173 ..S ^TMP("IBD-PLN",$J,SC,$P(^DPT(DFN,0),"^"),CNT)=DFN_"^"_IBD_"^"_SNODE
174 ..S ^TMP("IBD-PLB",$J,SC,$E($P(^DPT(DFN,0),"^",1),1)_$E($P(^DPT(DFN,0),"^",9),6,9),CNT)=DFN_"^"_IBD_"^"_SNODE
175 ..S ^TMP("IBD-PL4",$J,SC,$E($P(^DPT(DFN,0),"^",9),6,9),CNT)=DFN_"^"_IBD_"^"_SNODE
176 Q
177 ;
178LIST ; -- print list of patients
179 N IBD,IBJ,FORM,STATUS,CNT,X,IBQUIT
180 S IBQUIT=0
181 S IBD=0 F S IBD=$O(^TMP("IBD-PL",$J,IBDF("CLINIC"),IBD)) Q:'IBD!(IBQUIT) S NODE=$G(^TMP("IBD-PL",$J,IBDF("CLINIC"),IBD)) D ONE(NODE,IBD) I '(IBD#15) D ASKPT^IBDFDE61(IBD)
182 Q
183 ;
184ONE(NODE,IBD1) ; -- write one line
185 N CNT,C
186 Q:$G(NODE)=""
187 S DFN=+NODE,APPT=$P(NODE,"^",2)
188 S FORM=$$FINDID^IBDF18C(DFN,APPT,"",1),STATUS="NO FORM PRINTED"
189 S CNT=0 F IBJ=1:1 S X=$P(FORM,"^",IBJ) Q:X="" S CNT=CNT+1
190 I +FORM S Y=$P($G(^IBD(357.96,+FORM,0)),"^",11),C=$P(^DD(357.96,.11,0),"^",2) D Y^DIQ S STATUS=Y
191 W !?2,IBD1,?5,$E($P(^DPT(DFN,0),"^"),1,18),?26,$P($G(^DPT(DFN,.36)),"^",4),?32,$$FMTE^XLFDT(+APPT),?52,$E($G(STATUS),1,24),?77,"("_CNT_")"
192 Q
193 ;
194APDT ; -- list last 30 days appointment dates in clinic
195 S (X,Y)=$$FMADD^XLFDT(DT,-62),CNT=0
196 F S X=$O(^SC(IBDF("CLINIC"),"S",X)) Q:'X!(X>DT) D
197 .I $E(X,1,7)=Y Q
198 .S Y=$E(X,1,7),CNT=CNT+1
199 .I CNT=1 W !!,"The following are valid Appointment dates in the past 60 days:"
200 .W:(CNT#4=1) !,?3,$$FMTE^XLFDT(Y)
201 .W:(CNT#4=2) ?20,$$FMTE^XLFDT(Y)
202 .W:(CNT#4=3) ?40,$$FMTE^XLFDT(Y)
203 .W:(CNT#4=0) ?60,$$FMTE^XLFDT(Y)
204 Q
205 ;
206HDR ; -- print Clinic header
207 N CNT,IBD,IBD1 W @IOF
208 S CNT=0
209 F IBD=2,6,8,9,3,4 S IBD1=$P(CLSETUP,"^",IBD) I IBD1 S CNT=CNT+1
210 W !," Clinic: ",$E(CLNAME,1,25) W ?40," Date: ",$$FMTE^XLFDT(IBDFDT)
211 S FORM=$P(CLSETUP,"^",2),IBDFMNME=$P($G(^IBE(357,+FORM,0)),"^")
212 W !," Basic Form: ",$E(IBDFMNME,1,25) W ?40," Active Forms: ",CNT
213 W !,"Appointments: ",$O(^TMP("IBD-PL",$J,IBDF("CLINIC"),""),-1)
214 W !,$TR($J(" ",IOM)," ","=")
215 Q
216 ;
217END K I,J,X,Y,DA,DR,DIC,DIE,DIR,DTOUT,DUOUT,DIRUT,IBDSEL,CHOICE,TEXT,TEXTU,RESULT,IBDPI,IBDCO,IBDF
218 K ^TMP("IBD-PL",$J),^TMP("IBD-PLN",$J),^TMP("IBD-PLB",$J),^TMP("IBD-PL4",$J),^TMP("IBD-MORE",$J),^TMP("IBD-PLCHK",$J)
219 K ^TMP("IBD-ASK",$J),^TMP("IBD-LCODE",$J),^TMP("IBD-LST",$J),^TMP("IBD-LTEXT",$J),^TMP("IBD-OBJ",$J)
220 Q
Note: See TracBrowser for help on using the repository browser.