source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPOST.m@ 1274

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

initial load of FOIAVistA 6/30/08 version

File size: 9.1 KB
Line 
1PSOPOST ;BIR/SAB-post init for v7 ;07/29/96 9:17 AM
2 ;;7.0;OUTPATIENT PHARMACY;**30,56,73**;DEC 1997
3 ;External reference to ^PS(59.7 supported by DBIA 694
4 ;External reference to ^ORD(101 supported by DBIA 872
5 ;External reference ^PS(55 supported by DBIA 2228
6 ;External reference ^PSDRUG( supported by DBIA 221
7 ;External reference to STATUS^ORQOR2 supported by DBIA 3458
8 ;External reference to ^OR(100 supported by DBIA 3463
9 D BMES^XPDUTL("...Setting up Outpatient Pharmacy's protocols...")
10 S MENU="OR EVSEND PS",ITEM="PS RECEIVE OR" D D SETUP1:MENUP
11 .S MENUP=$O(^ORD(101,"B",MENU,0)) I 'MENUP D
12 ..D BMES^XPDUTL("Cannot find the protocol menu '"_MENU_"'.")
13 ..D MES^XPDUTL("You need to add the protocol '"_ITEM_"' to this protocol menu.")
14 K MENU,ITEM,MENUP
15 S MENU="PS EVSEND OR",ITEM="OR RECEIVE",MENUP=$O(^ORD(101,"B",MENU,0)) D SETUP1
16 S XQABT4=$H,$P(^PS(59.7,1,49.99),"^")="7.0",$P(^(49.99),"^",4)=DT
17 S XQABT5=$H
18 D BMES^XPDUTL("Initialization Completed in "_($P($H,",",2)-PSOIT)_" seconds.") K PSOIT
19 Q
20SETUP1 ;
21 S X=$O(^ORD(101,"B",ITEM,0)) I 'X D Q
22 .D BMES^XPDUTL("Cannot find the protocol '"_ITEM_"'.")
23 .D MES^XPDUTL("You need to add this protocol to the protocol menu '"_MENU_"'.")
24 I $D(^ORD(101,MENUP,10,"B",X)) D Q
25 .D BMES^XPDUTL("Protocol '"_ITEM_"' is already set up under protocol menu '"_MENU_"'.")
26 I $D(^ORD(101,MENUP,10,0))[0 S ^ORD(101,MENUP,10,0)="^"_"101.01PA"
27 K DA,DD,DO,DIC S DIC="^ORD(101,"_MENUP_",10,",DIC(0)="L",DLAYGO=101.01,DA(1)=MENUP D FILE^DICN K DD,DO
28 D BMES^XPDUTL("Protocol '"_ITEM_"' "_$S($P(Y,"^",3):"",1:"NOT ")_"added to the protocol menu '"_MENU_"'.")
29 Q
30POST ;
31 S $P(^PS(59.7,1,49.99),"^",6)=""
32 D NOW^%DTC S $P(^PS(59.7,1,49.99),"^",7)=% K %,%H,%I,X
33 F PSOPT="PSO PNDRPT","PSO PNDLBL","PSO PNDRX" D OUT^XPDMENU(PSOPT,"Unavailable - Under Construction")
34 K PSOPT,DA,DIE,DR
35 S IFN=0 F S IFN=$O(^PSRX(IFN)) Q:'IFN D:$G(^PSRX(IFN,0))]""&($P($G(^PSRX(IFN,0)),"^",2)) S:$P($G(^PSRX(IFN,0)),"^",2) $P(^PSRX(IFN,0),"^",19)=1
36 .Q:$P(^PSRX(IFN,0),"^",19)
37 .S X1=DT,X2=-120 D C^%DTC S CUTOFF=X
38 .I $P($G(^PSRX(IFN,"OR1")),"^")']"",+$G(^PSDRUG(+$P(^PSRX(IFN,0),"^",6),2)) S $P(^PSRX(IFN,"OR1"),"^")=+$G(^PSDRUG($P(^PSRX(IFN,0),"^",6),2))
39 .;moves sig from 0;10 to sig;1 and status from 0;15 to sta;1
40 .I $G(^PSRX(IFN,"SIG"))']"" S ^PSRX(IFN,"SIG")=$P($G(^PSRX(IFN,0)),"^",10)_"^"_0 S $P(^PSRX(IFN,0),"^",10)=""
41 .I $P($G(^PSRX(IFN,2)),"^",6)'<CUTOFF,'$P($G(^("SIG")),"^",2) D POP^PSOSIGNO(IFN)
42 .I $G(^PSRX(IFN,"STA"))']"" S ^PSRX(IFN,"STA")=$P($G(^PSRX(IFN,0)),"^",15) S $P(^PSRX(IFN,0),"^",15)=""
43 .I $P($G(^PSRX(IFN,2)),"^",6)<DT,$P(^("STA"),"^")<11 S $P(^PSRX(IFN,"STA"),"^")=11 D ECAN^PSOUTL(IFN)
44 .S PR=0 F S PR=$O(^PSRX(IFN,"P",PR)) Q:'PR D
45 ..I '$P($G(^PSRX(IFN,"P",PR,0)),"^") K ^PSRX(IFN,"P",PR,0) Q
46 ..S ^PSRX("ADP",$E($P(^PSRX(IFN,"P",PR,0),"^"),1,7),IFN,PR)=""
47 N SPAT,SDATE,SCT,SZZ,SLAST,SCMOP
48 F PSO=0:0 S PSO=$O(^PS(52.5,PSO)) Q:'PSO S PNODE=$P($G(^PS(52.5,PSO,"P")),"^"),SFLAG=1 D
49 .S PSOINRX=+$P($G(^PS(52.5,PSO,0)),"^") D:PNODE&(PSOINRX)
50 ..I $P($G(^PS(52.5,PSO,0)),"^",7)'="L" D S SFLAG=0 S:$P($G(^PSRX(PSOINRX,"STA")),"^")=5 $P(^("STA"),"^")=0
51 ...S SDATE=$P($G(^PS(52.5,PSO,0)),"^",2),SPAT=$P($G(^(0)),"^",3)
52 ...I SDATE'="" K ^PS(52.5,"C",SDATE,PSO) I $G(PNODE)=2 K ^PS(52.5,"AC",+$G(SPAT),SDATE,PSO)
53 ...K ^PS(52.5,"AF",+$G(SPAT),PSO)
54 ...I $P($G(^DPT(+$G(SPAT),0)),"^")'="" K ^PS(52.5,"D",$P(^(0),"^"),PSO)
55 ...K ^PS(52.5,"B",PSOINRX,PSO)
56 ...S SCMOP=$P($G(^PS(52.5,PSO,0)),"^",7) I SCMOP'="" D
57 ....I SCMOP="Q"!(SCMOP="X")!(SCMOP="P") I SDATE'="" K ^PS(52.5,$S(SCMOP="Q":"AQ",SCMOP="X":"AX",1:"AP"),$G(SDATE),+$G(SPAT),PSO)
58 ....I SCMOP="P"!(SCMOP="Q") K ^PS(52.5,"AG",+$G(SPAT),PSO)
59 ...K ^PS(52.5,PSO,"P"),^PS(52.5,PSO,0)
60 .I SFLAG,$P($G(^PSRX(PSOINRX,0)),"^",6) S $P(^PS(52.5,PSO,0),"^",10)=$P($G(^PSDRUG($P($G(^PSRX(PSOINRX,0)),"^",6),0)),"^",3)
61 S SCT=0 F SZZ=0:0 S SZZ=$O(^PS(52.5,SZZ)) Q:'SZZ S SCT=SCT+1 S:'$O(^PS(52.5,SZZ)) SLAST=SZZ
62 S ^PS(52.5,0)="RX SUSPENSE^52.5PI^"_+$G(SLAST)_"^"_SCT
63 K DIK,PNODE,PSO,SFLAG,PSOINRX,IFN,PR
64 F PSOPT="PSO PNDRPT","PSO PNDLBL","PSO PNDRX" D OUT^XPDMENU(PSOPT,"")
65 D NOW^%DTC S $P(^PS(59.7,1,49.99),"^",6)=% K %,%H,%I,X,DA,DR,DIE,PSOPT
66 S ZTQUEUED="@" Q
67RESTART ;
68 I $P(^PS(59.7,1,49.99),"^")'="7.0" S $P(^PS(59.7,1,49.99),"^")="7.0"
69 I $S($D(DUZ)[0:1,'$D(^VA(200,$G(DUZ),0)):1,$D(DUZ(0))[0:1,1:0) W !!,$C(7),"DUZ and DUZ(0) must be defined as an active user.",!!
70 S ZTDTH=$H,ZTRTN="POST^PSOPOST",ZTIO="",ZTDESC="Outpatient Pharmacy version 7.0 background conversion restart." D ^%ZTLOAD
71 W !,"Background Job queued to run.",!
72 Q
73CLOZ ;
74 N DFN,XX
75 F DFN=0:0 S DFN=$O(^PS(55,"ASAND",DFN)) Q:'DFN D:$D(^PS(55,DFN,"SAND"))
76 .S XX=$P(^PS(55,DFN,"SAND"),"^",2)
77 .I $L(XX)>1 S $P(^PS(55,DFN,"SAND"),"^",2)=$S("A,D,H,P,"[($E(XX)_","):$E(XX),1:"")
78 Q
79PCLO S ZTDTH=$H,ZTRTN="CLOZ^PSOPOST",ZTIO="",ZTDESC="Outpatient Pharmacy clozapine patient status correction starts" D ^%ZTLOAD
80 W !,"Background Job queued to run.",!
81 Q
82 ;
83AGF ;PSO*7*73 - AG x-ref fix
84 I $D(^XTMP("PSO73")) W !!,"Use the entry point BEG^PSOPOST to restart - quitting " Q
85 S P73=1
86BEG W !!,?10,"*** 'AG' CROSS-REFERENCE CLEANUP PROCESS ***",!
87 I '$D(DUZ) W !!,"DUZ NOT DEFINED - QUITTING",!! Q
88 S TY="PSO73"
89 I '$G(P73) D Q:$G(PQ)
90 .I $G(^XTMP(TY,"A"))]"" S EXD=$P(^XTMP(TY,"A"),"^") D:EXD
91 ..W !,"Cleanup was done up to "_$E(EXD,4,5)_"-"_$E(EXD,6,7)_"-"_$E(EXD,2,3)_" of phase "_$P(^XTMP(TY,"A"),"^",2)_"."
92 ..W !,"It will continue from this date forward."
93 .E S IDT=$S($P($G(^PS(59.7,1,49.99)),"^",7):$P(^PS(59.7,1,49.99),"^",7),1:$P($G(^PS(59.7,1,49.99)),"^",4)) D
94 ..I 'IDT S PQ=1 W !,"Outpatient Pharmacy V. 7.0 not installed" Q
95 ..E W !,"Cleanup will start from "_$E(IDT,4,5)_"-"_$E(IDT,6,7)_"-"_$E(IDT,2,3)_" (Outpatient Pharmacy V. 7.0 installed date)." K ^XTMP(TY)
96 .Q:$G(PQ)
97 .D W
98 I $G(P73) K ^XTMP(TY),P73 D
99 .W !,"To the following prompt you can respond with the date/time to queue the"
100 .W !,"cleanup background job or enter '^' to skip scheduling." D W
101 K %DT D NOW^%DTC S %DT="RAEX",%DT(0)=%,%DT("A")="Select the Date/Time to queue the cleanup background job: "
102 D ^%DT K %DT
103 I $D(DTOUT)!(Y<0) W !!!?10,"Cleanup job not queued.." Q
104 S ZTDTH=$G(Y),ZTRTN="AGC^PSOPOST",ZTIO="",ZTDESC="Outpatient Pharmacy AG cross-reference correction has started"
105 D ^%ZTLOAD W:$D(ZTSK) !!,"Task Queued To Run!",!
106 Q
107W W !,"A mail message will be sent to the installer upon completion of this job.",!
108 Q
109AGC ;
110 S TY="PSO73" I '$G(DT) S DT=$$DT^XLFDT
111 S IDT=$S($P($G(^PS(59.7,1,49.99)),"^",7):$P(^PS(59.7,1,49.99),"^",7),1:$P($G(^PS(59.7,1,49.99)),"^",4))
112 I 'IDT S ^XTMP(TY,1)="Outpatient Pharmacy V. 7.0 not installed" G SND
113 S X1=IDT,X2=-121 D C^%DTC S IDT=X
114 S EXD=IDT D NOW^%DTC S Y=% X ^DD("DD")
115 I '$D(^XTMP(TY)) S X1=DT,X2=+30 D C^%DTC S ^XTMP(TY,0)=$G(X)_"^"_DT,^XTMP(TY,"A")=EXD G EN0
116 I $D(^XTMP(TY,"A")) D I EXD S YY="EN"_PH G @YY
117 .S EXD=$P(^XTMP(TY,"A"),"^") S:'EXD EXD=IDT
118 .S PH=$P(^XTMP(TY,"A"),"^",2) S:'PH PH=0
119 .I EXD>IDT D
120 ..S ^XTMP(TY,1)="Scanning the 'AG' cross-reference from date: "_$E(EXD,4,5)_"-"_$E(EXD,6,7)_"-"_$E(EXD,2,3)_$S(PH:" (Phase "_PH_")",1:""),^XTMP(TY,2)=""
121 ..S ^XTMP(TY,3)="Cleanup Start Date/Time: "_Y,^XTMP(TY,4)=""
122 Q
123EN0 S $P(^XTMP(TY,"A"),"^",2)=0
124 S ^XTMP(TY,1)="Scanning the 'AG' cross-reference from date: "_$E(EXD,4,5)_"-"_$E(EXD,6,7)_"-"_$E(EXD,2,3),^XTMP(TY,2)=""
125 S ^XTMP(TY,3)="Cleanup Start Date/Time: "_Y,^XTMP(TY,4)=""
126 S EXD=EXD-1
127 F S EXD=$O(^PSRX("AG",EXD)) Q:'EXD S $P(^XTMP(TY,"A"),"^")=EXD,RX=0 F S RX=$O(^PSRX("AG",EXD,RX)) Q:'RX D
128 .I '$D(^PSRX(RX))!('$D(^PSRX(RX,0)))!('$D(^PSRX(RX,2))) K ^PSRX("AG",EXD,RX) Q
129 .S X=$P($G(^PSRX(RX,2)),"^",6) Q:X'?7N
130 .I X'=EXD K ^PSRX("AG",EXD,RX) S ^PSRX("AG",X,RX)=""
131 S EXD=IDT
132EN1 S EXD=EXD-1 S $P(^XTMP(TY,"A"),"^",2)=1
133 F S EXD=$O(^PSRX("AD",EXD)) Q:'EXD S $P(^XTMP(TY,"A"),"^")=EXD,RX=0 F S RX=$O(^PSRX("AD",EXD,RX)) Q:'RX S RF="" F S RF=$O(^PSRX("AD",EXD,RX,RF)) Q:RF=""!(RF) D
134 .Q:'$D(^PSRX(RX,0))!('$P($G(^PSRX(RX,0)),"^",2))!('$D(^PSRX(RX,2)))
135 .S X=$P($G(^PSRX(RX,2)),"^",6) Q:X'?7N
136 .Q:$D(^PSRX("AG",X,RX))
137 .S ^PSRX("AG",X,RX)=""
138 S EXD=IDT
139EN2 S EXD=EXD-1 S $P(^XTMP(TY,"A"),"^",2)=2
140 F S EXD=$O(^PSRX("AG",EXD)) Q:'EXD!(EXD'<DT) S $P(^XTMP(TY,"A"),"^")=EXD,RX=0 F S RX=$O(^PSRX("AG",EXD,RX)) Q:'RX D
141 .Q:'$D(^PSRX(RX))!('$D(^PSRX(RX,0)))!('$D(^PSRX(RX,2)))!('$D(^PSRX(RX,"STA")))
142 .S ST=+$P($G(^PSRX(RX,"STA")),"^") I ST,ST=12!(ST=14)!(ST=15) D:$P($G(^("OR1")),"^",2)
143 ..S ORN=$P(^PSRX(RX,"OR1"),"^",2) I +$$STATUS^ORQOR2(ORN)=7 D
144 ...S (II,JJ)=0 F S II=$O(^PSRX(RX,"A",II)) Q:'II S:$P($G(^(II,0)),"^",2)="C"!($P($G(^(0)),"^",2)="L") JJ=II
145 ...D:JJ MSG
146 D NOW^%DTC S Y=% X ^DD("DD") S ^XTMP(TY,5)="Cleanup End Date/Time: "_Y,^XTMP(TY,6)=""
147SND S XMY(DUZ)="",XMDUZ="Patch PSO*7*73"
148 S XMSUB="PATCH PSO*7*73 - 'AG' Cross-reference Cleanup Information"
149 S XMTEXT="^XTMP(TY," D ^XMD K XMY,^XTMP(TY)
150 S:$D(ZTQUEUED) ZTREQ="@"
151 Q
152MSG ;
153 S ACR=$G(^PSRX(RX,"A",JJ,0)),PHR=$P(ACR,"^",3),AL=$P(ACR,"^",5),ADT=$P(ACR,"^")
154 S (PNO,COM)=""
155 I AL["Renewed" S COM="Renewed by Pharmacy"
156 I AL["Auto Discontinued" S PHR="",PNO="A",COM=$E($P(AL,".",2),2,99) S:COM="" COM=AL
157 I AL["Discontinued During" S COM="Discontinued by Pharmacy"
158 S ZZDU=DUZ S:PHR DUZ=PHR D EN^PSOHLSN1(RX,"OD",$S(ST=15:"RP",1:""),COM,PNO) S DUZ=ZZDU
159 I 'ADT S ADT=$E(DT_".2200",1,12)
160 I $D(^OR(100,ORN,6)) S $P(^(6),"^",3)=$E(ADT,1,12)
161 I $D(^OR(100,ORN,3)) S $P(^(3),"^")=ADT
162 Q
Note: See TracBrowser for help on using the repository browser.