PSORXPA1 ;BIR/SAB - listman partial prescriptions ;Aug 06, 2021@13:21:01
;;7.0;OUTPATIENT PHARMACY;**11,27,56,77,130,152,181,174,287,385,442,528,630,441**;DEC 1997;Build 208
;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 $$CS(PSOLST(ORN)) W !!,"This is a controlled substance. Cannot partial fill Rx.",! S DIR(0)="FO",DIR("A")="Press RETURN to continue" D ^DIR Q
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)
I +$P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")=0,$G(^PSRX($P(PSOLST(ORN),"^",2),"PARK")) S VALMBCK="",VALMSG="Rx is PARKED; Unpark Rx before acting!" Q ;441 PAPI
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)=""
; BNT PSO*7*385
N PSOELIG,PSORF,PSOTRIC,PSOTCQ
; Get Patient Eligibility from PSORX("PATIENT STATUS") or PTST.
S PSOELIG=0
S PSOELIG=$S($E(PSORX("PATIENT STATUS"),1)="T":1,$G(PTST)="TRICARE":1,$E(PSORX("PATIENT STATUS"),1)="C":2,$G(PTST)="CHAMPVA":2,1:0)
S PSORF=$$LSTRFL^PSOBPSU1(DA),PSOTRIC=$$TRIC^PSOREJP1(DA,PSORF),PSOTCQ=0
; PSOELIG will contain the Patient's eligibility for Rx's where the BILLING ELIGIBILITY INDICATOR isn't populated.
I PSOTRIC!PSOELIG D Q:PSOTCQ
. ; Check for PSO TRICARE/CHAMPVA security key
. I '$D(^XUSEC("PSO TRICARE/CHAMPVA",DUZ)) D Q
. . S PSOTCQ=1,VALMBCK="R",VALMSG="Action Requires <PSO TRICARE/CHAMPVA> security key"
. ; Is this RX non-billable?
. I $$ECME^PSOBPSUT(DA)="" D Q:PSOTCQ
. . N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
. . S DIR(0)="Y"
. . S DIR("A",1)="This partial fill is for a "_$$ELIGDISP^PSOREJP1(DA,PSORF)_" non-billable Rx and will not be reimbursed."
. . S DIR("A")="Do you wish to continue"
. . D ^DIR I Y'=1 S PSOTCQ=1,VALMBCK="R"
. ; Is this RX rejected?
. I $$STATUS^PSOBPSUT(DA,PSORF)="E REJECTED" D Q:PSOTCQ
. . N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
. . S DIR(0)="Y"
. . S DIR("A",1)="This partial fill is for a "_$$ELIGDISP^PSOREJP1(DA,PSORF)_" rejected Rx and will not be reimbursed."
. . S DIR("A")="Do you wish to continue"
. . D ^DIR I Y'=1 S PSOTCQ=1,VALMBCK="R"
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)!$D(^PSRX(DA,"P",Z1,0))) 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
; BNT PSO*7*385 Add audit log entry for TRICARE or CHAMPVA RX
N RXJST
I PSOTRIC!PSOELIG D
. I PSOTRIC S RXJST=$S(PSOTRIC=1:"TRICARE",PSOTRIC=2:"CHAMPVA",1:"")_" Partial Fill"
. I PSOELIG S RXJST=$S(PSOELIG=1:"TRICARE",PSOELIG=2:"CHAMPVA",1:"")_" Partial Fill"
. D AUDIT^PSOTRI(RXN,RXF,,RXJST,"P",$S(PSOTRIC=1:"T",PSOELIG=1:"T",1:"C"))
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
CS(LINEITEM) ; controlled substance check
; Input: LINEITEM - the line item that was selected from the list of active Rx's
; off the Medication Profile screen rendered using PSO LM BACKDOOR ORDERS
;Output: $$CS - 1:YES / 0:NO
N RXIEN,DRGIEN,CSVAL
S RXIEN=$P(LINEITEM,"^",2)
S DRGIEN=$$GET1^DIQ(52,RXIEN,6,"I") I 'DRGIEN Q 0
S CSVAL=$$GET1^DIQ(50,DRGIEN,3)
I CSVAL,CSVAL>0,CSVAL<6 Q 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORXPA1 7598 printed Dec 13, 2024@02:34:35 Page 2
PSORXPA1 ;BIR/SAB - listman partial prescriptions ;Aug 06, 2021@13:21:01
+1 ;;7.0;OUTPATIENT PHARMACY;**11,27,56,77,130,152,181,174,287,385,442,528,630,441**;DEC 1997;Build 208
+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 ;
+6 IF $$CS(PSOLST(ORN))
WRITE !!,"This is a controlled substance. Cannot partial fill Rx.",!
SET DIR(0)="FO"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
QUIT
+7 IF $DATA(RXRP($PIECE(PSOLST(ORN),"^",2)))
SET VALMBCK=""
SET VALMSG="A Reprint Label has been requested!"
QUIT
+8 ;I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial has already been requested!" Q
+9 IF $DATA(RXRS($PIECE(PSOLST(ORN),"^",2)))
SET VALMBCK=""
SET VALMSG="Rx is being pulled from suspense!"
QUIT
+10 SET PSORPDFN=+$PIECE($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),0)),"^",2)
+11 ;441 PAPI
IF +$PIECE($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),"STA")),"^")=0
IF $GET(^PSRX($PIECE(PSOLST(ORN),"^",2),"PARK"))
SET VALMBCK=""
SET VALMSG="Rx is PARKED; Unpark Rx before acting!"
QUIT
+12 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
+13 SET VALMBCK=""
End DoDot:1
QUIT
+14 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
+15 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
+16 DO FULL^VALM1
IF '$DATA(PSOPAR)
DO ^PSOLSET
if '$DATA(PSOPAR)
DO ULK
if '$DATA(PSOPAR)
GOTO KL
+17 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)=""
+18 ; BNT PSO*7*385
+19 NEW PSOELIG,PSORF,PSOTRIC,PSOTCQ
+20 ; Get Patient Eligibility from PSORX("PATIENT STATUS") or PTST.
+21 SET PSOELIG=0
+22 SET PSOELIG=$SELECT($EXTRACT(PSORX("PATIENT STATUS"),1)="T":1,$GET(PTST)="TRICARE":1,$EXTRACT(PSORX("PATIENT STATUS"),1)="C":2,$GET(PTST)="CHAMPVA":2,1:0)
+23 SET PSORF=$$LSTRFL^PSOBPSU1(DA)
SET PSOTRIC=$$TRIC^PSOREJP1(DA,PSORF)
SET PSOTCQ=0
+24 ; PSOELIG will contain the Patient's eligibility for Rx's where the BILLING ELIGIBILITY INDICATOR isn't populated.
+25 IF PSOTRIC!PSOELIG
Begin DoDot:1
+26 ; Check for PSO TRICARE/CHAMPVA security key
+27 IF '$DATA(^XUSEC("PSO TRICARE/CHAMPVA",DUZ))
Begin DoDot:2
+28 SET PSOTCQ=1
SET VALMBCK="R"
SET VALMSG="Action Requires <PSO TRICARE/CHAMPVA> security key"
End DoDot:2
QUIT
+29 ; Is this RX non-billable?
+30 IF $$ECME^PSOBPSUT(DA)=""
Begin DoDot:2
+31 NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
+32 SET DIR(0)="Y"
+33 SET DIR("A",1)="This partial fill is for a "_$$ELIGDISP^PSOREJP1(DA,PSORF)_" non-billable Rx and will not be reimbursed."
+34 SET DIR("A")="Do you wish to continue"
+35 DO ^DIR
IF Y'=1
SET PSOTCQ=1
SET VALMBCK="R"
End DoDot:2
if PSOTCQ
QUIT
+36 ; Is this RX rejected?
+37 IF $$STATUS^PSOBPSUT(DA,PSORF)="E REJECTED"
Begin DoDot:2
+38 NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
+39 SET DIR(0)="Y"
+40 SET DIR("A",1)="This partial fill is for a "_$$ELIGDISP^PSOREJP1(DA,PSORF)_" rejected Rx and will not be reimbursed."
+41 SET DIR("A")="Do you wish to continue"
+42 DO ^DIR
IF Y'=1
SET PSOTCQ=1
SET VALMBCK="R"
End DoDot:2
if PSOTCQ
QUIT
End DoDot:1
if PSOTCQ
QUIT
+43 IF +$PIECE($GET(^PSRX(DA,2)),"^",6)<DT
Begin DoDot:1
+44 if $PIECE($GET(^PSRX(DA,"STA")),"^")<12
SET $PIECE(^PSRX(DA,"STA"),"^")=11
+45 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)
+46 SET STAT="SC"
SET PHARMST="ZE"
DO EN^PSOHLSN1(DA,STAT,PHARMST,COMM)
KILL STAT,PHARMST,COMM,RX0,J,RX2,R3
End DoDot:1
+47 ;I +$P($G(^PSRX(DA,2)),"^",6)<PSODTCUT D K DA S VALMBCK="R" Q
+48 ;.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)
+49 IF +^PSRX(DA,"STA")
IF +^("STA")'=5
IF +^("STA")'=11
Begin DoDot:1
+50 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),";")
+51 SET VALMSG="Prescription is in a "_D_" status."
End DoDot:1
KILL DA
SET VALMBCK="R"
DO ULK
QUIT
+52 IF $GET(PSXSYS)
IF ($ORDER(^PS(52.5,"B",DA,"")))
SET PSOZ1=$ORDER(^PS(52.5,"B",DA,""))
Begin DoDot:1
+53 IF $PIECE($GET(^PS(52.5,PSOZ1,0)),"^",7)="Q"!($PIECE($GET(^(0)),"^",7)="L")
Begin DoDot:2
+54 WRITE !!,"A partial entered for this Rx cannot be suspended."
+55 WRITE !,"A fill for this Rx is already suspended for CMOP transmission."
+56 WRITE !,"You may pull this fill from suspense or enter a partial and print the label.",!!
End DoDot:2
End DoDot:1
+57 ;..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)!$DATA(^PSRX(DA,"P",Z1,0)))
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
+4 ; BNT PSO*7*385 Add audit log entry for TRICARE or CHAMPVA RX
+5 NEW RXJST
+6 IF PSOTRIC!PSOELIG
Begin DoDot:1
+7 IF PSOTRIC
SET RXJST=$SELECT(PSOTRIC=1:"TRICARE",PSOTRIC=2:"CHAMPVA",1:"")_" Partial Fill"
+8 IF PSOELIG
SET RXJST=$SELECT(PSOELIG=1:"TRICARE",PSOELIG=2:"CHAMPVA",1:"")_" Partial Fill"
+9 DO AUDIT^PSOTRI(RXN,RXF,,RXJST,"P",$SELECT(PSOTRIC=1:"T",PSOELIG=1:"T",1:"C"))
End DoDot:1
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
CS(LINEITEM) ; controlled substance check
+1 ; Input: LINEITEM - the line item that was selected from the list of active Rx's
+2 ; off the Medication Profile screen rendered using PSO LM BACKDOOR ORDERS
+3 ;Output: $$CS - 1:YES / 0:NO
+4 NEW RXIEN,DRGIEN,CSVAL
+5 SET RXIEN=$PIECE(LINEITEM,"^",2)
+6 SET DRGIEN=$$GET1^DIQ(52,RXIEN,6,"I")
IF 'DRGIEN
QUIT 0
+7 SET CSVAL=$$GET1^DIQ(50,DRGIEN,3)
+8 IF CSVAL
IF CSVAL>0
IF CSVAL<6
QUIT 1
+9 QUIT 0
