PSORXPA1 ;BIR/SAB - listman partial prescriptions ;07/14/93
;;7.0;OUTPATIENT PHARMACY;**11,27,56,77,130,152,181,174,287**;DEC 1997;Build 77
;External references L,UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
;External reference to ^PSDRUG supported by DBIA 221
;External reference to ^DD(52 supported by DBIA 999
I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!" Q
;I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial has already been requested!" Q
I $D(RXRS($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="Rx is being pulled from suspense!" Q
S PSORPDFN=+$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^",2)
S PSOPLCK=$$L^PSSLOCK(PSORPDFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK,PSORPDFN D Q
.S VALMBCK=""
K PSOPLCK D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) D UL^PSSLOCK(PSORPDFN) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG,PSORPDFN Q
I '$G(RXPR($P(PSOLST(ORN),"^",2))) S RX=$P(PSOLST(ORN),"^",2) D VALID^PSORXRP1 I $G(QFLG) S VALMBCK="",VALMSG="A New Label has been requested already!" K QFLG,RX D ULK Q
D FULL^VALM1 I '$D(PSOPAR) D ^PSOLSET D:'$D(PSOPAR) ULK G:'$D(PSOPAR) KL
S DA=$P(PSOLST(ORN),"^",2),RX0=^PSRX(DA,0),J=DA,RX2=$G(^(2)),R3=$G(^(3)) S:'$G(BBFLG) BBRX(1)=""
N PSORF,PSOTRIC D TRIC^PSORXL1(DA) I PSOTRIC&($$STATUS^PSOBPSUT(DA,PSORF)'["PAYABLE") D Q
. S VALMBCK="",VALMSG="Partial cannot be filled on Tricare non-payable Rx."
I +$P($G(^PSRX(DA,2)),"^",6)<DT D
.S:$P($G(^PSRX(DA,"STA")),"^")<12 $P(^PSRX(DA,"STA"),"^")=11
.S COMM="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"/"_$E($P(^(2),"^",6),6,7)_"/"_$E($P(^(2),"^",6),2,3)
.S STAT="SC",PHARMST="ZE" D EN^PSOHLSN1(DA,STAT,PHARMST,COMM) K STAT,PHARMST,COMM,RX0,J,RX2,R3
;I +$P($G(^PSRX(DA,2)),"^",6)<PSODTCUT D K DA S VALMBCK="R" Q
;.S VALMSG="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"/"_$E($P(^(2),"^",6),6,7)_"/"_$E($P(^(2),"^",6),2,3)
I +^PSRX(DA,"STA"),+^("STA")'=5,+^("STA")'=11 D K DA S VALMBCK="R" D ULK Q
.S C=";"_+^PSRX(DA,"STA")_":",X=$P(^DD(52,100,0),"^",3),E=$F(X,C),D=$P($E(X,E,999),";")
.S VALMSG="Prescription is in a "_D_" status."
I $G(PSXSYS),($O(^PS(52.5,"B",DA,""))) S PSOZ1=$O(^PS(52.5,"B",DA,"")) D
.I $P($G(^PS(52.5,PSOZ1,0)),"^",7)="Q"!($P($G(^(0)),"^",7)="L") D
..W !!,"A partial entered for this Rx cannot be suspended."
..W !,"A fill for this Rx is already suspended for CMOP transmission."
..W !,"You may pull this fill from suspense or enter a partial and print the label.",!!
;..S PSOZZ=1 K PSOZ1
CLC S PSOCLC=DUZ,PHYS=$P(^PSRX(DA,0),"^",4),DRG=$P(^(0),"^",6)
I 'PHYS,$O(^PSRX(DA,1,0)) F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S PHYS=$S($P(^PSRX(DA,1,I,0),"^",17):$P(^PSRX(DA,1,I,0),"^",17),1:PHYS)
S PSOPRZ=0 I $O(^PSRX(DA,"P",0)) N Z2 F Z2=0:0 S Z2=$O(^PSRX(DA,"P",Z2)) Q:'Z2 S PSOPRZ=Z2
K Z1,PRMK S PM=1,RXN=DA,RXF=6,DIE("NO^")="BACKOUTOK",DIE=52
;DR="[PSO PARTIAL]"
S DR="K PM,PQ;60;Q;S:$O(Y(1))]""""!($G(PM)) Y=""@1"";35;@1;K PM;"
S DR(2,52.2)=".01;S Z1=D1;.02;S:X=""M""!('$P($G(PSOPAR),U,12)) PM=1;.04;S:X=U PQ=1;.041R;S:X=U PQ=1;.05;.07////^S X=DUZ;6////^S X=PHYS;Q;.08///^S X=""NOW"";S PDT=X;.09////^S X=PSOSITE;.03;S:X=U PQ=1;S PRMK=X"
D ^DIE
I $D(RXPR(DA)),'$D(^PSRX(DA,"P",$G(RXPR(DA)))) D RMP^PSOCAN3
G:'$G(Z1) CLCX
I $G(PRMK)']"",Z1>PSOPRZ D ULK G KILL
I Z1,$G(PRMK)]"" D D:$T(EN^PSOHDR)]"" EN^PSOHDR("PPAR",RXN) K DIE,RXN,RXF
.D ACT S:$P($G(^PSRX(RXN,"P",Z1,0)),"^",2)["W" PSODFN=$P(^PSRX(RXN,0),"^",2),BINGRTE="W",BBFLG=1,BBRX(1)=$G(BBRX(1))_RXN_","
.S ZD(RXN)=+^PSRX(RXN,"P",Z1,0),^PSRX(RXN,"TYPE")=Z1,$P(^PSRX(RXN,"P",Z1,0),"^",11)=$P($G(^PSDRUG(DRG,660)),"^",6),RXF=6,RXP=Z1,RXPR(RXN)=RXP
.;I $G(PSOZZ)=1,($G(Z1)) D Q1^PSORXL K Z1,PSOZZ Q
.I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=RXN_"," Q
.F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 Q:PSORX("PSOL",PSOX1)[RXN_"," S PSOX2=PSOX1
.I PSOX1 Q
.I $L(PSORX("PSOL",PSOX2))+$L(RXN)<220 S:PSORX("PSOL",PSOX2)'[RXN_"," PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RXN_","
.E S PSORX("PSOL",PSOX2+1)=RXN_","
S:'$D(PSOFROM) PSOFROM="PARTIAL" S BINGCRT=1 ;D:$D(BINGRTE)&($D(DISGROUP)) ^PSOBING1 K BINGRTE,TM,TM1
CLCX D ULK K DR,DIE,DRG,PPL,RXP,IOP,DA,PHYS,PSOPRZ S VALMBCK="R" Q
;
KILL S DA=Z1,DIK="^PSRX("_RXN_",""P""," D ^DIK S ^PSRX(RXN,"TYPE")=0
D ULK S VALMSG="No Partial Fill Dispensed",VALMBCK="R" Q
KL K DFN,RFDAT,RLL,%,PRMK,PM,%Y,%X,D0,D1,DA,DI,DIC,DIE,DLAYGO,DQ,DR,I,II,J,JJJ,N,PHYS,PS,PSDATE,RFL,RFL1,RXF,ST,ST0,Z,Z1,X,Y,PDT,PSL,PSNP
K PSOM,PSOP,PSOD,PSOU,DIK,DUOUT,IFN,RXN,DRG,HRX,I1,PSOCLC,PSOLIST,PSOLST,PSPAR,RXP D KVA^VADPT Q
ACT ;adds activity info for partial rx
S RXF=0 F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1
S DA=0 F FDA=0:0 S FDA=$O(^PSRX(RXN,"A",FDA)) Q:'FDA S DA=FDA
S DA=DA+1,^PSRX(RXN,"A",0)="^52.3DA^"_DA_"^"_DA,^PSRX(RXN,"A",DA,0)=DT_"^"_"P"_"^"_DUZ_"^"_RXF_"^"_PRMK
EX K RXF,I,FDA S DA=RXN
Q
ULK ;
D UL^PSSLOCK(+$G(PSORPDFN))
D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
K PSOMSG,PSOPLCK,PSORPDFN
Q
PSORXPA1 ;BIR/SAB - listman partial prescriptions ;07/14/93
+1 ;;7.0;OUTPATIENT PHARMACY;**11,27,56,77,130,152,181,174,287**;DEC 1997;Build 77
+2 ;External references L,UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
+3 ;External reference to ^PSDRUG supported by DBIA 221
+4 ;External reference to ^DD(52 supported by DBIA 999
+5 IF $DATA(RXRP($PIECE(PSOLST(ORN),"^",2)))
SET VALMBCK=""
SET VALMSG="A Reprint Label has been requested!"
QUIT
+6 ;I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial has already been requested!" Q
+7 IF $DATA(RXRS($PIECE(PSOLST(ORN),"^",2)))
SET VALMBCK=""
SET VALMSG="Rx is being pulled from suspense!"
QUIT
+8 SET PSORPDFN=+$PIECE($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),0)),"^",2)
+9 SET PSOPLCK=$$L^PSSLOCK(PSORPDFN,0)
IF '$GET(PSOPLCK)
DO LOCK^PSOORCPY
SET VALMSG=$SELECT($PIECE($GET(PSOPLCK),"^",2)'="":$PIECE($GET(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.")
KILL PSOPLCK,PSORPDFN
Begin DoDot:1
+10 SET VALMBCK=""
End DoDot:1
QUIT
+11 KILL PSOPLCK
DO PSOL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
IF '$GET(PSOMSG)
DO UL^PSSLOCK(PSORPDFN)
SET VALMSG=$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing this order.")
SET VALMBCK=""
KILL PSOMSG,PSORPDFN
QUIT
+12 IF '$GET(RXPR($PIECE(PSOLST(ORN),"^",2)))
SET RX=$PIECE(PSOLST(ORN),"^",2)
DO VALID^PSORXRP1
IF $GET(QFLG)
SET VALMBCK=""
SET VALMSG="A New Label has been requested already!"
KILL QFLG,RX
DO ULK
QUIT
+13 DO FULL^VALM1
IF '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
DO ULK
IF '$DATA(PSOPAR)
GOTO KL
+14 SET DA=$PIECE(PSOLST(ORN),"^",2)
SET RX0=^PSRX(DA,0)
SET J=DA
SET RX2=$GET(^(2))
SET R3=$GET(^(3))
IF '$GET(BBFLG)
SET BBRX(1)=""
+15 NEW PSORF,PSOTRIC
DO TRIC^PSORXL1(DA)
IF PSOTRIC&($$STATUS^PSOBPSUT(DA,PSORF)'["PAYABLE")
Begin DoDot:1
+16 SET VALMBCK=""
SET VALMSG="Partial cannot be filled on Tricare non-payable Rx."
End DoDot:1
QUIT
+17 IF +$PIECE($GET(^PSRX(DA,2)),"^",6)<DT
Begin DoDot:1
+18 IF $PIECE($GET(^PSRX(DA,"STA")),"^")<12
SET $PIECE(^PSRX(DA,"STA"),"^")=11
+19 SET COMM="Medication Expired on "_$EXTRACT($PIECE(^PSRX(DA,2),"^",6),4,5)_"/"_$EXTRACT($PIECE(^(2),"^",6),6,7)_"/"_$EXTRACT($PIECE(^(2),"^",6),2,3)
+20 SET STAT="SC"
SET PHARMST="ZE"
DO EN^PSOHLSN1(DA,STAT,PHARMST,COMM)
KILL STAT,PHARMST,COMM,RX0,J,RX2,R3
End DoDot:1
+21 ;I +$P($G(^PSRX(DA,2)),"^",6)<PSODTCUT D K DA S VALMBCK="R" Q
+22 ;.S VALMSG="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"/"_$E($P(^(2),"^",6),6,7)_"/"_$E($P(^(2),"^",6),2,3)
+23 IF +^PSRX(DA,"STA")
IF +^("STA")'=5
IF +^("STA")'=11
Begin DoDot:1
+24 SET C=";"_+^PSRX(DA,"STA")_":"
SET X=$PIECE(^DD(52,100,0),"^",3)
SET E=$FIND(X,C)
SET D=$PIECE($EXTRACT(X,E,999),";")
+25 SET VALMSG="Prescription is in a "_D_" status."
End DoDot:1
KILL DA
SET VALMBCK="R"
DO ULK
QUIT
+26 IF $GET(PSXSYS)
IF ($ORDER(^PS(52.5,"B",DA,"")))
SET PSOZ1=$ORDER(^PS(52.5,"B",DA,""))
Begin DoDot:1
+27 IF $PIECE($GET(^PS(52.5,PSOZ1,0)),"^",7)="Q"!($PIECE($GET(^(0)),"^",7)="L")
Begin DoDot:2
+28 WRITE !!,"A partial entered for this Rx cannot be suspended."
+29 WRITE !,"A fill for this Rx is already suspended for CMOP transmission."
+30 WRITE !,"You may pull this fill from suspense or enter a partial and print the label.",!!
End DoDot:2
End DoDot:1
+31 ;..S PSOZZ=1 K PSOZ1
CLC SET PSOCLC=DUZ
SET PHYS=$PIECE(^PSRX(DA,0),"^",4)
SET DRG=$PIECE(^(0),"^",6)
+1 IF 'PHYS
IF $ORDER(^PSRX(DA,1,0))
FOR I=0:0
SET I=$ORDER(^PSRX(DA,1,I))
IF 'I
QUIT
SET PHYS=$SELECT($PIECE(^PSRX(DA,1,I,0),"^",17):$PIECE(^PSRX(DA,1,I,0),"^",17),1:PHYS)
+2 SET PSOPRZ=0
IF $ORDER(^PSRX(DA,"P",0))
NEW Z2
FOR Z2=0:0
SET Z2=$ORDER(^PSRX(DA,"P",Z2))
IF 'Z2
QUIT
SET PSOPRZ=Z2
+3 KILL Z1,PRMK
SET PM=1
SET RXN=DA
SET RXF=6
SET DIE("NO^")="BACKOUTOK"
SET DIE=52
+4 ;DR="[PSO PARTIAL]"
+5 SET DR="K PM,PQ;60;Q;S:$O(Y(1))]""""!($G(PM)) Y=""@1"";35;@1;K PM;"
+6 SET DR(2,52.2)=".01;S Z1=D1;.02;S:X=""M""!('$P($G(PSOPAR),U,12)) PM=1;.04;S:X=U PQ=1;.041R;S:X=U PQ=1;.05;.07////^S X=DUZ;6////^S X=PHYS;Q;.08///^S X=""NOW"";S PDT=X;.09////^S X=PSOSITE;.03;S:X=U PQ=1;S PRMK=X"
+7 DO ^DIE
+8 IF $DATA(RXPR(DA))
IF '$DATA(^PSRX(DA,"P",$GET(RXPR(DA))))
DO RMP^PSOCAN3
+9 IF '$GET(Z1)
GOTO CLCX
+10 IF $GET(PRMK)']""
IF Z1>PSOPRZ
DO ULK
GOTO KILL
+11 IF Z1
IF $GET(PRMK)]""
Begin DoDot:1
+12 DO ACT
IF $PIECE($GET(^PSRX(RXN,"P",Z1,0)),"^",2)["W"
SET PSODFN=$PIECE(^PSRX(RXN,0),"^",2)
SET BINGRTE="W"
SET BBFLG=1
SET BBRX(1)=$GET(BBRX(1))_RXN_","
+13 SET ZD(RXN)=+^PSRX(RXN,"P",Z1,0)
SET ^PSRX(RXN,"TYPE")=Z1
SET $PIECE(^PSRX(RXN,"P",Z1,0),"^",11)=$PIECE($GET(^PSDRUG(DRG,660)),"^",6)
SET RXF=6
SET RXP=Z1
SET RXPR(RXN)=RXP
+14 ;I $G(PSOZZ)=1,($G(Z1)) D Q1^PSORXL K Z1,PSOZZ Q
+15 IF $GET(PSORX("PSOL",1))']""
SET PSORX("PSOL",1)=RXN_","
QUIT
+16 FOR PSOX1=0:0
SET PSOX1=$ORDER(PSORX("PSOL",PSOX1))
IF 'PSOX1
QUIT
IF PSORX("PSOL",PSOX1)[RXN_","
QUIT
SET PSOX2=PSOX1
+17 IF PSOX1
QUIT
+18 IF $LENGTH(PSORX("PSOL",PSOX2))+$LENGTH(RXN)<220
IF PSORX("PSOL",PSOX2)'[RXN_","
SET PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RXN_","
+19 IF '$TEST
SET PSORX("PSOL",PSOX2+1)=RXN_","
End DoDot:1
IF $TEXT(EN^PSOHDR)]""
DO EN^PSOHDR("PPAR",RXN)
KILL DIE,RXN,RXF
+20 ;D:$D(BINGRTE)&($D(DISGROUP)) ^PSOBING1 K BINGRTE,TM,TM1
IF '$DATA(PSOFROM)
SET PSOFROM="PARTIAL"
SET BINGCRT=1
CLCX DO ULK
KILL DR,DIE,DRG,PPL,RXP,IOP,DA,PHYS,PSOPRZ
SET VALMBCK="R"
QUIT
+1 ;
KILL SET DA=Z1
SET DIK="^PSRX("_RXN_",""P"","
DO ^DIK
SET ^PSRX(RXN,"TYPE")=0
+1 DO ULK
SET VALMSG="No Partial Fill Dispensed"
SET VALMBCK="R"
QUIT
KL KILL DFN,RFDAT,RLL,%,PRMK,PM,%Y,%X,D0,D1,DA,DI,DIC,DIE,DLAYGO,DQ,DR,I,II,J,JJJ,N,PHYS,PS,PSDATE,RFL,RFL1,RXF,ST,ST0,Z,Z1,X,Y,PDT,PSL,PSNP
+1 KILL PSOM,PSOP,PSOD,PSOU,DIK,DUOUT,IFN,RXN,DRG,HRX,I1,PSOCLC,PSOLIST,PSOLST,PSPAR,RXP
DO KVA^VADPT
QUIT
ACT ;adds activity info for partial rx
+1 SET RXF=0
FOR I=0:0
SET I=$ORDER(^PSRX(RXN,1,I))
IF 'I
QUIT
SET RXF=I
IF I>5
SET RXF=I+1
+2 SET DA=0
FOR FDA=0:0
SET FDA=$ORDER(^PSRX(RXN,"A",FDA))
IF 'FDA
QUIT
SET DA=FDA
+3 SET DA=DA+1
SET ^PSRX(RXN,"A",0)="^52.3DA^"_DA_"^"_DA
SET ^PSRX(RXN,"A",DA,0)=DT_"^"_"P"_"^"_DUZ_"^"_RXF_"^"_PRMK
EX KILL RXF,I,FDA
SET DA=RXN
+1 QUIT
ULK ;
+1 DO UL^PSSLOCK(+$GET(PSORPDFN))
+2 DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
+3 KILL PSOMSG,PSOPLCK,PSORPDFN
+4 QUIT
