source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFIN.m@ 738

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

revised back to 6/30/08 version
File size: 9.6 KB
Line 
1PSOORFIN ;BIR/SAB-finish cprs orders ;5/14/07 09:47
2 ;;7.0;OUTPATIENT PHARMACY;**7,15,27,32,44,46,84,106,111,117,131,146,139,195,208**;DEC 1997;Build 39
3 ; Modified from FOIA VistA
4 ; Copyright (C) GNU GPL 2007 WorldVistA
5 ;
6 ;PSSLOCK-2789,PSDRUG-221,50.7-2223,55-2228,50.606-2174
7 I $G(PSOAFYN)'="Y" D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) D MSG^PSODPT G EX ;vfah
8 I $G(PSOAFYN)="Y" D:'$D(PSOPAR) ^PSOAFSET I '$D(PSOPAR) D MSG^PSODPT G EX ;vfah
9 D INST^PSOORFI2 I $G(PSOIQUIT) K PSOIQUIT G EX
10 I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1
11 I $G(PSOAFYN)'="Y" S (PSOFIN,POERR)=1 K PSOBCK,MEDA,MEDP,SRT,DIR D KQ S DIR("?")="^D ST^PSOORFI1",DIR("A")="Select By",DIR("B")="PATIENT",DIR(0)="SMB^PA:PATIENT;RT:ROUTE;PR:PRIORITY;CL:CLINIC;E:EXIT" D ^DIR I $D(DIRUT)!(Y="E") G EX ;vfah
12 I $G(PSOAFYN)'="Y" S (PSOFIN,POERR)=1 K PSOBCK,MEDA,MEDP,SRT,DIR D KQ ;vfah
13 I $G(PSOAFYN)="Y" S Y="PA" ;vfah
14 G:Y="PA" PAT G:Y="PR" PRI G:Y="CL" ^PSOORFI3
15 K DIR S PSOSORT="ROUTE"
16 S DIR("?")="^D RT^PSOORFI1",DIR("A")="Route",DIR(0)="SBM^W:WINDOW;M:MAIL;C:CLINIC;E:EXIT",DIR("B")="WINDOW"
17 D ^DIR G:$D(DIRUT)!(Y="E") EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y
18 I $G(PSOAFYN)="Y" S PSOSORT="ROUTE^WINDOW",PSRT="WINDOW" ;vfah
19 S LG=0,PATA=0 F S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG"))) F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG"))) D
20 .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2) S PAT=$P(^PS(52.41,PSOD,0),"^",2)
21 .I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL
22 .I '$O(^PS(52.41,"AC",PAT,PSRT,0)) S PSOLK=1,PAT(PAT)=PAT Q
23 .D RTE^PSOORFI2 I $G(PSZFIN) S PSOLK=1,PAT(PAT)=PAT Q
24 .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
25 .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP Q
26 .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
27 .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
28 .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
29 .D PP S ORD=0 D @PSRT S PAT(PAT)=PAT
30 .S X=PAT D ULP
31 K POERR("QFLG"),PSOQFLG,PSOPTPST,MAIL,WIN,CLI I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL
32 I $G(PSOQUIT) K PSOQUIT D EX G PSOORFIN
33EX D EX^PSOORFI1
34 Q
35W D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S MAIL=1
36 Q:$G(POERR("QFLG")) I $G(MAIL) S ORD=0 D
37 .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
38 .Q:$G(POERR("QFLG"))
39 .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
40 Q
41M D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S WIN=1
42 Q:$G(POERR("QFLG")) I $G(WIN) S ORD=0 D
43 .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD
44 .Q:$G(POERR("QFLG"))
45 .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
46 Q
47C D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S CLI=1
48 Q:$G(POERR("QFLG")) I $G(CLI) S ORD=0 D
49 .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD
50 .Q:$G(POERR("QFLG"))
51 .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
52 Q
53PAT I $G(PSOAFYN)'="Y" W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="PATIENT" ;vfah
54 I $G(PSOAFYN)="Y" K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="PATIENT" ;vfah
55 I $G(PSOAFYN)'="Y" S DIR("?")="^D PT^PSOORFI1",DIR("A")="All Patients or Single Patient",DIR(0)="SBM^A:ALL;S:SINGLE;E:EXIT",DIR("B")="SINGLE" ;vfah
56 I $G(PSOAFYN)'="Y" D ^DIR K DIR G:$D(DIRUT)!(Y="E") EX I Y="S" S PSOSORT=PSOSORT_"^"_"SINGLE" G SPAT ;vfah
57 I $G(PSOAFYN)="Y" S PSOSORT=PSOSORT_"^"_"SINGLE" G SPAT ;vfah
58 S PSOSORT=PSOSORT_"^ALL"
59 S LG=0,PATA=0 F S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG"))) F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG"))) D:$D(^PS(52.41,PSOD,0))
60 .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2) S PAT=$P(^PS(52.41,PSOD,0),"^",2)
61 .I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL
62 .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
63 .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG,PSOQQ Q
64 .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
65 .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
66 .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
67 .S PAT(PAT)=PAT
68 .F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG")))!($G(PSOQQ)) D
69 ..D PP,LK1,ORD
70 .S X=PAT D ULP K PSOQQ
71 I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL
72 I $G(PSOQUIT) K PSOQUIT D EX G PSOORFIN
73 G EX
74SPAT K MEDA,MEDP,PSOQFLG,PSORX("FN") D KQ,KV^PSOVER1
75 ;PSOAFIN begin SPAT
76 I $G(PSOAFDON)=1 G EX ;vfah
77 I $G(PSOAFYN)'="Y" S DIR(0)="FO^2:30",DIR("A")="Select Patient",DIR("?")="^D HELP^PSOORFI2" D ^DIR I $E(X)="?" G SPAT ;vfah
78 I $G(PSOAFYN)'="Y" G:$D(DIRUT) EX D KV^PSOVER1 ;vfah
79 I $G(PSOAFYN)'="Y" S DIC(0)="EQM",DIC=2,DIC("S")="I $D(^PS(52.41,""AOR"",+Y,PSOPINST))" ;vfah
80 I $G(PSOAFYN)'="Y" D ^DIC K DIC G:"^"[X EX G:Y=-1 SPAT S (PSODFN,PAT)=+Y,PSOFINY=Y ;vfah
81 ;PSOAFIN end SPAT
82 D LK I $G(POERR("QFLG")) G SPAT
83 N SNGLPAT S SNGLPAT=1
84 D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSOFINY I $G(MEDP) D SPL D OERR^PSORX1 D:$O(PSORX("PSOL",0))!($D(RXRS)) LBL S PSOFIN=1,X=PSOPTLOK D KLLP,ULP,KLL G SPAT
85 D PP,SDFN,POST^PSOORFI1 D:$G(PSOQFLG) G:$G(PSOQFLG) EX I $G(PSOQUIT) S:$G(PSOQUIT) POERR("QFLG")=1 S X=PAT D ULP G SPAT
86 .S X=PAT D ULP
87 I PSOAFYN'="Y" S ORD=0 F S ORD=$O(^PS(52.41,"P",PAT,ORD)) Q:'ORD!($G(POERR("QFLG"))) D ;vhah
88 .D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE")&($P(^(0),"^",3)'="HD") LK1,ORD
89 I PSOAFYN="Y" S ORD=0,ORD=$O(^PS(52.41,"B",+ORDERID,ORD)) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE")&($P(^(0),"^",3)'="HD") LK1,ORD ;vfah
90 I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL
91 I $G(PSOAFYN)="Y" S PSOAFDON=1 ;vfah
92 S PSOFIN=1,X=PAT D ULP G SPAT
93ORD I $G(PSOBCK) N LST,ORN
94 E S PSOLOUD=1 D:$P($G(^PS(55,PAT,0)),"^",6)'=2 EN^PSOHLUP(PAT) K PSOLOUD
95 K DRET,SIG,^TMP("PSORXDC",$J) Q:'$D(^PS(52.41,ORD,0))
96 I $G(PSOFIN),$P($G(^PS(52.41,ORD,"INI")),"^")'=$G(PSOPINST) Q
97 D L1^PSOORFI3 I '$G(PSOMSG) K PSOMSG Q
98 I '$D(^PS(52.41,ORD,0)) K PSOMSG Q
99 K DRET,SIG,PSOPRC,PHI,PRC,PSOSIGFL,OBX,PSOMSG S PSOFDR=1,OR0=^PS(52.41,ORD,0),OI=$P(OR0,"^",8),PSORX("SC")=$P(OR0,"^",16)
100 I $O(^PS(52.41,ORD,2,0)) S PHI=^PS(52.41,ORD,2,0),T=0 F S T=$O(^PS(52.41,ORD,2,T)) Q:'T S PHI(T)=^PS(52.41,ORD,2,T,0)
101 I $P($G(^PS(52.41,ORD,"EXT")),"^")'="" K PHI I $O(^PS(52.41,ORD,"SIG",0)) S PHI=$G(^PS(52.41,ORD,"SIG",0)),T=0 F S T=$O(^PS(52.41,ORD,"SIG",T)) Q:'T S PHI(T)=$G(^PS(52.41,ORD,"SIG",T,0))
102 I $O(^PS(52.41,ORD,3,0)) S PRC=^PS(52.41,ORD,3,0),T=0 F S T=$O(^PS(52.41,ORD,3,T)) Q:'T S PRC(T)=^PS(52.41,ORD,3,T,0)
103 I $P(OR0,"^",24),($P(OR0,"^",3)="RNW"!($P(OR0,"^",3)="NW")) N PKI,PKI1,PKIR,PKIE S PKI=0 D CER^PSOPKIV1 Q:PKI<1
104 I $P(OR0,"^",3)="RNW",$D(^PSRX(+$P(OR0,"^",21),0)) D G SUCC ;process renews
105 .K PSOREEDT S (PSOORRNW,PSOFDR)=1,PSORENW("OIRXN")=$P(OR0,"^",21),PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"))=0 D ^PSOORRNW,SQR^PSOORFI3
106 I $P(OR0,"^",3)="RF",$D(^PSRX(+$P(OR0,"^",19),0)) D RF^PSOORFI2 G SUCC
107 N PSODRUG,PSONEW S PSOFROM="PENDING" D:'$G(PSOTPBFG) DSPL^PSOTPCAN(ORD) D DSPL^PSOORFI1:'$D(ZTSK),SQN^PSOORFI3
108SUCC ;
109 D SUCC^PSOORFI5
110 Q
111 ;
112LBL ;
113 D LBL^PSOORFI5
114 Q
115 ;
116CHK ;
117 D CHK^PSOORFI5
118 Q
119 ;
120PRI K DIR S PSOSORT="PRIORITY"
121 S DIR("A")="Select Priority",DIR(0)="SBM^S:STAT;E:EMERGENCY;R:ROUTINE",DIR("B")="ROUTINE"
122 D ^DIR G:$D(DIRUT) EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y
123 S LG=0,PATA=0 F S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG"))) F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG"))) D
124 .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2) S PAT=$P(^PS(52.41,PSOD,0),"^",2)
125 .I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL
126 .I '$O(^PS(52.41,"AP",PAT,PSRT,0)) S PSOLK=1,PAT(PAT)=PAT Q
127 .D PRI^PSOORFI2 I $G(PSZFIN) S PSOLK=1,PAT(PAT)=PAT Q
128 .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
129 .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP Q
130 .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
131 .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
132 .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
133 .D PP S ORD=0 D @PSRT S PAT(PAT)=PAT
134 .S X=PAT D ULP
135 I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL
136 I $G(PSOQUIT) K PSOQUIT D EX G PSOORFIN
137 G EX
138 Q
139S D S^PSOORFI2 Q
140 ;
141E D E^PSOORFI2 Q
142 ;
143R D R^PSOORFI2 Q
144 ;
145LK D LOCK^PSOORFI1
146 Q
147LK1 D LOCK1^PSOORFI1 Q
148QU I $G(PSOQUIT) S POERR("QFLG")=1 K PSOQUIT
149 S:$G(PSOQFLG) PAT(PAT)=PAT
150 Q
151ULP K PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
152 D CLEAN^PSOVER1
153 I '$G(X) Q
154 D UL^PSSLOCK(X) Q
155KLL K PSOPTLOK Q
156KLLP K PSONOLCK Q
157SPL D SPL^PSOORFI4 Q
158SDFN S PSODFN=+$G(PSODFN) Q
159PP D PP^PSOORFI4 Q
160KQ K PSOQUIT,POERR("QFLG") Q
Note: See TracBrowser for help on using the repository browser.