- 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
