- 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
