PSOSUPOE ;BIR/RTR - Suspense pull via Listman ;3/1/96
;;7.0;OUTPATIENT PHARMACY;**8,21,27,34,130,148,281,287,289**;DEC 1997;Build 107
;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
SEL I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
N PSOGETF,PSOGET,PSOGETFN,ORD,ORN,MW,PDUZ,PSLST,PSOSQ,PSOSQRTE,PSOSQMTH,PSPOP,PSOX1,PSOX2,RXLTOP,RXREC,SFN,SORD,SORN,VALMCNT
K DIR,DUOUT,DTOUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!('Y) S VALMSG="Nothing pulled from suspense!",VALMBCK="" Q
S PSLST=Y
SELQ D FULL^VALM1
K DIR S DIR("A")="Select routing for Rx(s)",DIR(0)="S^M:MAIL;W:WINDOW",DIR("B")="WINDOW" D ^DIR K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) G END
S PSOSQRTE=Y I $G(PSOSQRTE)="W",$P(PSOPAR,"^",12) K DIR S DIR(0)="FO^2:60",DIR("A")="METHOD OF PICK-UP" D ^DIR S PSOSQMTH=$G(Y) K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) G END
W ! K DIR S DIR(0)="Y",DIR("A")="Pull Rx(s) and delete from suspense",DIR("B")="YES" D D ^DIR K DIR I Y'=1 G END
.S DIR("?",1)="Enter Yes to pull selected Rx(s) from suspense. Since(Rx(s) pulled early from",DIR("?",2)="suspense are not associated with a printed batch, these Rx(s) cannot be"
.S DIR("?",3)="reprinted from suspense using the 'Reprint batches from suspense' option.",DIR("?")="Therefore, any Rx(s) pulled early from suspense will be deleted from suspense."
Q:$G(PULLONE)
F SORD=1:1:$L(PSLST,",") Q:$P(PSLST,",",SORD)']"" S SORN=$P(PSLST,",",SORD) D:+PSOLST(SORN)=52 BEG
S VALMBCK="R"
I '$G(PSOSQ) S VALMSG="No Rx's pulled from suspense!"
Q
BEG ;
S RXREC=$P(PSOLST(SORN),"^",2)
BEGQ Q:'$D(^PSRX(+$G(RXREC),0))
D PSOL^PSSLOCK(RXREC) I '$G(PSOMSG) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P($G(^PSRX(RXREC,0)),"^")),! K PSOMSG D DIR Q
K PSOMSG I $P($G(^PSRX(RXREC,"STA")),"^")'=5 W !!,"Rx# ",$P(^PSRX(RXREC,0),"^")," is not on Suspense!" D DIR,ULRX Q
S SFN=$O(^PS(52.5,"B",RXREC,0)) I 'SFN D DIR,ULRX Q
S PDUZ=DUZ I +$G(^PS(52.5,SFN,"P")) W !,">>> Rx #",$P(^PSRX(+$P(^(0),"^"),0),"^")," ALREADY PRINTED FROM SUSPENSE.",!,?5,"USE THE REPRINT OPTION TO REPRINT LABEL." D DIR,ULRX Q
I +$P($G(^PSRX(RXREC,2)),"^",6)<DT,+$P($G(^("STA")),"^")<11 D S DIE=52,DA=RXREC,DR="100///11" D ^DIE S DA=SFN,DIK="^PS(52.5," D ^DIK K DIE,DA,DIK W !,"Rx # "_$P(^PSRX(RXREC,0),"^")_" has expired!" D DIR,ULRX Q
.N PSCOU,AAA,VVV,QQQ,PSOPRT,PSOEXPI D EX^PSOSUTL
I $D(RXRP(RXREC)) W !!,"A reprint has already been requested for Rx # ",$P($G(^PSRX(RXREC,0)),"^") D DIR,ULRX Q
I $D(RXPR(RXREC)) W !!,"A partial has already been requested for Rx # ",$P($G(^PSRX(RXREC,0)),"^") D DIR,ULRX Q
S PSPOP=0 I $G(PSODIV),$P($G(^PS(52.5,SFN,0)),"^",6)'=$G(PSOSITE) D CKDIV I $G(PSPOP) D DIR,ULRX Q
S:$P(^PS(52.5,SFN,0),"^",5) RXPR(RXREC)=$P(^(0),"^",5) S:$P(^PS(52.5,SFN,0),"^",12) RXRP(RXREC)=1
S RXFL(RXREC)=$P($G(^PS(52.5,SFN,0)),"^",13),RXRS(RXREC)=$G(PSODFN),RXLTOP=1
S RXRS(RXREC)=$G(RXRS(RXREC))_"^"_$S($P($G(^PS(52.5,SFN,0)),"^",4)="W":"W",1:"M")_"^"_$P($G(^PSRX(RXREC,"MP")),"^") S PSOGET="M" D GETMW
S RXRS(RXREC)=$G(RXRS(RXREC))_"^"_$G(PSOGETF)_"^"_$G(PSOGETFN)_"^"_$S($G(PSOGET)="W":"W",1:"M")
S $P(^PS(52.5,SFN,0),"^",4)=$G(PSOSQRTE) S MW=$G(PSOSQRTE) N RR,RFCNT D MAILS^PSOSUPAT I $D(PSOSQMTH) S $P(^PSRX(RXREC,"MP"),"^")=$G(PSOSQMTH)
S PSOSQ=1
;
; - Submitting Rx to ECME for 3rd Party Billing
I '$D(RXPR(RXREC)) D
. N ACTION,RFL S RFL=$G(RXFL(RXREC)) I RFL="" S RFL=$$LSTRFL^PSOBPSU1(RXREC)
. D ECMESND^PSOBPSU1(RXREC,RFL,,"PP")
. I $$FIND^PSOREJUT(RXREC,RFL) D
. . S ACTION=$$HDLG^PSOREJU1(RXREC,RFL,"79,88","PP","IOQ","Q")
;
D ULRX K PSOGET,PSOGETF
Q
WIND ;
N RRT,RRTT,XXXX,JJJJ,PSINTRX,RTETEST,PSOPSO,SSSS
S PBINGRTE=0,PSINTRX=RXREC
I $G(RXPR(RXREC)) S RTETEST=$P($G(^PSRX(RXREC,"P",RXPR(PSINTRX),0)),"^",2) S:RTETEST="W" PBINGRTE=1 Q
S PSOPSO=0 F SSSS=0:0 S SSSS=$O(^PSRX(PSINTRX,1,SSSS)) Q:'SSSS S PSOPSO=SSSS
I 'PSOPSO S RTETEST=$P($G(^PSRX(PSINTRX,0)),"^",11) S:RTETEST="W" PBINGRTE=1 Q
I PSOPSO S RTETEST=$P($G(^PSRX(PSINTRX,1,PSOPSO,0)),"^",2) S:RTETEST="W" PBINGRTE=1 Q
Q
DIR ;
W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR Q
END S VALMSG="Nothing pulled from suspense!",VALMBCK="R" S:$G(PULLONE)=1 PULLONE=2 Q
ADD ;Add Rx to SPSORX array
I $G(SPSORX("PSOL",1))']"" S SPSORX("PSOL",1)=RXREC_"," Q
F PSOX1=0:0 S PSOX1=$O(SPSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1
I $L(SPSORX("PSOL",PSOX2))+$L(RXREC)<220 S SPSORX("PSOL",PSOX2)=SPSORX("PSOL",PSOX2)_RXREC_"," Q
S SPSORX("PSOL",PSOX2+1)=RXREC_","
Q
BBADD ;
N PSOX1,PSOX2
I $G(BBRX(1))']"" S BBRX(1)=RXREC_"," Q
F PSOX1=0:0 S PSOX1=$O(BBRX(PSOX1)) Q:'PSOX1 S PSOX2=PSOX1
I $L(BBRX(PSOX2))+$L(RXREC)<220 S BBRX(PSOX2)=BBRX(PSOX2)_RXREC_"," Q
S BBRX(PSOX2+1)=RXREC_","
Q
TRIC(PSOTRX) ;
S PSOTRF=$$LSTRFL^PSOBPSU1(PSOTRX)
S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(PSOTRX,PSOTRF,.PSOTRIC)
S ESTAT=$P($$STATUS^PSOBPSUT(PSOTRX,PSOTRF),"^")
I PSOTRIC S EACTION=$S(ESTAT["PAYABLE":1,ESTAT["Inactive ECME Tricare":1,ESTAT="":1,1:0)
Q
PPLADD ;
N SZZ,SPSOX1,SPSOX2,LSFN,PSOTRF,PSOTRIC,PSOTRX,EACTION,ESTAT
I $G(PPL)'="",$E(PPL,$L(PPL))'="," S PPL=PPL_","
F SZZ=0:0 S SZZ=$O(RXRS(SZZ)) Q:'SZZ D
.S LSFN=$O(^PS(52.5,"B",SZZ,0))
.Q:'$G(LSFN)
.Q:$G(^PS(52.5,LSFN,"P"))
.D TRIC(SZZ)
.I $G(PSOTRIC) Q:'$G(EACTION) ;no labels for "In Progress" Tricare Rx's.
.I $G(PPL)="" S PPL=SZZ_"," Q
.I $L(PPL)+$L(SZZ)<220 S PPL=PPL_SZZ_"," Q
.I $G(PSORX("PSOL",2))']"" S PSORX("PSOL",2)=SZZ_"," Q
.F SPSOX1=1:0 S SPSOX1=$O(PSORX("PSOL",SPSOX1)) Q:'SPSOX1 S SPSOX2=SPSOX1
.I $L(PSORX("PSOL",SPSOX2))+$L(SZZ)<220 S PSORX("PSOL",SPSOX2)=PSORX("PSOL",SPSOX2)_SZZ_"," Q
.S PSORX("PSOL",SPSOX2+1)=SZZ_","
Q
CKDIV ;
I '$P($G(PSOSYS),"^",2) W !!?10,"Rx # ",$P(^PSRX(RXREC,0),"^")," is not a valid choice (Different Division)" S PSPOP=1 Q
I $P($G(PSOSYS),"^",3) W !!?10 K DIR S DIR("A")="Rx # "_$P(^PSRX(RXREC,0),"^")_" is from another division. OK to Pull",DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR I $G(DIRUT)!('Y) S PSPOP=1
Q
SELONE ;Pull one Rx through Listman
I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q
N ORD,MW,PDUZ,PSLST,PSOSQ,PSOSQRTE,PSOSQMTH,PSPOP,PSOX1,PSOX2,PULLONE,RXLTOP,RXREC,SFN,SORD,SORN,VALMCNT
S PULLONE=1
I +PSOLST(ORN)'=52 S VALMBCK="" Q
I +PSOLST(ORN)=52,$P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")'=5 S VALMSG="Rx is not on Suspense!",VALMBCK="" Q
I +PSOLST(ORN)=52,$D(RXRS($P(PSOLST(ORN),"^",2))) S VALMSG="Pull early has already been requested!",VALMBCK="" Q
N EHOLDQ,ESIEN,ERXIEN S ERXIEN=$P(PSOLST(ORN),"^",2),ESIEN="",ESIEN=$O(^PS(52.5,"B",ERXIEN,ESIEN))
I $G(ESIEN),$$GET1^DIQ(52.5,ESIEN,10)'="" D EHOLD Q:$G(EHOLDQ)
K EHOLDQ,ESIEN,ERXIEN
D SELQ I $G(PULLONE)=2 S VALMSG="Rx# "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^")_" not pulled from suspense!" Q
I +PSOLST(ORN)=52 S RXREC=$P(PSOLST(ORN),"^",2)
D BEGQ S VALMSG="Rx# "_$P($G(^PSRX(+$G(RXREC),0)),"^")_$S($G(PSOSQ):" pulled",1:" not pulled")_" from Suspense!"
S VALMBCK="R"
Q
RESET ;
N RSDA,RXMW,RXMP,RXSP,RXR,DA,RXPSRX,RXFILL,RXFILLN
F RSDA=0:0 S RSDA=$O(RXRS(RSDA)) Q:'RSDA D
.S RXSP=$O(^PS(52.5,"B",RSDA,0)) Q:'RXSP
.Q:'$D(^PS(52.5,RXSP,0))
.S RXMW=$S($P($G(RXRS(RSDA)),"^",2)="":"M",1:$P($G(RXRS(RSDA)),"^",2)),RXMP=$P($G(RXRS(RSDA)),"^",3),RXFILL=$P($G(RXRS(RSDA)),"^",4),RXFILLN=$P($G(RXRS(RSDA)),"^",5),RXPSRX=$S($P($G(RXRS(RSDA)),"^",6)="":"M",1:$P($G(RXRS(RSDA)),"^",6))
.I RXMW'="" S $P(^PS(52.5,RXSP,0),"^",4)=RXMW D
..I RXFILL="P" D Q
...I $D(^PSRX(RSDA,"P",+$G(RXFILLN),0)) S $P(^PSRX(RSDA,"P",+$G(RXFILLN),0),"^",2)=$G(RXPSRX),$P(^PSRX(RSDA,"MP"),"^")=RXMP
..I RXFILL="R",$G(RXFILLN) S DA(1)=RSDA,DA=RXFILLN,DIE="^PSRX("_DA(1)_",1,",DR="2////"_RXPSRX D ^DIE K DIE
..I RXFILL="O" S DA=RSDA,DIE="^PSRX(",DR="11////"_RXPSRX D ^DIE K DIE
..S $P(^PSRX(RSDA,"MP"),"^")=RXMP
Q
GETMW ;
N GETPAR,GETRX,GETCNT
S PSOGETF="O",PSOGETFN=""
S GETPAR=$P($G(^PS(52.5,SFN,0)),"^",5)
I GETPAR S PSOGET=$P($G(^PSRX(RXREC,"P",GETPAR,0)),"^",2),PSOGETF="P",PSOGETFN=GETPAR Q
I '$O(^PSRX(RXREC,1,0)) S PSOGET=$P($G(^PSRX(RXREC,0)),"^",11) Q
S GETRX=0 F GETCNT=0:0 S GETCNT=$O(^PSRX(RXREC,1,GETCNT)) Q:'GETCNT S GETRX=GETCNT
S PSOGET=$P($G(^PSRX(RXREC,1,+$G(GETRX),0)),"^",2),PSOGETF="R",PSOGETFN=+$G(GETRX)
Q
ULRX ;
I '$G(RXREC) Q
D PSOUL^PSSLOCK(RXREC)
Q
EHOLD ;
Q:'$G(ERXIEN)
Q:$$GET1^DIQ(52,ERXIEN,86)=""
D FULL^VALM1
W !,"This is an ePharmacy billable fill which is Suspended until "_$$GET1^DIQ(52.5,ESIEN,10)_", based"
W !,"on the 3/4 Days rule.",!
K DIR S EHOLDQ=0,DIR(0)="YA",DIR("A")="Do you wish to continue? "
D ^DIR I $D(DIRUT)!('Y) S EHOLDQ=1 K DIR
S VALMSG="No action taken.",VALMBCK="R"
Q
;
PSOSUPOE ;BIR/RTR - Suspense pull via Listman ;3/1/96
+1 ;;7.0;OUTPATIENT PHARMACY;**8,21,27,34,130,148,281,287,289**;DEC 1997;Build 107
+2 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
SEL IF '$GET(PSOCNT)
SET VALMSG="This patient has no Prescriptions!"
SET VALMBCK=""
QUIT
+1 NEW PSOGETF,PSOGET,PSOGETFN,ORD,ORN,MW,PDUZ,PSLST,PSOSQ,PSOSQRTE,PSOSQMTH,PSPOP,PSOX1,PSOX2,RXLTOP,RXREC,SFN,SORD,SORN,VALMCNT
+2 KILL DIR,DUOUT,DTOUT
SET DIR("A")="Select Orders by number"
SET DIR(0)="LO^1:"_PSOCNT
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!('Y)
SET VALMSG="Nothing pulled from suspense!"
SET VALMBCK=""
QUIT
+3 SET PSLST=Y
SELQ DO FULL^VALM1
+1 KILL DIR
SET DIR("A")="Select routing for Rx(s)"
SET DIR(0)="S^M:MAIL;W:WINDOW"
SET DIR("B")="WINDOW"
DO ^DIR
KILL DIR
IF Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
GOTO END
+2 SET PSOSQRTE=Y
IF $GET(PSOSQRTE)="W"
IF $PIECE(PSOPAR,"^",12)
KILL DIR
SET DIR(0)="FO^2:60"
SET DIR("A")="METHOD OF PICK-UP"
DO ^DIR
SET PSOSQMTH=$GET(Y)
KILL DIR
IF Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
GOTO END
+3 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Pull Rx(s) and delete from suspense"
SET DIR("B")="YES"
Begin DoDot:1
+4 SET DIR("?",1)="Enter Yes to pull selected Rx(s) from suspense. Since(Rx(s) pulled early from"
SET DIR("?",2)="suspense are not associated with a printed batch, these Rx(s) cannot be"
+5 SET DIR("?",3)="reprinted from suspense using the 'Reprint batches from suspense' option."
SET DIR("?")="Therefore, any Rx(s) pulled early from suspense will be deleted from suspense."
End DoDot:1
DO ^DIR
KILL DIR
IF Y'=1
GOTO END
+6 IF $GET(PULLONE)
QUIT
+7 FOR SORD=1:1:$LENGTH(PSLST,",")
IF $PIECE(PSLST,",",SORD)']""
QUIT
SET SORN=$PIECE(PSLST,",",SORD)
IF +PSOLST(SORN)=52
DO BEG
+8 SET VALMBCK="R"
+9 IF '$GET(PSOSQ)
SET VALMSG="No Rx's pulled from suspense!"
+10 QUIT
BEG ;
+1 SET RXREC=$PIECE(PSOLST(SORN),"^",2)
BEGQ IF '$DATA(^PSRX(+$GET(RXREC),0))
QUIT
+1 DO PSOL^PSSLOCK(RXREC)
IF '$GET(PSOMSG)
WRITE !!,$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing Rx "_$PIECE($GET(^PSRX(RXREC,0)),"^")),!
KILL PSOMSG
DO DIR
QUIT
+2 KILL PSOMSG
IF $PIECE($GET(^PSRX(RXREC,"STA")),"^")'=5
WRITE !!,"Rx# ",$PIECE(^PSRX(RXREC,0),"^")," is not on Suspense!"
DO DIR
DO ULRX
QUIT
+3 SET SFN=$ORDER(^PS(52.5,"B",RXREC,0))
IF 'SFN
DO DIR
DO ULRX
QUIT
+4 SET PDUZ=DUZ
IF +$GET(^PS(52.5,SFN,"P"))
WRITE !,">>> Rx #",$PIECE(^PSRX(+$PIECE(^(0),"^"),0),"^")," ALREADY PRINTED FROM SUSPENSE.",!,?5,"USE THE REPRINT OPTION TO REPRINT LABEL."
DO DIR
DO ULRX
QUIT
+5 IF +$PIECE($GET(^PSRX(RXREC,2)),"^",6)<DT
IF +$PIECE($GET(^("STA")),"^")<11
Begin DoDot:1
+6 NEW PSCOU,AAA,VVV,QQQ,PSOPRT,PSOEXPI
DO EX^PSOSUTL
End DoDot:1
SET DIE=52
SET DA=RXREC
SET DR="100///11"
DO ^DIE
SET DA=SFN
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIE,DA,DIK
WRITE !,"Rx # "_$PIECE(^PSRX(RXREC,0),"^")_" has expired!"
DO DIR
DO ULRX
QUIT
+7 IF $DATA(RXRP(RXREC))
WRITE !!,"A reprint has already been requested for Rx # ",$PIECE($GET(^PSRX(RXREC,0)),"^")
DO DIR
DO ULRX
QUIT
+8 IF $DATA(RXPR(RXREC))
WRITE !!,"A partial has already been requested for Rx # ",$PIECE($GET(^PSRX(RXREC,0)),"^")
DO DIR
DO ULRX
QUIT
+9 SET PSPOP=0
IF $GET(PSODIV)
IF $PIECE($GET(^PS(52.5,SFN,0)),"^",6)'=$GET(PSOSITE)
DO CKDIV
IF $GET(PSPOP)
DO DIR
DO ULRX
QUIT
+10 IF $PIECE(^PS(52.5,SFN,0),"^",5)
SET RXPR(RXREC)=$PIECE(^(0),"^",5)
IF $PIECE(^PS(52.5,SFN,0),"^",12)
SET RXRP(RXREC)=1
+11 SET RXFL(RXREC)=$PIECE($GET(^PS(52.5,SFN,0)),"^",13)
SET RXRS(RXREC)=$GET(PSODFN)
SET RXLTOP=1
+12 SET RXRS(RXREC)=$GET(RXRS(RXREC))_"^"_$SELECT($PIECE($GET(^PS(52.5,SFN,0)),"^",4)="W":"W",1:"M")_"^"_$PIECE($GET(^PSRX(RXREC,"MP")),"^")
SET PSOGET="M"
DO GETMW
+13 SET RXRS(RXREC)=$GET(RXRS(RXREC))_"^"_$GET(PSOGETF)_"^"_$GET(PSOGETFN)_"^"_$SELECT($GET(PSOGET)="W":"W",1:"M")
+14 SET $PIECE(^PS(52.5,SFN,0),"^",4)=$GET(PSOSQRTE)
SET MW=$GET(PSOSQRTE)
NEW RR,RFCNT
DO MAILS^PSOSUPAT
IF $DATA(PSOSQMTH)
SET $PIECE(^PSRX(RXREC,"MP"),"^")=$GET(PSOSQMTH)
+15 SET PSOSQ=1
+16 ;
+17 ; - Submitting Rx to ECME for 3rd Party Billing
+18 IF '$DATA(RXPR(RXREC))
Begin DoDot:1
+19 NEW ACTION,RFL
SET RFL=$GET(RXFL(RXREC))
IF RFL=""
SET RFL=$$LSTRFL^PSOBPSU1(RXREC)
+20 DO ECMESND^PSOBPSU1(RXREC,RFL,,"PP")
+21 IF $$FIND^PSOREJUT(RXREC,RFL)
Begin DoDot:2
+22 SET ACTION=$$HDLG^PSOREJU1(RXREC,RFL,"79,88","PP","IOQ","Q")
End DoDot:2
End DoDot:1
+23 ;
+24 DO ULRX
KILL PSOGET,PSOGETF
+25 QUIT
WIND ;
+1 NEW RRT,RRTT,XXXX,JJJJ,PSINTRX,RTETEST,PSOPSO,SSSS
+2 SET PBINGRTE=0
SET PSINTRX=RXREC
+3 IF $GET(RXPR(RXREC))
SET RTETEST=$PIECE($GET(^PSRX(RXREC,"P",RXPR(PSINTRX),0)),"^",2)
IF RTETEST="W"
SET PBINGRTE=1
QUIT
+4 SET PSOPSO=0
FOR SSSS=0:0
SET SSSS=$ORDER(^PSRX(PSINTRX,1,SSSS))
IF 'SSSS
QUIT
SET PSOPSO=SSSS
+5 IF 'PSOPSO
SET RTETEST=$PIECE($GET(^PSRX(PSINTRX,0)),"^",11)
IF RTETEST="W"
SET PBINGRTE=1
QUIT
+6 IF PSOPSO
SET RTETEST=$PIECE($GET(^PSRX(PSINTRX,1,PSOPSO,0)),"^",2)
IF RTETEST="W"
SET PBINGRTE=1
QUIT
+7 QUIT
DIR ;
+1 WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR
QUIT
END SET VALMSG="Nothing pulled from suspense!"
SET VALMBCK="R"
IF $GET(PULLONE)=1
SET PULLONE=2
QUIT
ADD ;Add Rx to SPSORX array
+1 IF $GET(SPSORX("PSOL",1))']""
SET SPSORX("PSOL",1)=RXREC_","
QUIT
+2 FOR PSOX1=0:0
SET PSOX1=$ORDER(SPSORX("PSOL",PSOX1))
IF 'PSOX1
QUIT
SET PSOX2=PSOX1
+3 IF $LENGTH(SPSORX("PSOL",PSOX2))+$LENGTH(RXREC)<220
SET SPSORX("PSOL",PSOX2)=SPSORX("PSOL",PSOX2)_RXREC_","
QUIT
+4 SET SPSORX("PSOL",PSOX2+1)=RXREC_","
+5 QUIT
BBADD ;
+1 NEW PSOX1,PSOX2
+2 IF $GET(BBRX(1))']""
SET BBRX(1)=RXREC_","
QUIT
+3 FOR PSOX1=0:0
SET PSOX1=$ORDER(BBRX(PSOX1))
IF 'PSOX1
QUIT
SET PSOX2=PSOX1
+4 IF $LENGTH(BBRX(PSOX2))+$LENGTH(RXREC)<220
SET BBRX(PSOX2)=BBRX(PSOX2)_RXREC_","
QUIT
+5 SET BBRX(PSOX2+1)=RXREC_","
+6 QUIT
TRIC(PSOTRX) ;
+1 SET PSOTRF=$$LSTRFL^PSOBPSU1(PSOTRX)
+2 SET PSOTRIC=""
SET PSOTRIC=$$TRIC^PSOREJP1(PSOTRX,PSOTRF,.PSOTRIC)
+3 SET ESTAT=$PIECE($$STATUS^PSOBPSUT(PSOTRX,PSOTRF),"^")
+4 IF PSOTRIC
SET EACTION=$SELECT(ESTAT["PAYABLE":1,ESTAT["Inactive ECME Tricare":1,ESTAT="":1,1:0)
+5 QUIT
PPLADD ;
+1 NEW SZZ,SPSOX1,SPSOX2,LSFN,PSOTRF,PSOTRIC,PSOTRX,EACTION,ESTAT
+2 IF $GET(PPL)'=""
IF $EXTRACT(PPL,$LENGTH(PPL))'=","
SET PPL=PPL_","
+3 FOR SZZ=0:0
SET SZZ=$ORDER(RXRS(SZZ))
IF 'SZZ
QUIT
Begin DoDot:1
+4 SET LSFN=$ORDER(^PS(52.5,"B",SZZ,0))
+5 IF '$GET(LSFN)
QUIT
+6 IF $GET(^PS(52.5,LSFN,"P"))
QUIT
+7 DO TRIC(SZZ)
+8 ;no labels for "In Progress" Tricare Rx's.
IF $GET(PSOTRIC)
IF '$GET(EACTION)
QUIT
+9 IF $GET(PPL)=""
SET PPL=SZZ_","
QUIT
+10 IF $LENGTH(PPL)+$LENGTH(SZZ)<220
SET PPL=PPL_SZZ_","
QUIT
+11 IF $GET(PSORX("PSOL",2))']""
SET PSORX("PSOL",2)=SZZ_","
QUIT
+12 FOR SPSOX1=1:0
SET SPSOX1=$ORDER(PSORX("PSOL",SPSOX1))
IF 'SPSOX1
QUIT
SET SPSOX2=SPSOX1
+13 IF $LENGTH(PSORX("PSOL",SPSOX2))+$LENGTH(SZZ)<220
SET PSORX("PSOL",SPSOX2)=PSORX("PSOL",SPSOX2)_SZZ_","
QUIT
+14 SET PSORX("PSOL",SPSOX2+1)=SZZ_","
End DoDot:1
+15 QUIT
CKDIV ;
+1 IF '$PIECE($GET(PSOSYS),"^",2)
WRITE !!?10,"Rx # ",$PIECE(^PSRX(RXREC,0),"^")," is not a valid choice (Different Division)"
SET PSPOP=1
QUIT
+2 IF $PIECE($GET(PSOSYS),"^",3)
WRITE !!?10
KILL DIR
SET DIR("A")="Rx # "_$PIECE(^PSRX(RXREC,0),"^")_" is from another division. OK to Pull"
SET DIR(0)="Y"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
IF $GET(DIRUT)!('Y)
SET PSPOP=1
+3 QUIT
SELONE ;Pull one Rx through Listman
+1 IF $GET(PSOBEDT)
WRITE $CHAR(7),$CHAR(7)
SET VALMSG="Invalid Action at this time !"
SET VALMBCK=""
QUIT
+2 NEW ORD,MW,PDUZ,PSLST,PSOSQ,PSOSQRTE,PSOSQMTH,PSPOP,PSOX1,PSOX2,PULLONE,RXLTOP,RXREC,SFN,SORD,SORN,VALMCNT
+3 SET PULLONE=1
+4 IF +PSOLST(ORN)'=52
SET VALMBCK=""
QUIT
+5 IF +PSOLST(ORN)=52
IF $PIECE($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),"STA")),"^")'=5
SET VALMSG="Rx is not on Suspense!"
SET VALMBCK=""
QUIT
+6 IF +PSOLST(ORN)=52
IF $DATA(RXRS($PIECE(PSOLST(ORN),"^",2)))
SET VALMSG="Pull early has already been requested!"
SET VALMBCK=""
QUIT
+7 NEW EHOLDQ,ESIEN,ERXIEN
SET ERXIEN=$PIECE(PSOLST(ORN),"^",2)
SET ESIEN=""
SET ESIEN=$ORDER(^PS(52.5,"B",ERXIEN,ESIEN))
+8 IF $GET(ESIEN)
IF $$GET1^DIQ(52.5,ESIEN,10)'=""
DO EHOLD
IF $GET(EHOLDQ)
QUIT
+9 KILL EHOLDQ,ESIEN,ERXIEN
+10 DO SELQ
IF $GET(PULLONE)=2
SET VALMSG="Rx# "_$PIECE($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),0)),"^")_" not pulled from suspense!"
QUIT
+11 IF +PSOLST(ORN)=52
SET RXREC=$PIECE(PSOLST(ORN),"^",2)
+12 DO BEGQ
SET VALMSG="Rx# "_$PIECE($GET(^PSRX(+$GET(RXREC),0)),"^")_$SELECT($GET(PSOSQ):" pulled",1:" not pulled")_" from Suspense!"
+13 SET VALMBCK="R"
+14 QUIT
RESET ;
+1 NEW RSDA,RXMW,RXMP,RXSP,RXR,DA,RXPSRX,RXFILL,RXFILLN
+2 FOR RSDA=0:0
SET RSDA=$ORDER(RXRS(RSDA))
IF 'RSDA
QUIT
Begin DoDot:1
+3 SET RXSP=$ORDER(^PS(52.5,"B",RSDA,0))
IF 'RXSP
QUIT
+4 IF '$DATA(^PS(52.5,RXSP,0))
QUIT
+5 SET RXMW=$SELECT($PIECE($GET(RXRS(RSDA)),"^",2)="":"M",1:$PIECE($GET(RXRS(RSDA)),"^",2))
SET RXMP=$PIECE($GET(RXRS(RSDA)),"^",3)
SET RXFILL=$PIECE($GET(RXRS(RSDA)),"^",4)
SET RXFILLN=$PIECE($GET(RXRS(RSDA)),"^",5)
SET RXPSRX=$SELECT($PIECE($GET(RXRS(RSDA)),"^",6)="":"M",1:$PIECE($GET(RXRS(RSDA)),"^",6))
+6 IF RXMW'=""
SET $PIECE(^PS(52.5,RXSP,0),"^",4)=RXMW
Begin DoDot:2
+7 IF RXFILL="P"
Begin DoDot:3
+8 IF $DATA(^PSRX(RSDA,"P",+$GET(RXFILLN),0))
SET $PIECE(^PSRX(RSDA,"P",+$GET(RXFILLN),0),"^",2)=$GET(RXPSRX)
SET $PIECE(^PSRX(RSDA,"MP"),"^")=RXMP
End DoDot:3
QUIT
+9 IF RXFILL="R"
IF $GET(RXFILLN)
SET DA(1)=RSDA
SET DA=RXFILLN
SET DIE="^PSRX("_DA(1)_",1,"
SET DR="2////"_RXPSRX
DO ^DIE
KILL DIE
+10 IF RXFILL="O"
SET DA=RSDA
SET DIE="^PSRX("
SET DR="11////"_RXPSRX
DO ^DIE
KILL DIE
+11 SET $PIECE(^PSRX(RSDA,"MP"),"^")=RXMP
End DoDot:2
End DoDot:1
+12 QUIT
GETMW ;
+1 NEW GETPAR,GETRX,GETCNT
+2 SET PSOGETF="O"
SET PSOGETFN=""
+3 SET GETPAR=$PIECE($GET(^PS(52.5,SFN,0)),"^",5)
+4 IF GETPAR
SET PSOGET=$PIECE($GET(^PSRX(RXREC,"P",GETPAR,0)),"^",2)
SET PSOGETF="P"
SET PSOGETFN=GETPAR
QUIT
+5 IF '$ORDER(^PSRX(RXREC,1,0))
SET PSOGET=$PIECE($GET(^PSRX(RXREC,0)),"^",11)
QUIT
+6 SET GETRX=0
FOR GETCNT=0:0
SET GETCNT=$ORDER(^PSRX(RXREC,1,GETCNT))
IF 'GETCNT
QUIT
SET GETRX=GETCNT
+7 SET PSOGET=$PIECE($GET(^PSRX(RXREC,1,+$GET(GETRX),0)),"^",2)
SET PSOGETF="R"
SET PSOGETFN=+$GET(GETRX)
+8 QUIT
ULRX ;
+1 IF '$GET(RXREC)
QUIT
+2 DO PSOUL^PSSLOCK(RXREC)
+3 QUIT
EHOLD ;
+1 IF '$GET(ERXIEN)
QUIT
+2 IF $$GET1^DIQ(52,ERXIEN,86)=""
QUIT
+3 DO FULL^VALM1
+4 WRITE !,"This is an ePharmacy billable fill which is Suspended until "_$$GET1^DIQ(52.5,ESIEN,10)_", based"
+5 WRITE !,"on the 3/4 Days rule.",!
+6 KILL DIR
SET EHOLDQ=0
SET DIR(0)="YA"
SET DIR("A")="Do you wish to continue? "
+7 DO ^DIR
IF $DATA(DIRUT)!('Y)
SET EHOLDQ=1
KILL DIR
+8 SET VALMSG="No action taken."
SET VALMBCK="R"
+9 QUIT
+10 ;
