PSOSUPRX ;BIR/RTR - Suspense pull early ;3/1/96
;;7.0;OUTPATIENT PHARMACY;**8,36,130,185,148,287**;DEC 1997;Build 77
;External reference to ^PS(55 supported by DBIA 2228
;External reference to ^PSSLOCK supported by DBIA 2789
ST N PSOPLLRX D:'$D(PSOPAR) ^PSOLSET G:'$D(PSOPAR) ST
N SUSROUTE,BBRX S SUSPT=1,PSLION=$G(PSOLAP),PSOQFLAG=0 W !! S DIR("A")="Print a specific Rx # or all Rx's for a patient",DIR(0)="SBO^S:SPECIFIC RX;A:ALL RXs FOR A PATIENT"
S DIR("?",1)="Enter 'S' to print a suspended prescription label early.",DIR("?")="Enter 'A' to print all prescription suspense labels for a patient."
D ^DIR K DIR S SA=Y G:$G(DIRUT)!(Y<0) EXIT I SA="A" D ^PSOSUPAT G EXIT
LU D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) ;setup start time for bingo
K SUSROUTE,BBRX,RXP,RXFL,RXRP,RXPR,RXRR
K PSOPROFL,PSOE,RXP1,RXPR,PRF,PSOWIN,PSOWINEN K RTE S MW="" W ! S DIR("A")="Select SUSPENDED Rx #: ",DIR(0)="FOA",DIR("?")="Enter the Rx # or wand the barcode. For a list of suspense prescriptions, type '??'",DIR("??")="^D LIST^PSOSUPRX"
S POP=0 D ^DIR K DIR G:$D(DIRUT)!('Y) ST S OUT=0 D:Y["-" PSOINST^PSOSUPAT G:OUT LU
S:Y'["-" X=Y S:Y["-" Y=$P(Y,"-",2),X=$P(^PSRX(+Y,0),"^") K Y G:$G(X)="" ST K DIC W ! D S DIC="^PS(52.5,",DIC(0)="ZQE" D ^DIC K DIC,PSOSPINT W ! G:$D(DTOUT)!($D(DUOUT)) ST G LU:Y<0 S RXREC=+Y(0),SFN=+Y
.S PSOSPINT=X S DIC("S")="I $D(^PSRX(+$P(^PS(52.5,+Y,0),""^""),0)),$P($G(^(""STA"")),""^"")=5,$P($G(^(0)),""^"")=PSOSPINT"
S PSOPLLRX=$G(RXREC) I PSOPLLRX D PSOL^PSSLOCK(PSOPLLRX) I '$G(PSOMSG) D K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR K PSOMSG,PSOPLLRX,X,Y G LU
.I $P($G(PSOMSG),"^",2)'="" W !,$P($G(PSOMSG),"^",2),! Q
.W !,"Another person is editing this order.",!
K PSOMSG
S PSOLOUD=1 D:$P($G(^PS(55,$P(Y(0),"^",3),0)),"^",6)'=2 EN^PSOHLUP($P(Y(0),"^",3)) K PSOLOUD
I $G(PSODIV),$P($G(^PS(52.5,SFN,0)),"^",6)'=$G(PSOSITE) S PSPOP=0,PSOSAV=Y,PSOSAVO=Y(0) D CKDIV^PSOSUPAT S Y=PSOSAV,Y(0)=PSOSAVO K PSOSAV,PSOSAVO,PSOPRFLG D:PSPOP UNLK G:PSPOP LU
D CHKDEAD W:DEAD !!,?10,$G(PSDNAME)," DIED ",$G(PSDDDATE) D:'DEAD BEG D:$G(PSOQFLAG) RESET^PSOSUPAT K PSOSPEC,PSOQFLAG,PSOPULL,PSODELE D UNLK G LU
EXIT K ASKED,CBD,CNT,COM,DA,DEAD,DEL,PSODELE,DFN,DIRUT,DR,DTOUT,DUOUT,HOLDDFN,HDSFN,JJ,MW,OLD,OUT,PDUZ,PSODFN,TM,TM1,RXLTOP,RXRR,PSOGET,PSOGETF,PSOGETFN
K PPL,PSOPULL,PSOWIN,PSOWINEN,PRF,PSODBQ,PSPOP,PSOQFLAG,PSOPROFL,PSOSPEC,RF,RFCNT,RTE,RX,RXP1,RXPR,RXREC,SA,SFN,STOP,SUSPT,VADM,ZTSK,RXFL
K X,Y,Z,PSOPRFLG,PSDDDATE,PSDNAME,ZZZZ,RXRP Q
CHKDEAD S (DFN,PSODFN)=+$P(Y(0),"^",3) D DEM^VADPT S PSDNAME=$G(VADM(1)) I VADM(1)="" W !?10,"PATIENT UNKNOWN" S DEAD=0 Q
I VADM(6)="" S DEAD=0 Q
S PSDDDATE=$P(VADM(6),"^",2),(PDUZ,PSOCLC)=DUZ F ZZZZ=0:0 S ZZZZ=$O(^PS(55,DFN,"P",ZZZZ)) Q:'ZZZZ I $D(^PS(55,DFN,"P",ZZZZ,0)),$P($G(^(0)),"^") S (DA,RXREC)=$P(^(0),"^") I $O(^PS(52.5,"B",DA,0)) D DEAD
Q
DEAD S HOLD=DA,REA="C",COM="Died ("_$G(PSDDDATE)_")",DA=RXREC,DEAD=1 D CAN^PSOCAN S DA=HOLD K HOLD,REA Q
BEG S PSOSPEC=1,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.",! 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!" F PSOE=1:1:3 W "." H 1
.D EX^PSOSUTL
I '$D(^PS(52.5,SFN,0)) K PSOE Q
D ICN^PSODPT(+$P(^PSRX(RXREC,0),"^",2))
S RXFL(RXREC)=$P($G(^PS(52.5,SFN,0)),"^",13)
S HDSFN=SFN,(PPL,DA)=RXREC S:$P(^PS(52.5,SFN,0),"^",5) (RXP1,RXPR(RXREC))=$P(^(0),"^",5)
S:$P(^PS(52.5,SFN,0),"^",12) RXRP(RXREC)=1 D QUES Q:$G(PSOQFLAG)
S (PSOPULL,PSODBQ,PSONOPRT)=1,RXLTOP=1 D WIND D Q^PSORXL S PPL=RXREC
I '$G(PSOQFLAG) W !!,"LABEL QUEUED TO PRINT",! K RX
I '$G(PSOQFLAG) D PRF D:'$G(PSOQFLAG) S PSOQFLAG=0
.S:'$G(PSOPROFL) PSOPRFLG=1 W:$G(PSOPROFL) !!,"PROFILE QUEUED TO PRINT"
K PSONOPRT,RXPR,RXP1
S PPL=RXREC
;call to bingo board
S:$G(SUSROUTE) BBRX(1)=PPL
D:$G(BINGRTE)&($D(DISGROUP))&('$G(PSOQFLAG)) ^PSOBING1 K BINGRTE,BBRX
Q
QUES I '$D(RTE) W ! K DIR S DIR("A")="Select routing for Rx(s)",DIR(0)="S^M:MAIL;W:WINDOW",DIR("B")="WINDOW" D ^DIR K DIR S (RTE,MW)=Y I Y["^"!($D(DTOUT)) W !!?5,"Nothing pulled from suspense!",! S PSOQFLAG=1 Q
S PSOGET="M" D GETMW^PSOSUPOE S RXRR(RXREC)=$S($P(^PS(52.5,SFN,0),"^",4)="W":"W",1:"M")_"^"_$P($G(^PSRX(RXREC,"MP")),"^")_"^"_$G(PSOGETF)_"^"_$G(PSOGETFN)_"^"_$S($G(PSOGET)="W":"W",1:"M")
S:$G(MW)="W" SUSROUTE=1 S $P(^PS(52.5,SFN,0),"^",4)=$G(MW) D:$G(MW)="W" Q:$G(PSOQFLAG) D MAIL^PSOSUPAT
.I '$G(PSOWIN),$P(PSOPAR,"^",12) S DA=RXREC,DIE="^PSRX(",DR=35 D ^DIE S:$D(Y)!($D(DTOUT)) PSOQFLAG=1 Q:$G(PSOQFLAG) S PSOWIN=1,PSOWINEN=$P($G(^PSRX(RXREC,"MP")),"^") Q
I '$D(PSODELE)!($G(PSOSPEC)) W !! S DIR("A")="Pull Rx(s) and delete from suspense",DIR("B")="Y",DIR(0)="Y" D D ^DIR K DIR S PSODELE=Y I Y'=1 W $C(7),!!?5,"Nothing pulled from suspense!",! S PSOQFLAG=1 K PSODELE Q
.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."
S HDSFN=SFN
;
; - Submitting Rx to ECME for 3rd Party Billing
N RFL S RFL=RXFL(RXREC) I RFL="" S RFL=$$LSTRFL^PSOBPSU1(RXREC)
D ECMESND^PSOBPSU1(RXREC,RFL,,"PE")
N PSOTRIC S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RXREC,RFL,.PSOTRIC)
I $$FIND^PSOREJUT(RXREC,RFL),$$HDLG^PSOREJU1(RXREC,RFL,"79,88","PE","IOQ","I")="Q" S:'PSOTRIC PSOQFLAG=1 Q
;
Q
PRF S:'$D(DFN) DFN=+$P(^PS(52.5,SFN,0),"^",3) I $P(PSOPAR,"^",8),'$D(^PSRX(RXREC,1)),'$D(PRF(DFN)),'$G(RXP1) S PSOPROFL=1,HOLDDFN=DFN D ^PSOPRF S DFN=HOLDDFN K HOLDDFN S PRF(DFN)=""
Q
LIST S X="?",DIC("S")="I $D(^PSRX(+$P(^PS(52.5,+Y,0),""^""),0)),$P($G(^(""STA"")),""^"")=5",DIC="^PS(52.5,",DIC(0)="ZQ" D ^DIC K DIC W ! Q:Y<0!($D(DTOUT)) Q
NEXT S PSOX("IRXN")=RX D NEXT^PSOUTIL(.PSOX) S NEXT=$P(PSOX("RX3"),"^",2)
S DA=RX,DIE=52,DR="102///"_NEXT D ^DIE K DIE Q:$D(DTOUT)!($D(DUOUT))
K NEXT,PSOX Q
WIND ;
N RRT,RRTT,XXXX,JJJJ,PSINTRX,RTETEST,PSOPSO,SSSS
S BINGRTE=0
S RRT=1 F XXXX=1:1:$L(PPL) S RRTT=$E(PPL,XXXX) I RRTT="," S RRT=RRT+1
F JJJJ=1:1:RRT Q:$G(BINGRTE) S PSINTRX=$P(PPL,",",JJJJ) I $D(^PSRX(+PSINTRX,0)) D
.I $G(RXPR(PSINTRX)) S RTETEST=$P($G(^PSRX(PSINTRX,"P",RXPR(PSINTRX),0)),"^",2) S:RTETEST="W" BINGRTE=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" BINGRTE=1 Q
.I PSOPSO S RTETEST=$P($G(^PSRX(PSINTRX,1,PSOPSO,0)),"^",2) S:RTETEST="W" BINGRTE=1 Q
Q
UNLK ;Unlock prescription
Q:'$G(PSOPLLRX)
D PSOUL^PSSLOCK(PSOPLLRX)
K PSOPLLRX
PSOSUPRX ;BIR/RTR - Suspense pull early ;3/1/96
+1 ;;7.0;OUTPATIENT PHARMACY;**8,36,130,185,148,287**;DEC 1997;Build 77
+2 ;External reference to ^PS(55 supported by DBIA 2228
+3 ;External reference to ^PSSLOCK supported by DBIA 2789
ST NEW PSOPLLRX
IF '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
GOTO ST
+1 NEW SUSROUTE,BBRX
SET SUSPT=1
SET PSLION=$GET(PSOLAP)
SET PSOQFLAG=0
WRITE !!
SET DIR("A")="Print a specific Rx # or all Rx's for a patient"
SET DIR(0)="SBO^S:SPECIFIC RX;A:ALL RXs FOR A PATIENT"
+2 SET DIR("?",1)="Enter 'S' to print a suspended prescription label early."
SET DIR("?")="Enter 'A' to print all prescription suspense labels for a patient."
+3 DO ^DIR
KILL DIR
SET SA=Y
IF $GET(DIRUT)!(Y<0)
GOTO EXIT
IF SA="A"
DO ^PSOSUPAT
GOTO EXIT
LU ;setup start time for bingo
DO NOW^%DTC
SET TM=$EXTRACT(%,1,12)
SET TM1=$PIECE(TM,".",2)
+1 KILL SUSROUTE,BBRX,RXP,RXFL,RXRP,RXPR,RXRR
+2 KILL PSOPROFL,PSOE,RXP1,RXPR,PRF,PSOWIN,PSOWINEN
KILL RTE
SET MW=""
WRITE !
SET DIR("A")="Select SUSPENDED Rx #: "
SET DIR(0)="FOA"
SET DIR("?")="Enter the Rx # or wand the barcode. For a list of suspense prescriptions, type '??'"
SET DIR("??")="^D LIST^PSOSUPRX"
+3 SET POP=0
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!('Y)
GOTO ST
SET OUT=0
IF Y["-"
DO PSOINST^PSOSUPAT
IF OUT
GOTO LU
+4 IF Y'["-"
SET X=Y
IF Y["-"
SET Y=$PIECE(Y,"-",2)
SET X=$PIECE(^PSRX(+Y,0),"^")
KILL Y
IF $GET(X)=""
GOTO ST
KILL DIC
WRITE !
Begin DoDot:1
+5 SET PSOSPINT=X
SET DIC("S")="I $D(^PSRX(+$P(^PS(52.5,+Y,0),""^""),0)),$P($G(^(""STA"")),""^"")=5,$P($G(^(0)),""^"")=PSOSPINT"
End DoDot:1
SET DIC="^PS(52.5,"
SET DIC(0)="ZQE"
DO ^DIC
KILL DIC,PSOSPINT
WRITE !
IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO ST
IF Y<0
GOTO LU
SET RXREC=+Y(0)
SET SFN=+Y
+6 SET PSOPLLRX=$GET(RXREC)
IF PSOPLLRX
DO PSOL^PSSLOCK(PSOPLLRX)
IF '$GET(PSOMSG)
Begin DoDot:1
+7 IF $PIECE($GET(PSOMSG),"^",2)'=""
WRITE !,$PIECE($GET(PSOMSG),"^",2),!
QUIT
+8 WRITE !,"Another person is editing this order.",!
End DoDot:1
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
KILL PSOMSG,PSOPLLRX,X,Y
GOTO LU
+9 KILL PSOMSG
+10 SET PSOLOUD=1
IF $PIECE($GET(^PS(55,$PIECE(Y(0),"^",3),0)),"^",6)'=2
DO EN^PSOHLUP($PIECE(Y(0),"^",3))
KILL PSOLOUD
+11 IF $GET(PSODIV)
IF $PIECE($GET(^PS(52.5,SFN,0)),"^",6)'=$GET(PSOSITE)
SET PSPOP=0
SET PSOSAV=Y
SET PSOSAVO=Y(0)
DO CKDIV^PSOSUPAT
SET Y=PSOSAV
SET Y(0)=PSOSAVO
KILL PSOSAV,PSOSAVO,PSOPRFLG
IF PSPOP
DO UNLK
IF PSPOP
GOTO LU
+12 DO CHKDEAD
IF DEAD
WRITE !!,?10,$GET(PSDNAME)," DIED ",$GET(PSDDDATE)
IF 'DEAD
DO BEG
IF $GET(PSOQFLAG)
DO RESET^PSOSUPAT
KILL PSOSPEC,PSOQFLAG,PSOPULL,PSODELE
DO UNLK
GOTO LU
EXIT KILL ASKED,CBD,CNT,COM,DA,DEAD,DEL,PSODELE,DFN,DIRUT,DR,DTOUT,DUOUT,HOLDDFN,HDSFN,JJ,MW,OLD,OUT,PDUZ,PSODFN,TM,TM1,RXLTOP,RXRR,PSOGET,PSOGETF,PSOGETFN
+1 KILL PPL,PSOPULL,PSOWIN,PSOWINEN,PRF,PSODBQ,PSPOP,PSOQFLAG,PSOPROFL,PSOSPEC,RF,RFCNT,RTE,RX,RXP1,RXPR,RXREC,SA,SFN,STOP,SUSPT,VADM,ZTSK,RXFL
+2 KILL X,Y,Z,PSOPRFLG,PSDDDATE,PSDNAME,ZZZZ,RXRP
QUIT
CHKDEAD SET (DFN,PSODFN)=+$PIECE(Y(0),"^",3)
DO DEM^VADPT
SET PSDNAME=$GET(VADM(1))
IF VADM(1)=""
WRITE !?10,"PATIENT UNKNOWN"
SET DEAD=0
QUIT
+1 IF VADM(6)=""
SET DEAD=0
QUIT
+2 SET PSDDDATE=$PIECE(VADM(6),"^",2)
SET (PDUZ,PSOCLC)=DUZ
FOR ZZZZ=0:0
SET ZZZZ=$ORDER(^PS(55,DFN,"P",ZZZZ))
IF 'ZZZZ
QUIT
IF $DATA(^PS(55,DFN,"P",ZZZZ,0))
IF $PIECE($GET(^(0)),"^")
SET (DA,RXREC)=$PIECE(^(0),"^")
IF $ORDER(^PS(52.5,"B",DA,0))
DO DEAD
+3 QUIT
DEAD SET HOLD=DA
SET REA="C"
SET COM="Died ("_$GET(PSDDDATE)_")"
SET DA=RXREC
SET DEAD=1
DO CAN^PSOCAN
SET DA=HOLD
KILL HOLD,REA
QUIT
BEG SET PSOSPEC=1
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.",!
QUIT
+1 IF +$PIECE($GET(^PSRX(RXREC,2)),"^",6)<DT
IF +$PIECE($GET(^("STA")),"^")<11
Begin DoDot:1
+2 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!"
FOR PSOE=1:1:3
WRITE "."
HANG 1
+3 IF '$DATA(^PS(52.5,SFN,0))
KILL PSOE
QUIT
+4 DO ICN^PSODPT(+$PIECE(^PSRX(RXREC,0),"^",2))
+5 SET RXFL(RXREC)=$PIECE($GET(^PS(52.5,SFN,0)),"^",13)
+6 SET HDSFN=SFN
SET (PPL,DA)=RXREC
IF $PIECE(^PS(52.5,SFN,0),"^",5)
SET (RXP1,RXPR(RXREC))=$PIECE(^(0),"^",5)
+7 IF $PIECE(^PS(52.5,SFN,0),"^",12)
SET RXRP(RXREC)=1
DO QUES
IF $GET(PSOQFLAG)
QUIT
+8 SET (PSOPULL,PSODBQ,PSONOPRT)=1
SET RXLTOP=1
DO WIND
DO Q^PSORXL
SET PPL=RXREC
+9 IF '$GET(PSOQFLAG)
WRITE !!,"LABEL QUEUED TO PRINT",!
KILL RX
+10 IF '$GET(PSOQFLAG)
DO PRF
IF '$GET(PSOQFLAG)
Begin DoDot:1
+11 IF '$GET(PSOPROFL)
SET PSOPRFLG=1
IF $GET(PSOPROFL)
WRITE !!,"PROFILE QUEUED TO PRINT"
End DoDot:1
SET PSOQFLAG=0
+12 KILL PSONOPRT,RXPR,RXP1
+13 SET PPL=RXREC
+14 ;call to bingo board
+15 IF $GET(SUSROUTE)
SET BBRX(1)=PPL
+16 IF $GET(BINGRTE)&($DATA(DISGROUP))&('$GET(PSOQFLAG))
DO ^PSOBING1
KILL BINGRTE,BBRX
+17 QUIT
QUES IF '$DATA(RTE)
WRITE !
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
SET (RTE,MW)=Y
IF Y["^"!($DATA(DTOUT))
WRITE !!?5,"Nothing pulled from suspense!",!
SET PSOQFLAG=1
QUIT
+1 SET PSOGET="M"
DO GETMW^PSOSUPOE
SET RXRR(RXREC)=$SELECT($PIECE(^PS(52.5,SFN,0),"^",4)="W":"W",1:"M")_"^"_$PIECE($GET(^PSRX(RXREC,"MP")),"^")_"^"_$GET(PSOGETF)_"^"_$GET(PSOGETFN)_"^"_$SELECT($GET(PSOGET)="W":"W",1:"M")
+2 IF $GET(MW)="W"
SET SUSROUTE=1
SET $PIECE(^PS(52.5,SFN,0),"^",4)=$GET(MW)
IF $GET(MW)="W"
Begin DoDot:1
+3 IF '$GET(PSOWIN)
IF $PIECE(PSOPAR,"^",12)
SET DA=RXREC
SET DIE="^PSRX("
SET DR=35
DO ^DIE
IF $DATA(Y)!($DATA(DTOUT))
SET PSOQFLAG=1
IF $GET(PSOQFLAG)
QUIT
SET PSOWIN=1
SET PSOWINEN=$PIECE($GET(^PSRX(RXREC,"MP")),"^")
QUIT
End DoDot:1
IF $GET(PSOQFLAG)
QUIT
DO MAIL^PSOSUPAT
+4 IF '$DATA(PSODELE)!($GET(PSOSPEC))
WRITE !!
SET DIR("A")="Pull Rx(s) and delete from suspense"
SET DIR("B")="Y"
SET DIR(0)="Y"
Begin DoDot:1
+5 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"
+6 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
SET PSODELE=Y
IF Y'=1
WRITE $CHAR(7),!!?5,"Nothing pulled from suspense!",!
SET PSOQFLAG=1
KILL PSODELE
QUIT
+7 SET HDSFN=SFN
+8 ;
+9 ; - Submitting Rx to ECME for 3rd Party Billing
+10 NEW RFL
SET RFL=RXFL(RXREC)
IF RFL=""
SET RFL=$$LSTRFL^PSOBPSU1(RXREC)
+11 DO ECMESND^PSOBPSU1(RXREC,RFL,,"PE")
+12 NEW PSOTRIC
SET PSOTRIC=""
SET PSOTRIC=$$TRIC^PSOREJP1(RXREC,RFL,.PSOTRIC)
+13 IF $$FIND^PSOREJUT(RXREC,RFL)
IF $$HDLG^PSOREJU1(RXREC,RFL,"79,88","PE","IOQ","I")="Q"
IF 'PSOTRIC
SET PSOQFLAG=1
QUIT
+14 ;
+15 QUIT
PRF IF '$DATA(DFN)
SET DFN=+$PIECE(^PS(52.5,SFN,0),"^",3)
IF $PIECE(PSOPAR,"^",8)
IF '$DATA(^PSRX(RXREC,1))
IF '$DATA(PRF(DFN))
IF '$GET(RXP1)
SET PSOPROFL=1
SET HOLDDFN=DFN
DO ^PSOPRF
SET DFN=HOLDDFN
KILL HOLDDFN
SET PRF(DFN)=""
+1 QUIT
LIST SET X="?"
SET DIC("S")="I $D(^PSRX(+$P(^PS(52.5,+Y,0),""^""),0)),$P($G(^(""STA"")),""^"")=5"
SET DIC="^PS(52.5,"
SET DIC(0)="ZQ"
DO ^DIC
KILL DIC
WRITE !
IF Y<0!($DATA(DTOUT))
QUIT
QUIT
NEXT SET PSOX("IRXN")=RX
DO NEXT^PSOUTIL(.PSOX)
SET NEXT=$PIECE(PSOX("RX3"),"^",2)
+1 SET DA=RX
SET DIE=52
SET DR="102///"_NEXT
DO ^DIE
KILL DIE
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+2 KILL NEXT,PSOX
QUIT
WIND ;
+1 NEW RRT,RRTT,XXXX,JJJJ,PSINTRX,RTETEST,PSOPSO,SSSS
+2 SET BINGRTE=0
+3 SET RRT=1
FOR XXXX=1:1:$LENGTH(PPL)
SET RRTT=$EXTRACT(PPL,XXXX)
IF RRTT=","
SET RRT=RRT+1
+4 FOR JJJJ=1:1:RRT
IF $GET(BINGRTE)
QUIT
SET PSINTRX=$PIECE(PPL,",",JJJJ)
IF $DATA(^PSRX(+PSINTRX,0))
Begin DoDot:1
+5 IF $GET(RXPR(PSINTRX))
SET RTETEST=$PIECE($GET(^PSRX(PSINTRX,"P",RXPR(PSINTRX),0)),"^",2)
IF RTETEST="W"
SET BINGRTE=1
QUIT
+6 SET PSOPSO=0
FOR SSSS=0:0
SET SSSS=$ORDER(^PSRX(PSINTRX,1,SSSS))
IF 'SSSS
QUIT
SET PSOPSO=SSSS
+7 IF 'PSOPSO
SET RTETEST=$PIECE($GET(^PSRX(PSINTRX,0)),"^",11)
IF RTETEST="W"
SET BINGRTE=1
QUIT
+8 IF PSOPSO
SET RTETEST=$PIECE($GET(^PSRX(PSINTRX,1,PSOPSO,0)),"^",2)
IF RTETEST="W"
SET BINGRTE=1
QUIT
End DoDot:1
+9 QUIT
UNLK ;Unlock prescription
+1 IF '$GET(PSOPLLRX)
QUIT
+2 DO PSOUL^PSSLOCK(PSOPLLRX)
+3 KILL PSOPLLRX
