source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFDE.m@ 1163

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

initial load of FOIAVistA 6/30/08 version
File size: 8.8 KB
Line 
1IBDFDE ;ALB/AAS - AICS Data Entry, Entry point by form ; 24-FEB-96
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**3,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
7 N IBDPTDTE,IBDFMNME,IBDFMIEN,IBDFMSTI,IBDFMSTE,IBDFMIDI,IBDCLNME,IBFORM,IBDCLNPH,IBDPID,IBDPTPRI,IBDSEL,IBDPI,IBDCO,PXCA,SDCLST,PXCASTAT,PXKNODA,PXKNODB,IBDREDIT,IBDASK,IBDPRE,IBDOK,IBD,IBDCKOUT
8 N ANS1,AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX
9 ;
10 I '$D(DT) D DT^DICRW
11 D HOME^%ZIS
12 W !!,"Data Entry of Encounter Forms (by Form)",!!
13 ;
14STRT ; -- ask for form id
15 D END
16 S DIR("?")="Enter the encounter form id, printed on the form. This is the second number from the left, just right of the label 'ID:'."
17 S DIR(0)="PO^357.96:AEQM",DIR("A")="Encounter Form ID" D ^DIR K DIR,DA,DR,DIC
18 I $D(DIRUT) G END
19 S IBDF("FORM")=+Y
20 D EN
21 ;
22STRTQ I '$P($G(^IBD(357.09,1,0)),"^",6) D PAUSE
23 G:IBQUIT END
24 W @IOF
25 Q:$G(IBDF("OPTION"))
26 G STRT
27 ;
28EN ; -- entry point to edit one form,
29 ; Input IBDF("FORM") := form number
30 ;
31 D:$D(XRTL) T0^%ZOSV
32 N IBDSTRT,IBDFIN,IBDTIME S IBDSTRT=$H
33 S IBQUIT=0
34 L +^IBD(357.96,IBDF("FORM")):5 I '$T W !!,"Form is currently being entered by another user, try again later!" S IBFLAG=1 G ENQ
35 I $G(^IBD(357.96,IBDF("FORM"),0))="" W !!,"Form Tracking Entry has been deleted, Data entry not available" S IBFLAG=1 G ENQ
36 ;
37OVER ; -- start here to re-edit an entry
38 N IOINHI,IOINORM
39 S X="IOINHI;IOINORM" D ENDR^%ZISS
40 S (IBQUIT,IBDF("KILL"))=0
41 D IDPAT^IBDFRPC3(.FRMDATA,IBDF("FORM"))
42 D EXPAND(FRMDATA)
43 I $P($G(^IBE(357,IBDFMIEN,0)),"^",12)'=1 W !!,"Form is not scannable. Data entry not available" S IBFLAG=1 G ENQ
44 ;
45 I '$G(IBDF("FRMDEF")) W !!,"Form Definition entry not defined for form tracking entry.",!,"Data entry not available." D ERR S IBFLAG=1 G ENQ
46 I $G(^IBD(357.95,+$G(IBDF("FRMDEF")),0))="" W !!,"Form Definition Entry has been deleted.",!,"Data entry not available." D ERR S IBFLAG=1 G ENQ
47 I $P($G(^IBD(357.95,+$G(IBDF("FRMDEF")),0)),"^",21)="" W !!,"Can not determine Encounter Form from Form Tracking entry.",!,"Data entry not available." D ERR S IBFLAG=1 G ENQ
48 I $G(^IBE(357,IBDFMIEN,0))="" W !!,"Encounter Form has been deleted. Data entry not available." D ERR S IBFLAG=1 G ENQ
49 I $G(^DPT(DFN,"S",IBDF("APPT"),0))'="",$P(^DPT(DFN,"S",IBDF("APPT"),0),"^",1)'=IBDF("CLINIC") W !!,"Form "_IBDF("FORM")_" is for an Appointment that has been canceled.",!,"Data entry not available." S IBFLAG=1 G ENQ
50 S X=$P($G(^DPT(DFN,"S",IBDF("APPT"),0)),"^",2) I X'="","^C^N^NA^CA^PC^PCA^"[("^"_X_"^") W !!,"Form "_IBDF("FORM")_" is for an Appointment that has been canceled or no-showed.",!,"Data entry not available." S IBFLAG=1 G ENQ
51 I '$P($G(^IBE(357,IBDFMIEN,0)),"^",5),'$G(IBDREDIT) D KILLTMP
52 I '$G(IBDREDIT) D HDR
53 ;
54 I IBDFMSTI=3!(IBDFMSTI=6) D I IBQUIT G ENQ ; -- already sent to pce
55 .Q:$G(IBDREDIT)
56 .S IBQUIT=1
57 .W !!,"Current form Status is ",IBDFMSTE
58 .W:'IBDCKOUT "."
59 .W:IBDCKOUT " and was checked out",!,"on "_$$FMTE^XLFDT(IBDCKOUT)_", Status is "_$G(IOINHI)_IBDPTSTE_$G(IOINORM)_".",!
60 .S DIR("?")="Data Entry on this form appears to have been completed by either scanning or data entry. Deleting or editing of data is not allowed with this option. Answer 'Yes' if you wish to continue, or 'No' if to select another form."
61 .S DIR("?",1)="Enter ?? to see a list of data stored in PCE."
62 .S DIR("?",2)=" "
63 .S DIR("??")="^D WRITE^IBDFRPC5"
64 .S DIR(0)="Y",DIR("B")="No",DIR("A")="Are you sure you want to continue"
65 .D ^DIR K DIR I Y=1 S IBQUIT=0
66 ;
67 I +IBDCKOUT>0 D I IBQUIT G ENQ ; -- already sent to pce
68 .I IBDFMSTI=3!(IBDFMSTI=6) Q
69 .Q:$G(IBDREDIT)
70 .S IBQUIT=1
71 .W !!,"Appointment has already been Checked Out on "_$$FMTE^XLFDT(IBDCKOUT)_",",!,"Status is: "_$G(IOINHI)_IBDPTSTE_$G(IOINORM)_".",!
72 .S DIR("?")="This appointment appears to have been checked out on "_$$FMTE^XLFDT(IBDCKOUT)_". Deleting or editing of data is not allowed with this option. Answer 'Yes' if you wish to continue, or 'No' if to select another form."
73 .S DIR("?",1)="Enter ?? to see a list of data stored in PCE."
74 .S DIR("?",2)=" "
75 .S DIR("??")="^D WRITE^IBDFRPC5"
76 .S DIR(0)="Y",DIR("B")="No",DIR("A")="Are you sure you want to continue"
77 .D ^DIR K DIR I Y=1 S IBQUIT=0
78 ;
79 I '$G(IBDREDIT),$G(^DPT(DFN,"S",IBDF("APPT"),0))="" S IBDOK=1 D FNDAPPT^IBDFDE1 I 'IBDOK W !!,"No action Taken",! G ENQ
80 ;
81 I '$D(^TMP("IBD-OBJ",$J,IBDFMIEN,0)) D FRMLSTI^IBDFRPC("^TMP(""IBD-OBJ"",$J,IBDFMIEN)",IBDFMIEN,"",1)
82 I $O(^TMP("IBD-OBJ",$J,IBDFMIEN,0))="" W !,$G(^TMP("IBD-OBJ",$J,IBDFMIEN,0)),! G ENQ
83 ;
84NEWOVER ; -- start here to re-edit an entry
85 I $G(IBDREDIT) D HDR
86 D LISTOB
87 D CHKOUT^IBDFDE0(IBDF("SDOE"))
88 I '$G(IBDF("PROVIDER PI"))!($G(IBDF("PROVIDER"))) D DEFPROV^IBDFDE21
89 ;
90 K ^TMP("IBD-PI-CNT",$J)
91 S I=0 F S I=$O(^TMP("IBD-OBJ",$J,IBDFMIEN,I)) Q:I="" D
92 .S X=$P($G(^TMP("IBD-OBJ",$J,IBDFMIEN,I)),"^",2)
93 .S ^TMP("IBD-PI-CNT",$J,X)=$G(^TMP("IBD-PI-CNT",$J,X))+1
94 ;
95 S I=0 F S I=$O(^TMP("IBD-OBJ",$J,IBDFMIEN,I)) Q:I=""!(IBQUIT) D
96 .S IBDOBJ=$G(^TMP("IBD-OBJ",$J,IBDFMIEN,I))
97 .S IBDF("PI")=+$P(IBDOBJ,"^",2),IBDF("TYPE")=$P(IBDOBJ,"^",5)
98 .S IBDF("IEN")=+$P(IBDOBJ,"^",6),IBDF("VITAL")=$P(IBDOBJ,"^",7)
99 .S IBDF("PAGE")=$P(IBDOBJ,"^",10)\80+1 ;scannable forms only
100 .Q:IBDF("IEN")<1!(IBDF("PI")<1)
101 .S IBDF("IBDF")=I
102 .S RTN=$G(^IBE(357.6,IBDF("PI"),18)) Q:RTN=""
103 .X RTN
104 .I $G(IBDF("GOTO"))'="" S I=IBDF("GOTO") K IBDF("GOTO")
105 K ^TMP("IBD-PI-CNT",$J)
106 D FINAL^IBDFDE1 I $G(IBDREDIT) S IBQUIT=0 G OVER
107 S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV
108 ;
109ENQ K SDFN
110 L -^IBD(357.96,IBDF("FORM"))
111 I $D(IBFLAG) D
112 .I $P($G(^IBD(357.09,1,0)),"^",6) W !! D PAUSE
113 .K IBFLAG
114 Q
115 ;
116HDR ; -- print patient header
117 W @IOF
118 W IBDPTNM,?32,IBDPID,?47,$$FMTE^XLFDT($P($G(^DPT(DFN,0)),"^",3))
119 W " Form ID: ",$P(^IBD(357.96,IBDF("FORM"),0),"^")
120 W !,$TR($J(" ",IOM)," ","=")
121 W !," Clinic: ",$E(IBDCLNME,1,25) W ?40," Date/Time: ",IBDPTDTE
122 W !," Form Name: ",$E(IBDFMNME,1,25) W ?40,"Form Status: ",$E(IBDFMSTE,1,25)
123 Q
124 ;
125LISTOB ; -- header for input object list
126 W !!,"Items available for Input:"
127 D WRITE^IBDFDE0(IBDF("SDOE"))
128 S I=0 F S I=$O(^TMP("IBD-OBJ",$J,IBDFMIEN,I)) Q:I="" D
129 .S X=$G(^TMP("IBD-OBJ",$J,IBDFMIEN,I))
130 .Q:'$P(X,"^",8)
131 .S Y=$S($P(X,"^",7)="":$P(X,"^"),1:$P(X,"^",7))
132 .I Y="INPUT PROVIDER" S IBDF("PROVIDER PI")=+$P(X,"^",2)
133 .I Y["INPUT " S Y=$P(Y,"INPUT ",2)
134 .W !?3,$E(Y,1,35)
135 .;
136 .F S I=I+1 S X=$G(^TMP("IBD-OBJ",$J,IBDFMIEN,I)) Q:X=""!($P(X,"^",8))
137 .Q:X=""
138 .S Y=$S($P(X,"^",7)="":$P(X,"^"),1:$P(X,"^",7))
139 .I Y="INPUT PROVIDER" S IBDF("PROVIDER PI")=+$P(X,"^",2)
140 .I Y["INPUT " S Y=$P(Y,"INPUT ",2)
141 .W ?40,$E(Y,1,35)
142 ;
143 W !,$TR($J(" ",IOM)," ","=")
144 Q
145 ;
146EXPAND(X) ; -- sets standard varibles for form data
147 S (DFN,IBDF("DFN"))=$P(X,"^",2) ;DFN
148 S IBDF("CLINIC")=$P(X,"^",7) ; clinic ien
149 S IBDPTNM=$P(X,"^") ; patient name
150 S IBDPID=$P(X,"^",3) ; Patient identifier (ssn)
151 S IBDFMNME=$P(X,"^",4) ; form name
152 S IBDFMIEN=$P(X,"^",5) ; form ien (pointer to 357)
153 S IBDCLNME=$P(X,"^",6) ; clinic name
154 S IBDCLNPH=$P(X,"^",8) ; clinic physical location
155 S IBDF("APPT")=$P(X,"^",9) ; appt date/time (fm format)
156 S IBDPTDTE=$P(X,"^",10) ;appt date (external format)
157 S IBDPTSTI=$P(X,"^",11) ;appt status (piece two of "S" node)
158 S IBDPTSTE=$P(X,"^",12) ;appt status expanded
159 S IBDFMSTI=$P(X,"^",13) ;form status (internal)
160 S IBDFMSTE=$P(X,"^",14) ;form status (expanded)
161 S IBDF("FRMDEF")=$P(X,"^",15) ;form id (pointer to 357.95)
162 S IBDPTPRI=$P(X,"^",16) ;default provider internal
163 S IBDPTPRI=$P(X,"^",17) ;default provider external
164 S IBDCKOUT=$P(X,"^",20) ;checkout dt
165 S IBDF("SDOE")=$$FNDSDOE(DFN,IBDF("APPT")) ;outpatient encounter
166 Q
167 ;Q $$GETAPT^SDVSIT2(DFN,APPT,IBDF("CLINIC"))
168 ; -- will create encounters for appts/unsch vsts (but not disps or ae?)
169 ;
170FNDSDOE(DFN,APPT) ; -- returns pointer to opt encounter for appt.
171 N SDOE
172 S SDOE=$P($G(^DPT(+$G(DFN),"S",+$G(APPT),0)),"^",20)
173 I SDOE="",$G(^DPT(+$G(DFN),"S",+$G(APPT),0))="" S SDOE=$P($$SDV^IBDFRPC3(DFN,APPT),"^",2)
174 Q SDOE
175 ;
176PAUSE ; -- go to bottom of screen and pause for return
177 Q:$G(IBQUIT)
178 N I,DIR,DIRUT,DUOUT,DTOUT I $Y'>(IOSL-3) W !!
179 I $E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR S IBQUIT='Y
180 Q
181 ;
182END K I,J,X,Y,DA,DR,DIC,DIE,DIR,DTOUT,DUOUT,DIRUT,IBDSEL,CHOICE,TEXT,TEXTU,RESULT,IBDPI,IBDCO,IBDF
183 K ^TMP("IBD-ASK",$J),^TMP("IBD-LCODE",$J),^TMP("IBD-LST",$J),^TMP("IBD-LTEXT",$J),^TMP("IBD-OBJ",$J)
184 Q
185 ;
186KILLTMP K ^TMP("IBD-OBJ",$J,IBDFMIEN),^TMP("IBD-LST",$J,IBDFMIEN),^TMP("IBD-ASK",$J,IBDFMIEN),^TMP("IB",$J,"INTERFACES"),^TMP("IBD-LTEXT",$J,IBDFMIEN),^TMP("IBD-LCODE",$J,IBDFMIEN)
187 Q
188 ;
189ERR ;
190 W !!,"Entry in Form Tracking file (357.96) = ",$S($G(IBDF("FORM"))'="":IBDF("FORM"),1:"NULL")
191 W !," Entry in Form Definition (357.95) = ",$S($G(IBDF("FRMDEF"))'="":IBDF("FRMDEF"),1:"NULL")
192 W !," Entry if Encounter Form file (357) = ",$S($G(IBDFMIEN)'="":IBDFMIEN,1:"NULL"),!
193 Q
Note: See TracBrowser for help on using the repository browser.