source: WorldVistAEHR/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXQUTL.m@ 1000

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

initial load of WorldVistAEHR

File size: 6.1 KB
Line 
1PXQUTL ;ISL/JVS - FUNCTION CALLS FOR DEBUGGING UTILITIES;8/29/96 10:34 ;3/26/97 09:25
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**4,14,29,121**;Aug 12, 1996
3 ;
4LCFLE() ;--LOCATION FILES
5 N LOCCNT,IHSCNT
6 ;--COUNT FROM LOCATION FILE 4
7 S LOCCNT=$P($G(^DIC(4,0)),"^",3)
8 ;--COUNT FROM IHS LOCATION FILE 9999999.06
9 S IHSCNT=$P($G(^AUTTLOC(0)),"^",3)
10 Q LOCCNT_"^"_IHSCNT
11 ;
12PTFLE() ;--PATIENT FILES
13 N DPTCNT,IHSCNT
14 ;--COUNT FROM DPT FILE 2
15 S DPTCNT=$P($G(^DPT(0)),"^",3)
16 ;--COUNT FORM AUPNPAT FILE 9000010
17 S IHSCNT=$P($G(^AUPNPAT(0)),"^",3)
18 Q DPTCNT_"^"_IHSCNT
19 ;
20RE(ENTRY) ;--RECORD ENTRY TO BE PRINTED
21 Q:$G(ENTRY)="" ""
22 I $L(ENTRY)>80 S ENTRY=$E(ENTRY,1,78)_""""
23 S PXQRECI=PXQRECI+1
24 S ^TMP("PXQRECORD",$J,PXQRECI,ENTRY)=""
25 Q ""
26 ;
27READ ;--READ
28 N VAR,I,ANS,DX,DY
29 W !,"**************************************************************"
30 S (DX,DY)=0 X ^%ZOSF("XY")
31 S I=0
32 I '$G(CNT) S CNT=0
33 F S I=$O(^TMP("PXQRECORD",$J,I)) Q:I="" D
34 .S VAR=$O(^TMP("PXQRECORD",$J,I,0))
35 .;--NEW 3/25/97
36 .I VAR["^" S VAR=$TR(VAR,"?!","11")
37 .;--END OF NEW
38 .I VAR'["?"&(VAR'["!") W !,$O(^TMP("PXQRECORD",$J,I,0))
39 .I VAR["?"!(VAR["!") W !,@$O(^TMP("PXQRECORD",$J,I,0))
40 .S CNT=CNT+1
41 .;I $Y>(IOSL-2) D
42 .I CNT>(IOSL-4) S CNT=0 D
43 ..I IOST["C-" R !,"ENTER to continue",ANS:DTIME
44 ..I $G(ANS)="^" S I=9999999999999
45 ..S (DX,DY)=0 X ^%ZOSF("XY")
46 K ^TMP("PXQRECORD",$J),PXQPRM
47 I IOST["C-",$G(ANS)'="^" R !," END OF DISPLAY",ANS:DTIME
48 ;I IOST["C-",$G(ANS)'="^" W !," END OF DISPLAY"
49 Q
50ASKPAT() ;Ask user for a patient
51 ;DIC on file 9000001
52 N DIR,DIC,Y,X,DA
53 S DIR(0)="PO^9000001:AEMQ"
54 S DIR("A")="Patient Name"
55 D ^DIR
56 Q $S(+Y>0:+Y,1:-1)
57 ;
58 ;
59ASKNUM() ;Ask user for a VISIT
60 ;DIC on file 9000010
61 N DIR,DIC,Y,X,DA
62 I $D(^DISV(DUZ,"PXQREP3")) S DIR("B")=$G(^DISV(DUZ,"PXQREP3"))
63 S DIR(0)="P^9000010:AEMQ"
64 S DIR("A")="Enter VISIT (UNIQUE ID or `1239)"
65 D ^DIR
66 Q $S(+Y>0:+Y,1:-1)
67 ;
68ASKNUM1() ;Ask user for a VISIT
69 ;DIC on file 9000010
70 N DIC,Y,X,DA
71 I $D(^DISV(DUZ,"PXQREP3")) S DIR("B")=$G(^DISV(DUZ,"PXQREP3"))
72 S DIR(0)="P^9000010:AEMQ"
73 S DIR("A")="Enter VISIT (UNIQUE ID or `1239)"
74 D ^DIR
75 Q $S(+Y>0:+Y,1:-1)
76 ;
77ASKENC() ;Ask user for a ENCOUNTER
78 ;DIC on file 409.68
79 N DIR,DIC,Y,X,DA
80 S DIR(0)="P^409.68:AEMQ"
81 S DIR("A")="Enter ENCOUNTER (`2344)"
82 D ^DIR
83 Q $S(+Y>0:+Y,1:-1)
84 ;
85 ;
86SOR(IEN) ;--SOURCE IF SELECTED FROM MENU
87 Q:'$G(IEN) ""
88 W $$RE^PXQUTL("!")
89 W $$RE^PXQUTL("----------------VISIT "_IEN_"---SOURCES-------------")
90 ;
91 ;
92 ;
93 S DATEC=$P($G(^AUPNVSIT(IEN,0)),"^",2) D
94 .S Y=DATEC D DD^%DT S DATEC=Y
95 W $$RE^PXQUTL("?5,""CREATED : ""_DATEC")
96 ;
97 ;
98 S DATEE=$P($G(^AUPNVSIT(IEN,0)),"^",13) D
99 .S Y=DATEE D DD^%DT S DATEE=Y
100 W $$RE^PXQUTL("?5,""EDITED : ""_DATEE")
101 ;
102 ;
103 S USER=$S(+$P($G(^AUPNVSIT(IEN,0)),"^",23)>0:$P(^VA(200,+$P($G(^AUPNVSIT(IEN,0)),"^",23),0),"^",1),1:"")
104 W $$RE^PXQUTL("?5,""USER : ""_USER")
105 ;
106 ;
107 I $D(^DIC(19,+$P($G(^AUPNVSIT(IEN,0)),"^",24),0)) D
108 .S OPTION=$S(+$P($G(^AUPNVSIT(IEN,0)),"^",24)>0:$P(^DIC(19,+$P($G(^AUPNVSIT(IEN,0)),"^",24),0),"^",2),1:"")
109 .W $$RE^PXQUTL("?5,""OPTION : ""_OPTION")
110 ;
111 I $D(^ORD(101,+$P($G(^AUPNVSIT(IEN,0)),"^",25),0)) D
112 .S PROTOCOL=$S(+$P($G(^AUPNVSIT(IEN,0)),"^",25)>0:$P(^ORD(101,+$P($G(^AUPNVSIT(IEN,0)),"^",25),0),"^",2),1:"")
113 .W $$RE^PXQUTL("?5,""PROTOCOL: ""_PROTOCOL")
114 ;
115 ;
116 I $D(^DIC(9.4,+$P($G(^AUPNVSIT(IEN,812)),"^",2),0)) D
117 .S PACKAGE=$S(+$P($G(^AUPNVSIT(IEN,812)),"^",2)>0:$P(^DIC(9.4,+$P($G(^AUPNVSIT(IEN,812)),"^",2),0),"^",1),1:"")
118 .W $$RE^PXQUTL("?5,""PACKAGE : ""_PACKAGE")
119 ;
120 ;
121 I $P($G(^AUPNVSIT(IEN,812)),"^",3) D
122 .I $D(^PX(839.7,$P($G(^AUPNVSIT(IEN,812)),"^",3),0)) D
123 ..S SOURCE=$S(+$P($G(^AUPNVSIT(IEN,812)),"^",3)>0:$P(^PX(839.7,+$P($G(^AUPNVSIT(IEN,812)),"^",3),0),"^",1),1:"")
124 ..W $$RE^PXQUTL("?5,""SOURCE : ""_SOURCE")
125 ;
126 W $$RE^PXQUTL("______________________________________________________")
127 Q ""
128 ;
129SDV ;--IF AN APPOINTMENT ON THAT DAY
130 N JUNK,PATIENT,ENTRY,CNT,CS,DAY,DAY2,ERR,POINT,STOP
131 N PXC,PXCC,PXCCC,PXCCCC,ICPTSTR
132 S (PXC,PXCC,PXCCC,PXCCCC,ICPTSTR)=""
133 I $G(BROKEN),'$G(DFN),'$G(PATIENT),'$G(DATE) Q
134 I $G(DFN) S PATIENT=DFN
135 I '$G(DFN) S (PATIENT,DFN)=$P(^AUPNVSIT(IEN,0),"^",5)
136 Q:'$G(PATIENT)
137 I '$G(BROKEN) S DATE=$P(^AUPNVSIT(IEN,0),"^",1)
138 S CNT=0
139 S DAY=$P(DATE,".",1)
140 F S DAY=$O(^SDV("C",PATIENT,DAY)) Q:DAY'[$P(DATE,".",1) S CNT=CNT+1 D
141 .W $$RE^PXQUTL("!")
142 .W !
143 .S REF="^SDV(DAY)"
144 .F S REF=$Q(@REF) Q:REF'[DAY S DAY2=$P($P(REF,"(",2),",") I '$G(ERR),$P($G(^SDV(DAY2,0)),"^",2)=PATIENT,REF'["""CS"",""B""," S ENTRY=REF_" = "_@REF W $$RE^PXQUTL(ENTRY) I REF["""PR""" D CPT2
145 .;---
146 .W $$RE^PXQUTL(" ")
147 .S CS=0 F S CS=$O(^SDV(DAY2,"CS",CS)) Q:CS'>0 D
148 ..Q:$P($G(^SDV(DAY2,0)),"^",2)'=PATIENT
149 ..S POINT=$P($G(^SDV(DAY2,"CS",CS,0)),"^",1)
150 ..S STOP=$G(^DIC(40.7,POINT,0))
151 ..W $$RE^PXQUTL("STOP CODE "_POINT_" = "_STOP)
152 .S PXC=0 F S PXC=$O(PXQSDV(PXC)) Q:PXC="" Q:'$D(PXQSDV) D
153 ..S PXCC=$O(PXQSDV(PXC,0))
154 ..;S PXCCC=$E($P($G(^ICPT(PXC,0)),"^",2),1,30)
155 ..;S PXCCCC=$P($G(^ICPT(PXC,0)),"^",1)
156 ..S ICPTSTR=$$CPT^ICPTCOD(PXC,DAY)
157 ..S PXCCC=$E($P(ICPTSTR,"^",3),1,30)
158 ..S PXCCCC=$P(ICPTSTR,"^",2)
159 ..S ENTRY="CPT "_$G(PXCCCC)_" - "_$G(PXCCC)_" = "_$G(PXCC)_" TIMES"
160 ..W $$RE^PXQUTL(ENTRY)
161 D CPT
162 K PXQSDV,DATE
163 W $$RE^PXQUTL(" ")
164 Q
165CPT ;--PROCEDURES
166 I $D(^AUPNVCPT("AD",VISIT)),CNT=0 W $$RE^PXQUTL("THERE ARE PROCEDURES IN PCE BUT NO RECORD IN SCHEDULING **")
167 Q
168CPT2 ;--COUNT PROCEDURES
169 N PXQC,PXQQ
170 S PXQQ=0
171 F I=1:1:5 S PXQC=$P(@REF,"^",I) I PXQC]"" D
172 .I $D(PXQSDV(PXQC)) S PXQQ=$O(PXQSDV(PXQC,0))
173 .K PXQSDV(PXQC,PXQQ)
174 .S PXQSDV(PXQC,(PXQQ+1))=""
175 .S PXQQ=0
176 Q
177 ;
178 ;
179EXP(ROOT,IEN) ;---EXPAND ENTRIES
180 N I,REF,REF2,ENTRY
181 I ROOT["SCE",$P($G(^SCE(IEN,0)),"^",6)']"",$G(PXQPRM)=1 D
182 .W $$RE^PXQUTL(" ~~~~ERROR~~~")
183 .W $$RE^PXQUTL("** There is more Than 1 PARENT OUTPATIENT ENCOUNTER pointing to the same VISIT**")
184 .W $$RE^PXQUTL(" ")
185 I ROOT["SCE"&($P($G(^SCE(IEN,0)),"^",6)']"") S PXQPRM=1
186 I $G(BROKEN),ROOT["AUPNVCPT" S (DFN,PATIENT)=$P($G(^AUPNVCPT(IEN,0)),"^",2)
187 I $G(BROKEN),ROOT["SCE",'$G(DATE) S DATE=$P($G(^SCE(IEN,0)),"^",1),(DFN,PATIENT)=$P($G(^SCE(IEN,0)),"^",2)
188 S REF=$P(ROOT,"""",1)_IEN_")"
189 S REF2=$P(ROOT,"""",1)_IEN
190 F S REF=$Q(@REF) Q:REF'[REF2 S ENTRY=REF_" = "_@REF W $$RE^PXQUTL($G(ENTRY))
191 W $$RE^PXQUTL(" ")
192 Q ""
Note: See TracBrowser for help on using the repository browser.