source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSUTL.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 9.0 KB
Line 
1PSOSUTL ;BIR/RTR - Suspense utility routine ;12/15/95
2 ;;7.0;OUTPATIENT PHARMACY;**10,34,139,167,235**;DEC 1997
3 ;External reference to ^PSDRUG supported by DBIA 221
4 ;External reference to ^PSNDF supported by DBIA 2195
5AREC1 ;
6 S $P(^PSRX(RX,"STA"),"^")=0
7 S SFN=$O(^PS(52.5,"B",RX,0)) I 'SFN D CPMS Q
8 D NOW^%DTC S DTTM=% S COM="Suspense "_$S($G(RXRP(RX)):"(Reprint) ",1:"")_"Label Pulled Early"_$S($G(RXP):" (Partial)",1:"") S CNT=0 F JJ=0:0 S JJ=$O(^PSRX(RX,"A",JJ)) Q:'JJ S CNT=JJ
9 D DEL S $P(^PSRX(RX,"STA"),"^")=0 K PSODEL S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RX,1,RF)) Q:'RF S RFCNT=RF
10 I 'RFCNT,'$G(RXP),'$D(RXRP(RX)) S (X,OLD)=$P(^PSRX(RX,2),"^",2) D K DIE
11 .K DIE S DA=RX,DR="22////"_DT_";101////"_DT_";25////"_DT,DIE=52 D ^DIE
12 I RFCNT,'$G(RXP),'$D(RXRP(RX)) S (OLD,X)=+$P($G(^PSRX(RX,1,RFCNT,0)),"^") D K DIE S $P(^PSRX(RX,3),"^")=DT
13 .K DIE S DA(1)=RX,DA=RFCNT,DIE="^PSRX("_DA(1)_",1,",DR=".01///"_DT_";10.1///"_DT D ^DIE
14 S:'$D(PDUZ) PDUZ=DUZ S CNT=CNT+1,^PSRX(RX,"A",0)="^52.3DA^"_CNT_"^"_CNT
15 S ^PSRX(RX,"A",CNT,0)=DTTM_"^S^"_PDUZ_"^"_$S($G(RXP):6,'RFCNT:RFCNT,RFCNT<6:RFCNT,1:(RFCNT+1))_"^"_COM
16 D CPMS
17 Q
18CPMS ;
19 N PSOZZDD S PSOZZDD="Label printed from suspense" D EN^PSOHLSN1(RX,"SC","ZU",PSOZZDD) K PSOZZDD
20 Q
21 ;
22DEL S DA=SFN,DIK="^PS(52.5," D ^DIK K DIK Q
23 ;I 'PSODELE S NODE=^PS(52.5,SFN,0) K ^PS(52.5,"C",$P(NODE,"^",2),SFN),^PS(52.5,"AC",$P(NODE,"^",3),$P(NODE,"^",2),SFN) S $P(^PS(52.5,SFN,0),"^",2)=DT,^PS(52.5,"C",DT,SFN)="",^PS(52.5,SFN,"P")=1 D K NODE
24 ;.S X1=DT,X2=+$P($G(^PS(59.7,1,40.1)),"^",5) D C^%DTC S ^PS(52.5,"ADL",X,SFN)="" K X
25 ;I $P($G(^PS(52.5,SFN,0)),"^",7)'="" N DA,DR,DIE S DA=SFN,DIE="^PS(52.5,",DR="3////P" D ^DIE
26 Q
27AREC N PSOZZDMS S PSOZZDMS=0 S:$P(^PSRX(RX,"STA"),"^")=5 PSOZZDMS=1
28 S:$P(^PSRX(RX,"STA"),"^")=5 $P(^PSRX(RX,"STA"),"^")=0 S SFN=$O(^PS(52.5,"B",RX,0)) D:'SFN&(PSOZZDMS) CPMSG Q:'SFN D NOW^%DTC S DTTM=% S COM="Suspense "_$S($G(RXRP(RX)):"(Reprint) ",1:"")_"Label Printed"_$S($G(RXP):" (Partial)",1:"")
29 S $P(^PS(52.5,SFN,"P"),"^")=1 D K ^PS(52.5,"AC",DFN,$P(^PS(52.5,SFN,0),"^",2),SFN) S CNT=0 F JJ=0:0 S JJ=$O(^PSRX(RX,"A",JJ)) Q:'JJ S CNT=JJ
30 .S ^PS(52.5,"ADL",$E(PSOTIME,1,7),SFN)=""
31 S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RX,1,RF)) Q:'RF S RFCNT=RF S:RF>5 RFCNT=RF+1
32 S CNT=CNT+1,^PSRX(RX,"A",0)="^52.3DA^"_CNT_"^"_CNT S ^PSRX(RX,"A",CNT,0)=DTTM_"^S^"_DUZ_"^"_$S($G(RXP):6,1:RFCNT)_"^"_COM
33 S $P(^PS(52.5,SFN,0),"^",8)=PSOTIME,$P(^PS(52.5,SFN,0),"^",9)=PDUZ S:'$P(^PS(52.5,SFN,0),"^",6) $P(^PS(52.5,SFN,0),"^",6)=PSOSITE
34 I PSOZZDMS D CPMSG
35 Q
36CPMSG ;
37 N PSOZZDDD S PSOZZDDD="Label printed from suspense" D EN^PSOHLSN1(RX,"SC","ZU",PSOZZDDD) K PSOZZDDD
38 Q
39 ;
40ARECD D NOW^%DTC S CNT=0,DTTM=% F JJ=0:0 S JJ=$O(^PSRX(RX,"A",JJ)) Q:'JJ S CNT=JJ
41 S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RX,1,RF)) Q:'RF S RFCNT=RF S:RF>5 RFCNT=RF+1
42 S RXP=$P(^PS(52.5,SFN,0),"^",5)
43 S CNT=CNT+1,^PSRX(RX,"A",0)="^52.3DA^"_CNT_"^"_CNT S ^PSRX(RX,"A",CNT,0)=DTTM_"^C^"_DUZ_"^"_$S($G(RXP):6,1:RFCNT)_"^"_COM K RXP
44 D EN^PSOHLSN1(RX,"OD","",COM,"A")
45 Q
46EX Q:'$G(RXREC) D NOW^%DTC S PSCOU=0,DTTM=% F AAA=0:0 S AAA=$O(^PSRX(RXREC,"A",AAA)) Q:'AAA S PSCOU=AAA
47 S VVV=0 F QQQ=0:0 S QQQ=$O(^PSRX(RXREC,1,QQQ)) Q:'QQQ S VVV=QQQ S:QQQ>5 VVV=QQQ+1
48 S PSOPRT=$P(^PS(52.5,SFN,0),"^",5)
49 S PSOEXPI="Expired while on suspense"
50 S PSCOU=PSCOU+1,^PSRX(RXREC,"A",0)="^52.3DA^"_PSCOU_"^"_PSCOU S ^PSRX(RXREC,"A",PSCOU,0)=DTTM_"^S^"_DUZ_"^"_$S($G(PSOPRT):6,1:VVV)_"^"_PSOEXPI
51 D EN^PSOHLSN1(RXREC,"SC","ZE",PSOEXPI)
52 K PSCOU,AAA,QQQ,VVV,PSOPRT,PSOEXPI Q
53SET ; Set DEA in Suspense File
54 N PSOSUDEA
55 Q:'$G(X) Q:'$D(^PSRX(X,0))
56 S PSOSUDEA=$P($G(^PSRX(X,0)),"^",6) I PSOSUDEA,$D(^PSDRUG(PSOSUDEA,0)) S $P(^PS(52.5,DA,0),"^",10)=$P(^PSDRUG(PSOSUDEA,0),"^",3)
57 Q
58KILL Q:'$G(DA) Q:'$D(^PS(52.5,DA,0))
59 S $P(^PS(52.5,DA,0),"^",10)=""
60 Q
61SAS ;X-ref on Division field
62 N PSOC7,PSUSPIEN S PSUSPIEN=$O(^PS(52.5,"B",DA,0)) I PSUSPIEN,$D(^PS(52.5,PSUSPIEN,0)),'$P($G(^(0)),"^",5),'$O(^PSRX(DA,1,0)) D
63 .S PSOC7=$P($G(^PS(52.5,PSUSPIEN,0)),"^",7)
64 .S $P(^PS(52.5,PSUSPIEN,0),"^",6)=X S:$P(^PS(52.5,PSUSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P($G(^(0)),"^",7)="") ^PS(52.5,"AS",$P(^PS(52.5,PSUSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSUSPIEN)=""
65 .S $P(^PS(52.5,PSUSPIEN,0),"^",6)=X S:$P(^PS(52.5,PSUSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P($G(^(0)),"^",7)="P") ^PS(52.5,"APR",$P(^PS(52.5,PSUSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSUSPIEN)=""
66 .K:$P(^PS(52.5,PSUSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P($G(^(0)),"^",7)="P") ^PS(52.5,"AS",$P(^PS(52.5,PSUSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSUSPIEN)
67 .I PSOC7'="" D SCMPX^PSOCMOP(PSUSPIEN,PSOC7)
68 Q
69KAS ;
70 N PSUSPIEN,PSOC7 S PSUSPIEN=$O(^PS(52.5,"B",DA,0)) I PSUSPIEN,$D(^PS(52.5,PSUSPIEN,0)),'$P($G(^(0)),"^",5),'$O(^PSRX(DA,1,0)) D
71 .K:$P(^PS(52.5,PSUSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P(^(0),"^",7)="") ^PS(52.5,"AS",$P(^PS(52.5,PSUSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSUSPIEN)
72 .K:$P(^PS(52.5,PSUSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P(^(0),"^",7)="P") ^PS(52.5,"APR",$P(^PS(52.5,PSUSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSUSPIEN)
73 .S PSOC7=$P($G(^PS(52.5,PSUSPIEN,0)),"^",7)
74 .I PSOC7'="" D KCMPX^PSOCMOP(PSUSPIEN,PSOC7)
75 Q
76SAS1 ;Refill Division x-ref
77 N PSOSPIEN,ZZZ,PSREFCNT,PSOC7 S PSOSPIEN=$O(^PS(52.5,"B",DA(1),0)) I PSOSPIEN,$D(^PS(52.5,PSOSPIEN,0)),'$P($G(^(0)),"^",5),$O(^PSRX(DA(1),1,0)) D
78 .S PSOC7=$P($G(^PS(52.5,PSOSPIEN,0)),"^",7)
79 .S PSREFCNT=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(DA(1),1,ZZZ)) Q:'ZZZ S PSREFCNT=PSREFCNT+1
80 .I PSREFCNT=DA S $P(^PS(52.5,PSOSPIEN,0),"^",6)=X D
81 ..S:$P(^PS(52.5,PSOSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P($G(^(0)),"^",7)="") ^PS(52.5,"AS",$P(^PS(52.5,PSOSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSOSPIEN)=""
82 ..S:$P(^PS(52.5,PSOSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P($G(^(0)),"^",7)="P") ^PS(52.5,"APR",$P(^PS(52.5,PSOSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSOSPIEN)=""
83 ..K:$P(^PS(52.5,PSOSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P($G(^(0)),"^",7)="P") ^PS(52.5,"AS",$P(^PS(52.5,PSOSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSOSPIEN)
84 ..I PSOC7'="" D SCMPX^PSOCMOP(PSOSPIEN,PSOC7)
85 Q
86KAS1 ;
87 N PSOSPIEN,ZZZ,PSREFCNT,PSOC7 S PSOSPIEN=$O(^PS(52.5,"B",DA(1),0)) I PSOSPIEN,$D(^PS(52.5,PSOSPIEN,0)),'$P($G(^(0)),"^",5),$O(^PSRX(DA(1),1,0)) D
88 .S PSREFCNT=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(DA(1),1,ZZZ)) Q:'ZZZ S PSREFCNT=PSREFCNT+1
89 .I PSREFCNT=DA D
90 ..K:$P(^PS(52.5,PSOSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P(^(0),"^",7)="") ^PS(52.5,"AS",$P(^PS(52.5,PSOSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSOSPIEN)
91 ..K:$P(^PS(52.5,PSOSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P(^(0),"^",7)="P") ^PS(52.5,"APR",$P(^PS(52.5,PSOSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSOSPIEN)
92 ..S PSOC7=$P($G(^PS(52.5,PSOSPIEN,0)),"^",7)
93 ..I PSOC7'="" D KCMPX^PSOCMOP(PSOSPIEN,PSOC7)
94 Q
95SAS2 ;For partials
96 N PSPSPIEN S PSPSPIEN=$O(^PS(52.5,"B",DA(1),0)) I PSPSPIEN,$D(^PS(52.5,PSPSPIEN,0)),$P($G(^(0)),"^",5) D
97 .I DA=$P(^PS(52.5,PSPSPIEN,0),"^",5) S $P(^(0),"^",6)=X D
98 ..S:$P(^PS(52.5,PSPSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P($G(^(0)),"^",7)="") ^PS(52.5,"AS",$P(^PS(52.5,PSPSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSPSPIEN)=""
99 ..S:$P(^PS(52.5,PSPSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P($G(^(0)),"^",7)="P") ^PS(52.5,"APR",$P(^PS(52.5,PSPSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSPSPIEN)=""
100 ..K:$P(^PS(52.5,PSPSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P($G(^(0)),"^",7)="P") ^PS(52.5,"AS",$P(^PS(52.5,PSPSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSPSPIEN)
101 Q
102KAS2 ;
103 N PSPSPIEN S PSPSPIEN=$O(^PS(52.5,"B",DA(1),0)) I PSPSPIEN,$D(^PS(52.5,PSPSPIEN,0)),$P($G(^(0)),"^",5) D
104 .I DA=$P(^PS(52.5,PSPSPIEN,0),"^",5) D
105 ..K:$P(^PS(52.5,PSPSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P(^(0),"^",7)="") ^PS(52.5,"AS",$P(^PS(52.5,PSPSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSPSPIEN)
106 ..K:$P(^PS(52.5,PSPSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P(^(0),"^",7)="P") ^PS(52.5,"APR",$P(^PS(52.5,PSPSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSPSPIEN)
107 Q
108SDEA ;Update Suspense with DEA
109 N PSSSPIEN S PSSSPIEN=$O(^PS(52.5,"B",DA,0)) Q:'$G(PSSSPIEN)
110 I $D(^PS(52.5,PSSSPIEN,0)),$P($G(^("P")),"^")=0 S $P(^PS(52.5,PSSSPIEN,0),"^",10)=$P($G(^PSDRUG(+X,0)),"^",3)
111 Q
112SDIV N PSODINT,PSDVP,PSLOOP
113 S PSODINT=+$P($G(^PS(52.5,DA,0)),"^") Q:'PSODINT
114 S PSDVP=$P($G(^PS(52.5,DA,0)),"^",5) I PSDVP D Q
115 .S:$D(^PSRX(PSODINT,"P",+PSDVP,0)) $P(^(0),"^",9)=X
116 S PSDVP=0 F PSLOOP=0:0 S PSLOOP=$O(^PSRX(PSODINT,1,PSLOOP)) Q:'PSLOOP S PSDVP=PSLOOP
117 I PSDVP S:$D(^PSRX(PSODINT,1,PSDVP,0)) $P(^(0),"^",9)=X Q
118 S:$D(^PSRX(PSODINT,2)) $P(^(2),"^",9)=X
119 Q
120ZZ(RX) ; Returns VA print name, Trade Name, Generic Name
121 S I50=$P(^PSRX(RX,0),U,6),ZDRUG=$P(^PSDRUG(I50,0),U)
122 I $G(ZDRUG)']"" S ZDRUG="DRUG NOT ON FILE ("_I50_")" G END
123 I $G(^PSRX(RX,"TN"))]"" S ZDRUG=^("TN") G END
124 I $D(^PSDRUG("AQ",I50)),($D(^PSDRUG(I50,"ND"))) D
125 .S Z1=$P($G(^PSDRUG(I50,"ND")),U),Z2=$P($G(^("ND")),U,3)
126 .I $G(Z1),($G(Z2)) D
127 ..I $T(^PSNAPIS)]"" S PSOXN=$$PROD2^PSNAPIS(Z1,Z2) S ZDRUG=$P($G(PSOXN),"^") K PSOXN Q
128 ..S ZDRUG=$P($G(^PSNDF(Z1,5,Z2,2)),"^")
129 .K Z1,Z2,I50
130END K I50
131 Q ZDRUG
Note: See TracBrowser for help on using the repository browser.