PSOSUTL ;BIR/RTR - Suspense utility routine ;26-Jul-2016 15:09;DU
;;7.0;OUTPATIENT PHARMACY;**10,34,139,167,1008,1013,235,1015,1021**;DEC 1997;Build 14
;External reference to ^PSDRUG supported by DBIA 221
;External reference to ^PSNDF supported by DBIA 2195
; Modified - IHS/MSC/PLS- 02/09/09 - Line AREC
; 09/20/2011 - Line AREC1+6,AREC1+9
; 11/29/2011 - Mod at AREC no longer needed.
; 07/26/2016 - Lines AREC1+5,AREC1+10
AREC1 ;
S $P(^PSRX(RX,"STA"),"^")=0
S SFN=$O(^PS(52.5,"B",RX,0)) I 'SFN D CPMS Q
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
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
;IHS/MSC/PLS - 07/26/2016
;I 'RFCNT,'$G(RXP),'$D(RXRP(RX)) S (X,OLD)=$P(^PSRX(RX,2),"^",2) D K DIE
I 'RFCNT,'$G(RXP),('$D(RXRP(RX))!($D(RXRS(RX)))) S (X,OLD)=$P(^PSRX(RX,2),"^",2) D K DIE
.;K DIE S DA=RX,DR="22////"_DT_";101////"_DT_";25////"_DT,DIE=52 D ^DIE
.K DIE S DA=RX,DR="22////"_DT_";101////"_DT_";25////"_DT_";20///"_PSOSITE,DIE=52 D ^DIE ;IHS/MSC/PLS - 09/20/2011
;IHS/MSC/PLS - 07/26/2016
;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
I RFCNT,'$G(RXP),('$D(RXRP(RX))!($D(RXRS(RX)))) S (OLD,X)=+$P($G(^PSRX(RX,1,RFCNT,0)),"^") D K DIE S $P(^PSRX(RX,3),"^")=DT
.;K DIE S DA(1)=RX,DA=RFCNT,DIE="^PSRX("_DA(1)_",1,",DR=".01///"_DT_";10.1///"_DT D ^DIE
.K DIE S DA(1)=RX,DA=RFCNT,DIE="^PSRX("_DA(1)_",1,",DR=".01///"_DT_";10.1///"_DT_";8///"_PSOSITE D ^DIE ;IHS/MSC/PLS - 09/20/2011
S:'$D(PDUZ) PDUZ=DUZ S CNT=CNT+1,^PSRX(RX,"A",0)="^52.3DA^"_CNT_"^"_CNT
S ^PSRX(RX,"A",CNT,0)=DTTM_"^S^"_PDUZ_"^"_$S($G(RXP):6,'RFCNT:RFCNT,RFCNT<6:RFCNT,1:(RFCNT+1))_"^"_COM
D CPMS
Q
CPMS ;
N PSOZZDD S PSOZZDD="Label printed from suspense" D EN^PSOHLSN1(RX,"SC","ZU",PSOZZDD) K PSOZZDD
Q
;
DEL S DA=SFN,DIK="^PS(52.5," D ^DIK K DIK Q
;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
;.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
;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
Q
AREC N PSOZZDMS S PSOZZDMS=0 S:$P(^PSRX(RX,"STA"),"^")=5 PSOZZDMS=1
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:"")
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
.S ^PS(52.5,"ADL",$E(PSOTIME,1,7),SFN)=""
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
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
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
I PSOZZDMS D CPMSG
Q
CPMSG ;
N PSOZZDDD S PSOZZDDD="Label printed from suspense" D EN^PSOHLSN1(RX,"SC","ZU",PSOZZDDD) K PSOZZDDD
Q
;
ARECD D NOW^%DTC S CNT=0,DTTM=% F JJ=0:0 S JJ=$O(^PSRX(RX,"A",JJ)) Q:'JJ S CNT=JJ
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
S RXP=$P(^PS(52.5,SFN,0),"^",5)
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
D EN^PSOHLSN1(RX,"OD","",COM,"A")
Q
EX 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
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
S PSOPRT=$P(^PS(52.5,SFN,0),"^",5)
S PSOEXPI="Expired while on suspense"
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
D EN^PSOHLSN1(RXREC,"SC","ZE",PSOEXPI)
K PSCOU,AAA,QQQ,VVV,PSOPRT,PSOEXPI Q
SET ; Set DEA in Suspense File
N PSOSUDEA
Q:'$G(X) Q:'$D(^PSRX(X,0))
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)
Q
KILL Q:'$G(DA) Q:'$D(^PS(52.5,DA,0))
S $P(^PS(52.5,DA,0),"^",10)=""
Q
SAS ;X-ref on Division field
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
.S PSOC7=$P($G(^PS(52.5,PSUSPIEN,0)),"^",7)
.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)=""
.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)=""
.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)
.I PSOC7'="" D SCMPX^PSOCMOP(PSUSPIEN,PSOC7)
Q
KAS ;
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
.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)
.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)
.S PSOC7=$P($G(^PS(52.5,PSUSPIEN,0)),"^",7)
.I PSOC7'="" D KCMPX^PSOCMOP(PSUSPIEN,PSOC7)
Q
SAS1 ;Refill Division x-ref
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
.S PSOC7=$P($G(^PS(52.5,PSOSPIEN,0)),"^",7)
.S PSREFCNT=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(DA(1),1,ZZZ)) Q:'ZZZ S PSREFCNT=PSREFCNT+1
.I PSREFCNT=DA S $P(^PS(52.5,PSOSPIEN,0),"^",6)=X D
..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)=""
..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)=""
..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)
..I PSOC7'="" D SCMPX^PSOCMOP(PSOSPIEN,PSOC7)
Q
KAS1 ;
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
.S PSREFCNT=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(DA(1),1,ZZZ)) Q:'ZZZ S PSREFCNT=PSREFCNT+1
.I PSREFCNT=DA D
..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)
..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)
..S PSOC7=$P($G(^PS(52.5,PSOSPIEN,0)),"^",7)
..I PSOC7'="" D KCMPX^PSOCMOP(PSOSPIEN,PSOC7)
Q
SAS2 ;For partials
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
.I DA=$P(^PS(52.5,PSPSPIEN,0),"^",5) S $P(^(0),"^",6)=X D
..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)=""
..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)=""
..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)
Q
KAS2 ;
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
.I DA=$P(^PS(52.5,PSPSPIEN,0),"^",5) D
..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)
..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)
Q
SDEA ;Update Suspense with DEA
N PSSSPIEN S PSSSPIEN=$O(^PS(52.5,"B",DA,0)) Q:'$G(PSSSPIEN)
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)
Q
SDIV N PSODINT,PSDVP,PSLOOP
S PSODINT=+$P($G(^PS(52.5,DA,0)),"^") Q:'PSODINT
S PSDVP=$P($G(^PS(52.5,DA,0)),"^",5) I PSDVP D Q
.S:$D(^PSRX(PSODINT,"P",+PSDVP,0)) $P(^(0),"^",9)=X
S PSDVP=0 F PSLOOP=0:0 S PSLOOP=$O(^PSRX(PSODINT,1,PSLOOP)) Q:'PSLOOP S PSDVP=PSLOOP
I PSDVP S:$D(^PSRX(PSODINT,1,PSDVP,0)) $P(^(0),"^",9)=X Q
S:$D(^PSRX(PSODINT,2)) $P(^(2),"^",9)=X
Q
ZZ(RX) ; Returns VA print name, Trade Name, Generic Name
S I50=$P(^PSRX(RX,0),U,6),ZDRUG=$P(^PSDRUG(I50,0),U)
I $G(ZDRUG)']"" S ZDRUG="DRUG NOT ON FILE ("_I50_")" G END
I $G(^PSRX(RX,"TN"))]"" S ZDRUG=^("TN") G END
I $D(^PSDRUG("AQ",I50)),($D(^PSDRUG(I50,"ND"))) D
.S Z1=$P($G(^PSDRUG(I50,"ND")),U),Z2=$P($G(^("ND")),U,3)
.I $G(Z1),($G(Z2)) D
..I $T(^PSNAPIS)]"" S PSOXN=$$PROD2^PSNAPIS(Z1,Z2) S ZDRUG=$P($G(PSOXN),"^") K PSOXN Q
..S ZDRUG=$P($G(^PSNDF(Z1,5,Z2,2)),"^")
.K Z1,Z2,I50
END K I50
Q ZDRUG
PSOSUTL ;BIR/RTR - Suspense utility routine ;26-Jul-2016 15:09;DU
+1 ;;7.0;OUTPATIENT PHARMACY;**10,34,139,167,1008,1013,235,1015,1021**;DEC 1997;Build 14
+2 ;External reference to ^PSDRUG supported by DBIA 221
+3 ;External reference to ^PSNDF supported by DBIA 2195
+4 ; Modified - IHS/MSC/PLS- 02/09/09 - Line AREC
+5 ; 09/20/2011 - Line AREC1+6,AREC1+9
+6 ; 11/29/2011 - Mod at AREC no longer needed.
+7 ; 07/26/2016 - Lines AREC1+5,AREC1+10
AREC1 ;
+1 SET $PIECE(^PSRX(RX,"STA"),"^")=0
+2 SET SFN=$ORDER(^PS(52.5,"B",RX,0))
IF 'SFN
DO CPMS
QUIT
+3 DO NOW^%DTC
SET DTTM=%
SET COM="Suspense "_$SELECT($GET(RXRP(RX)):"(Reprint) ",1:"")_"Label Pulled Early"_$SELECT($GET(RXP):" (Partial)",1:"")
SET CNT=0
FOR JJ=0:0
SET JJ=$ORDER(^PSRX(RX,"A",JJ))
IF 'JJ
QUIT
SET CNT=JJ
+4 DO DEL
SET $PIECE(^PSRX(RX,"STA"),"^")=0
KILL PSODEL
SET RFCNT=0
FOR RF=0:0
SET RF=$ORDER(^PSRX(RX,1,RF))
IF 'RF
QUIT
SET RFCNT=RF
+5 ;IHS/MSC/PLS - 07/26/2016
+6 ;I 'RFCNT,'$G(RXP),'$D(RXRP(RX)) S (X,OLD)=$P(^PSRX(RX,2),"^",2) D K DIE
+7 IF 'RFCNT
IF '$GET(RXP)
IF ('$DATA(RXRP(RX))!($DATA(RXRS(RX))))
SET (X,OLD)=$PIECE(^PSRX(RX,2),"^",2)
Begin DoDot:1
+8 ;K DIE S DA=RX,DR="22////"_DT_";101////"_DT_";25////"_DT,DIE=52 D ^DIE
+9 ;IHS/MSC/PLS - 09/20/2011
KILL DIE
SET DA=RX
SET DR="22////"_DT_";101////"_DT_";25////"_DT_";20///"_PSOSITE
SET DIE=52
DO ^DIE
End DoDot:1
KILL DIE
+10 ;IHS/MSC/PLS - 07/26/2016
+11 ;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
+12 IF RFCNT
IF '$GET(RXP)
IF ('$DATA(RXRP(RX))!($DATA(RXRS(RX))))
SET (OLD,X)=+$PIECE($GET(^PSRX(RX,1,RFCNT,0)),"^")
Begin DoDot:1
+13 ;K DIE S DA(1)=RX,DA=RFCNT,DIE="^PSRX("_DA(1)_",1,",DR=".01///"_DT_";10.1///"_DT D ^DIE
+14 ;IHS/MSC/PLS - 09/20/2011
KILL DIE
SET DA(1)=RX
SET DA=RFCNT
SET DIE="^PSRX("_DA(1)_",1,"
SET DR=".01///"_DT_";10.1///"_DT_";8///"_PSOSITE
DO ^DIE
End DoDot:1
KILL DIE
SET $PIECE(^PSRX(RX,3),"^")=DT
+15 IF '$DATA(PDUZ)
SET PDUZ=DUZ
SET CNT=CNT+1
SET ^PSRX(RX,"A",0)="^52.3DA^"_CNT_"^"_CNT
+16 SET ^PSRX(RX,"A",CNT,0)=DTTM_"^S^"_PDUZ_"^"_$SELECT($GET(RXP):6,'RFCNT:RFCNT,RFCNT<6:RFCNT,1:(RFCNT+1))_"^"_COM
+17 DO CPMS
+18 QUIT
CPMS ;
+1 NEW PSOZZDD
SET PSOZZDD="Label printed from suspense"
DO EN^PSOHLSN1(RX,"SC","ZU",PSOZZDD)
KILL PSOZZDD
+2 QUIT
+3 ;
DEL SET DA=SFN
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIK
QUIT
+1 ;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
+2 ;.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
+3 ;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
+4 QUIT
AREC NEW PSOZZDMS
SET PSOZZDMS=0
IF $PIECE(^PSRX(RX,"STA"),"^")=5
SET PSOZZDMS=1
+1 IF $PIECE(^PSRX(RX,"STA"),"^")=5
SET $PIECE(^PSRX(RX,"STA"),"^")=0
SET SFN=$ORDER(^PS(52.5,"B",RX,0))
IF 'SFN&(PSOZZDMS)
DO CPMSG
IF 'SFN
QUIT
DO NOW^%DTC
SET DTTM=%
SET COM="Suspense "_$SELECT($GET(RXRP(RX)):"(Reprint) ",1:"")_"Label Printed"_$SELECT($GET(RXP):" (Partial)",1:"")
+2 SET $PIECE(^PS(52.5,SFN,"P"),"^")=1
Begin DoDot:1
+3 SET ^PS(52.5,"ADL",$EXTRACT(PSOTIME,1,7),SFN)=""
End DoDot:1
KILL ^PS(52.5,"AC",DFN,$PIECE(^PS(52.5,SFN,0),"^",2),SFN)
SET CNT=0
FOR JJ=0:0
SET JJ=$ORDER(^PSRX(RX,"A",JJ))
IF 'JJ
QUIT
SET CNT=JJ
+4 SET RFCNT=0
FOR RF=0:0
SET RF=$ORDER(^PSRX(RX,1,RF))
IF 'RF
QUIT
SET RFCNT=RF
IF RF>5
SET RFCNT=RF+1
+5 SET CNT=CNT+1
SET ^PSRX(RX,"A",0)="^52.3DA^"_CNT_"^"_CNT
SET ^PSRX(RX,"A",CNT,0)=DTTM_"^S^"_DUZ_"^"_$SELECT($GET(RXP):6,1:RFCNT)_"^"_COM
+6 SET $PIECE(^PS(52.5,SFN,0),"^",8)=PSOTIME
SET $PIECE(^PS(52.5,SFN,0),"^",9)=PDUZ
IF '$PIECE(^PS(52.5,SFN,0),"^",6)
SET $PIECE(^PS(52.5,SFN,0),"^",6)=PSOSITE
+7 IF PSOZZDMS
DO CPMSG
+8 QUIT
CPMSG ;
+1 NEW PSOZZDDD
SET PSOZZDDD="Label printed from suspense"
DO EN^PSOHLSN1(RX,"SC","ZU",PSOZZDDD)
KILL PSOZZDDD
+2 QUIT
+3 ;
ARECD DO NOW^%DTC
SET CNT=0
SET DTTM=%
FOR JJ=0:0
SET JJ=$ORDER(^PSRX(RX,"A",JJ))
IF 'JJ
QUIT
SET CNT=JJ
+1 SET RFCNT=0
FOR RF=0:0
SET RF=$ORDER(^PSRX(RX,1,RF))
IF 'RF
QUIT
SET RFCNT=RF
IF RF>5
SET RFCNT=RF+1
+2 SET RXP=$PIECE(^PS(52.5,SFN,0),"^",5)
+3 SET CNT=CNT+1
SET ^PSRX(RX,"A",0)="^52.3DA^"_CNT_"^"_CNT
SET ^PSRX(RX,"A",CNT,0)=DTTM_"^C^"_DUZ_"^"_$SELECT($GET(RXP):6,1:RFCNT)_"^"_COM
KILL RXP
+4 DO EN^PSOHLSN1(RX,"OD","",COM,"A")
+5 QUIT
EX IF '$GET(RXREC)
QUIT
DO NOW^%DTC
SET PSCOU=0
SET DTTM=%
FOR AAA=0:0
SET AAA=$ORDER(^PSRX(RXREC,"A",AAA))
IF 'AAA
QUIT
SET PSCOU=AAA
+1 SET VVV=0
FOR QQQ=0:0
SET QQQ=$ORDER(^PSRX(RXREC,1,QQQ))
IF 'QQQ
QUIT
SET VVV=QQQ
IF QQQ>5
SET VVV=QQQ+1
+2 SET PSOPRT=$PIECE(^PS(52.5,SFN,0),"^",5)
+3 SET PSOEXPI="Expired while on suspense"
+4 SET PSCOU=PSCOU+1
SET ^PSRX(RXREC,"A",0)="^52.3DA^"_PSCOU_"^"_PSCOU
SET ^PSRX(RXREC,"A",PSCOU,0)=DTTM_"^S^"_DUZ_"^"_$SELECT($GET(PSOPRT):6,1:VVV)_"^"_PSOEXPI
+5 DO EN^PSOHLSN1(RXREC,"SC","ZE",PSOEXPI)
+6 KILL PSCOU,AAA,QQQ,VVV,PSOPRT,PSOEXPI
QUIT
SET ; Set DEA in Suspense File
+1 NEW PSOSUDEA
+2 IF '$GET(X)
QUIT
IF '$DATA(^PSRX(X,0))
QUIT
+3 SET PSOSUDEA=$PIECE($GET(^PSRX(X,0)),"^",6)
IF PSOSUDEA
IF $DATA(^PSDRUG(PSOSUDEA,0))
SET $PIECE(^PS(52.5,DA,0),"^",10)=$PIECE(^PSDRUG(PSOSUDEA,0),"^",3)
+4 QUIT
KILL IF '$GET(DA)
QUIT
IF '$DATA(^PS(52.5,DA,0))
QUIT
+1 SET $PIECE(^PS(52.5,DA,0),"^",10)=""
+2 QUIT
SAS ;X-ref on Division field
+1 NEW PSOC7,PSUSPIEN
SET PSUSPIEN=$ORDER(^PS(52.5,"B",DA,0))
IF PSUSPIEN
IF $DATA(^PS(52.5,PSUSPIEN,0))
IF '$PIECE($GET(^(0)),"^",5)
IF '$ORDER(^PSRX(DA,1,0))
Begin DoDot:1
+2 SET PSOC7=$PIECE($GET(^PS(52.5,PSUSPIEN,0)),"^",7)
+3 SET $PIECE(^PS(52.5,PSUSPIEN,0),"^",6)=X
IF $PIECE(^PS(52.5,PSUSPIEN,0),"^",8)&($PIECE(^(0),"^",9))&($PIECE(^(0),"^",11))&($PIECE($GET(^(0)),"^",7)="")
SET ^PS(52.5,"AS",$PIECE(^PS(52.5,PSUSPIEN,0),"^",8),$PIECE(^(0),"^",9),X,$PIECE(^(0),"^",11),PSUSPIEN)=""
+4 SET $PIECE(^PS(52.5,PSUSPIEN,0),"^",6)=X
IF $PIECE(^PS(52.5,PSUSPIEN,0),"^",8)&($PIECE(^(0),"^",9))&($PIECE(^(0),"^",11))&($PIECE($GET(^(0)),"^",7)="P")
SET ^PS(52.5,"APR",$PIECE(^PS(52.5,PSUSPIEN,0),"^",8),$PIECE(^(0),"^",9),X,$PIECE(^(0),"^",11),PSUSPIEN)=""
+5 IF $PIECE(^PS(52.5,PSUSPIEN,0),"^",8)&($PIECE(^(0),"^",9))&($PIECE(^(0),"^",11))&($PIECE($GET(^(0)),"^",7)="P")
KILL ^PS(52.5,"AS",$PIECE(^PS(52.5,PSUSPIEN,0),"^",8),$PIECE(^(0),"^",9),X,$PIECE(^(0),"^",11),PSUSPIEN)
+6 IF PSOC7'=""
DO SCMPX^PSOCMOP(PSUSPIEN,PSOC7)
End DoDot:1
+7 QUIT
KAS ;
+1 NEW PSUSPIEN,PSOC7
SET PSUSPIEN=$ORDER(^PS(52.5,"B",DA,0))
IF PSUSPIEN
IF $DATA(^PS(52.5,PSUSPIEN,0))
IF '$PIECE($GET(^(0)),"^",5)
IF '$ORDER(^PSRX(DA,1,0))
Begin DoDot:1
+2 IF $PIECE(^PS(52.5,PSUSPIEN,0),"^",8)&($PIECE(^(0),"^",9))&($PIECE(^(0),"^",11))&($PIECE(^(0),"^",7)="")
KILL ^PS(52.5,"AS",$PIECE(^PS(52.5,PSUSPIEN,0),"^",8),$PIECE(^(0),"^",9),X,$PIECE(^(0),"^",11),PSUSPIEN)
+3 IF $PIECE(^PS(52.5,PSUSPIEN,0),"^",8)&($PIECE(^(0),"^",9))&($PIECE(^(0),"^",11))&($PIECE(^(0),"^",7)="P")
KILL ^PS(52.5,"APR",$PIECE(^PS(52.5,PSUSPIEN,0),"^",8),$PIECE(^(0),"^",9),X,$PIECE(^(0),"^",11),PSUSPIEN)
+4 SET PSOC7=$PIECE($GET(^PS(52.5,PSUSPIEN,0)),"^",7)
+5 IF PSOC7'=""
DO KCMPX^PSOCMOP(PSUSPIEN,PSOC7)
End DoDot:1
+6 QUIT
SAS1 ;Refill Division x-ref
+1 NEW PSOSPIEN,ZZZ,PSREFCNT,PSOC7
SET PSOSPIEN=$ORDER(^PS(52.5,"B",DA(1),0))
IF PSOSPIEN
IF $DATA(^PS(52.5,PSOSPIEN,0))
IF '$PIECE($GET(^(0)),"^",5)
IF $ORDER(^PSRX(DA(1),1,0))
Begin DoDot:1
+2 SET PSOC7=$PIECE($GET(^PS(52.5,PSOSPIEN,0)),"^",7)
+3 SET PSREFCNT=0
FOR ZZZ=0:0
SET ZZZ=$ORDER(^PSRX(DA(1),1,ZZZ))
IF 'ZZZ
QUIT
SET PSREFCNT=PSREFCNT+1
+4 IF PSREFCNT=DA
SET $PIECE(^PS(52.5,PSOSPIEN,0),"^",6)=X
Begin DoDot:2
+5 IF $PIECE(^PS(52.5,PSOSPIEN,0),"^",8)&($PIECE(^(0),"^",9))&($PIECE(^(0),"^",11))&($PIECE($GET(^(0)),"^",7)="")
SET ^PS(52.5,"AS",$PIECE(^PS(52.5,PSOSPIEN,0),"^",8),$PIECE(^(0),"^",9),X,$PIECE(^(0),"^",11),PSOSPIEN)=""
+6 IF $PIECE(^PS(52.5,PSOSPIEN,0),"^",8)&($PIECE(^(0),"^",9))&($PIECE(^(0),"^",11))&($PIECE($GET(^(0)),"^",7)="P")
SET ^PS(52.5,"APR",$PIECE(^PS(52.5,PSOSPIEN,0),"^",8),$PIECE(^(0),"^",9),X,$PIECE(^(0),"^",11),PSOSPIEN)=""
+7 IF $PIECE(^PS(52.5,PSOSPIEN,0),"^",8)&($PIECE(^(0),"^",9))&($PIECE(^(0),"^",11))&($PIECE($GET(^(0)),"^",7)="P")
KILL ^PS(52.5,"AS",$PIECE(^PS(52.5,PSOSPIEN,0),"^",8),$PIECE(^(0),"^",9),X,$PIECE(^(0),"^",11),PSOSPIEN)
+8 IF PSOC7'=""
DO SCMPX^PSOCMOP(PSOSPIEN,PSOC7)
End DoDot:2
End DoDot:1
+9 QUIT
KAS1 ;
+1 NEW PSOSPIEN,ZZZ,PSREFCNT,PSOC7
SET PSOSPIEN=$ORDER(^PS(52.5,"B",DA(1),0))
IF PSOSPIEN
IF $DATA(^PS(52.5,PSOSPIEN,0))
IF '$PIECE($GET(^(0)),"^",5)
IF $ORDER(^PSRX(DA(1),1,0))
Begin DoDot:1
+2 SET PSREFCNT=0
FOR ZZZ=0:0
SET ZZZ=$ORDER(^PSRX(DA(1),1,ZZZ))
IF 'ZZZ
QUIT
SET PSREFCNT=PSREFCNT+1
+3 IF PSREFCNT=DA
Begin DoDot:2
+4 IF $PIECE(^PS(52.5,PSOSPIEN,0),"^",8)&($PIECE(^(0),"^",9))&($PIECE(^(0),"^",11))&($PIECE(^(0),"^",7)="")
KILL ^PS(52.5,"AS",$PIECE(^PS(52.5,PSOSPIEN,0),"^",8),$PIECE(^(0),"^",9),X,$PIECE(^(0),"^",11),PSOSPIEN)
+5 IF $PIECE(^PS(52.5,PSOSPIEN,0),"^",8)&($PIECE(^(0),"^",9))&($PIECE(^(0),"^",11))&($PIECE(^(0),"^",7)="P")
KILL ^PS(52.5,"APR",$PIECE(^PS(52.5,PSOSPIEN,0),"^",8),$PIECE(^(0),"^",9),X,$PIECE(^(0),"^",11),PSOSPIEN)
+6 SET PSOC7=$PIECE($GET(^PS(52.5,PSOSPIEN,0)),"^",7)
+7 IF PSOC7'=""
DO KCMPX^PSOCMOP(PSOSPIEN,PSOC7)
End DoDot:2
End DoDot:1
+8 QUIT
SAS2 ;For partials
+1 NEW PSPSPIEN
SET PSPSPIEN=$ORDER(^PS(52.5,"B",DA(1),0))
IF PSPSPIEN
IF $DATA(^PS(52.5,PSPSPIEN,0))
IF $PIECE($GET(^(0)),"^",5)
Begin DoDot:1
+2 IF DA=$PIECE(^PS(52.5,PSPSPIEN,0),"^",5)
SET $PIECE(^(0),"^",6)=X
Begin DoDot:2
+3 IF $PIECE(^PS(52.5,PSPSPIEN,0),"^",8)&($PIECE(^(0),"^",9))&($PIECE(^(0),"^",11))&($PIECE($GET(^(0)),"^",7)="")
SET ^PS(52.5,"AS",$PIECE(^PS(52.5,PSPSPIEN,0),"^",8),$PIECE(^(0),"^",9),X,$PIECE(^(0),"^",11),PSPSPIEN)=""
+4 IF $PIECE(^PS(52.5,PSPSPIEN,0),"^",8)&($PIECE(^(0),"^",9))&($PIECE(^(0),"^",11))&($PIECE($GET(^(0)),"^",7)="P")
SET ^PS(52.5,"APR",$PIECE(^PS(52.5,PSPSPIEN,0),"^",8),$PIECE(^(0),"^",9),X,$PIECE(^(0),"^",11),PSPSPIEN)=""
+5 IF $PIECE(^PS(52.5,PSPSPIEN,0),"^",8)&($PIECE(^(0),"^",9))&($PIECE(^(0),"^",11))&($PIECE($GET(^(0)),"^",7)="P")
KILL ^PS(52.5,"AS",$PIECE(^PS(52.5,PSPSPIEN,0),"^",8),$PIECE(^(0),"^",9),X,$PIECE(^(0),"^",11),PSPSPIEN)
End DoDot:2
End DoDot:1
+6 QUIT
KAS2 ;
+1 NEW PSPSPIEN
SET PSPSPIEN=$ORDER(^PS(52.5,"B",DA(1),0))
IF PSPSPIEN
IF $DATA(^PS(52.5,PSPSPIEN,0))
IF $PIECE($GET(^(0)),"^",5)
Begin DoDot:1
+2 IF DA=$PIECE(^PS(52.5,PSPSPIEN,0),"^",5)
Begin DoDot:2
+3 IF $PIECE(^PS(52.5,PSPSPIEN,0),"^",8)&($PIECE(^(0),"^",9))&($PIECE(^(0),"^",11))&($PIECE(^(0),"^",7)="")
KILL ^PS(52.5,"AS",$PIECE(^PS(52.5,PSPSPIEN,0),"^",8),$PIECE(^(0),"^",9),X,$PIECE(^(0),"^",11),PSPSPIEN)
+4 IF $PIECE(^PS(52.5,PSPSPIEN,0),"^",8)&($PIECE(^(0),"^",9))&($PIECE(^(0),"^",11))&($PIECE(^(0),"^",7)="P")
KILL ^PS(52.5,"APR",$PIECE(^PS(52.5,PSPSPIEN,0),"^",8),$PIECE(^(0),"^",9),X,$PIECE(^(0),"^",11),PSPSPIEN)
End DoDot:2
End DoDot:1
+5 QUIT
SDEA ;Update Suspense with DEA
+1 NEW PSSSPIEN
SET PSSSPIEN=$ORDER(^PS(52.5,"B",DA,0))
IF '$GET(PSSSPIEN)
QUIT
+2 IF $DATA(^PS(52.5,PSSSPIEN,0))
IF $PIECE($GET(^("P")),"^")=0
SET $PIECE(^PS(52.5,PSSSPIEN,0),"^",10)=$PIECE($GET(^PSDRUG(+X,0)),"^",3)
+3 QUIT
SDIV NEW PSODINT,PSDVP,PSLOOP
+1 SET PSODINT=+$PIECE($GET(^PS(52.5,DA,0)),"^")
IF 'PSODINT
QUIT
+2 SET PSDVP=$PIECE($GET(^PS(52.5,DA,0)),"^",5)
IF PSDVP
Begin DoDot:1
+3 IF $DATA(^PSRX(PSODINT,"P",+PSDVP,0))
SET $PIECE(^(0),"^",9)=X
End DoDot:1
QUIT
+4 SET PSDVP=0
FOR PSLOOP=0:0
SET PSLOOP=$ORDER(^PSRX(PSODINT,1,PSLOOP))
IF 'PSLOOP
QUIT
SET PSDVP=PSLOOP
+5 IF PSDVP
IF $DATA(^PSRX(PSODINT,1,PSDVP,0))
SET $PIECE(^(0),"^",9)=X
QUIT
+6 IF $DATA(^PSRX(PSODINT,2))
SET $PIECE(^(2),"^",9)=X
+7 QUIT
ZZ(RX) ; Returns VA print name, Trade Name, Generic Name
+1 SET I50=$PIECE(^PSRX(RX,0),U,6)
SET ZDRUG=$PIECE(^PSDRUG(I50,0),U)
+2 IF $GET(ZDRUG)']""
SET ZDRUG="DRUG NOT ON FILE ("_I50_")"
GOTO END
+3 IF $GET(^PSRX(RX,"TN"))]""
SET ZDRUG=^("TN")
GOTO END
+4 IF $DATA(^PSDRUG("AQ",I50))
IF ($DATA(^PSDRUG(I50,"ND")))
Begin DoDot:1
+5 SET Z1=$PIECE($GET(^PSDRUG(I50,"ND")),U)
SET Z2=$PIECE($GET(^("ND")),U,3)
+6 IF $GET(Z1)
IF ($GET(Z2))
Begin DoDot:2
+7 IF $TEXT(^PSNAPIS)]""
SET PSOXN=$$PROD2^PSNAPIS(Z1,Z2)
SET ZDRUG=$PIECE($GET(PSOXN),"^")
KILL PSOXN
QUIT
+8 SET ZDRUG=$PIECE($GET(^PSNDF(Z1,5,Z2,2)),"^")
End DoDot:2
+9 KILL Z1,Z2,I50
End DoDot:1
END KILL I50
+1 QUIT ZDRUG
