PSOSUPAT.m

PSOSUPAT ;BIR/RTR - Pull all Rx's from suspense for a patient ;03/01/96

 ;;7.0;OUTPATIENT PHARMACY;**8,130,185,427,544,562**;DEC 1997;Build 19

 ;External reference to ^PS(55 supported by DBIA 2228

 ;External reference to ^PSSLOCK supported by DBIA 2789

PAT N PSOALRX,PSOALRXS,PSOSKIP

 S POP=0 K RXP,RXRR,RXFL,RXRP,RXPR,ASKED,BC,DELCNT,WARN,PSOAL,PSOPROFL,PSOQFLAG,PSOPULL,PSOWIN,PSOWINEN,PPLHOLD,PPLHOLDX

 W ! S DIR("A")="Are you entering the patient name or barcode",DIR(0)="SBO^P:Patient Name;B:Barcode"

 S DIR("?")="Enter P if you are going to enter the patient name. Enter B if you are going to enter or wand the barcode."

 D ^DIR K DIR G:$D(DIRUT) ^PSOSUPRX S BC=Y D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2)

BC S (OUT,POP)=0 I BC="B" W ! S DIR("A")="Enter/wand barcode",DIR(0)="FO^5:20",DIR("?")="Enter or wand a prescription barcode for the patient you wish to pull all Rx's for" D ^DIR K DIR G:$G(DIRUT) PAT S BCNUM=Y D

 .D PSOINST Q:OUT  S RX=$P(BCNUM,"-",2) D:$D(^PSRX(RX,0))

 ..S (DFN,PSODFN)=$P(^PSRX(RX,0),"^",2) W " ",$P($G(^DPT(DFN,0)),"^")

 ..D ICN^PSODPT(DFN)

 .I '$D(^PSRX(RX,0)) W !,$C(7),"NO PRESCRIPTION RECORD FOR THIS BARCODE." S OUT=1

 G:OUT BC

NAM I BC="P" W ! S DIC(0)="AEMZQ",DIC="^DPT(",DIC("S")="I $D(^PS(52.5,""AC"",+Y))!($D(^PS(52.5,""AG"",+Y)))" D ^DIC K DIC G:$D(DTOUT)!($D(DUOUT))!(Y<0) PAT S (DFN,PSODFN)=+Y

 S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD

 ;

 ; PSO*7*427 - DMB - 7/24/2015 - Remove call to QUES^PSOSUPRX so that a ECME reject would not cause the entire process to abort.  TEST/BEG still checks

 ;   for valid data, labels already printed, and locks but does not build PPLHOLD/arrays nor does it call QUES^PSOSPRX. If there still valid Rx's

 ;   to process, then ask Routing, Pickup Method and whether to Pull the Rx's.  After that, we call ECME (but only quit for each

 ;   RX if it fails), then add to PPLHOLD/arrays, and update the Routing/Pickup Method for RX SUSPENSE and the RX.

 S (ASKED,DELCNT,WARN)=0

 F CBD=0:0 S CBD=$O(^PS(55,DFN,"P",CBD)) Q:CBD'>0  D TEST

 I $G(PSOQFLAG) G EXIT

 ;

 ; After the TEST/BEG checks, check if there are any prescription left to process

 I '$D(PSOALRXS) W !!,"There are no prescriptions left to process - exiting!" D PAUSE G EXIT

 ;

 ; Get Routing

 W !

 K DIR,DTOUT S DIR("A")="Select routing for Rx(s)",DIR(0)="S^M:MAIL;W:WINDOW",DIR("B")="WINDOW" D ^DIR S MW=Y

 I Y["^"!($D(DTOUT)) W !!,"Nothing pulled from suspense!" D PAUSE G EXIT

 I MW="W" S SUSROUTE=1

 ;

 ; If Routing is Window and site paramter to ask Method of Pickup, then get Method of Pickup

 I MW="W",$P(PSOPAR,"^",12) K DIR,DTOUT,DUOUT S DIR(0)="52,35" D ^DIR S PSOWIN=1,PSOWINEN=Y I $G(DTOUT)!$G(DUOUT) W !!,"Nothing pulled from suspense!" D PAUSE G EXIT

 ;

 ; Ask to Pull Rx's

 W !!

 K DIR

 S DIR("A")="Pull Rx(s) and delete from suspense",DIR("B")="Y",DIR(0)="Y"

 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."

 D ^DIR

 I Y'=1 W $C(7),!!,"Nothing pulled from suspense!" D PAUSE G EXIT

 ;

 ; Loop through the remaining Rx and process

 S RXREC="" F  S RXREC=$O(PSOALRXS(RXREC)) Q:RXREC=""  D

 . ; Resubmit to ECME if needed and check results

 . N RFL S RFL=$P(PSOALRXS(RXREC),U,1) I RFL="" S RFL=$$LSTRFL^PSOBPSU1(RXREC)

 . ;

 . ; Do not send a claim if the last submission was rejected and

 . ; all rejects have been closed.

 . ;

 . S PSOSKIP=0

 . I $$SEND^PSOBPSU2(RXREC,RFL) D  I PSOSKIP Q

 . . D ECMESND^PSOBPSU1(RXREC,RFL,,"PE")

 . . I $$PSOET^PSOREJP3(RXREC,RFL) S PSOSKIP=1 Q  ; Quit if there is an unresolved TRICARE/CHAMPVA non-billable reject code

 . . N PSOTRIC S PSOTRIC=$$TRIC^PSOREJP1(RXREC,RFL)

 . . I $$FIND^PSOREJUT(RXREC,RFL),$$HDLG^PSOREJU1(RXREC,RFL,"79,88,943","PE","IOQ","I")="Q" S PSOSKIP=1 Q

 . . I $P($G(^PSRX(RXREC,"STA")),"^")=12 S PSOSKIP=1 Q  ;No label if discontinued via Reject Notification screen

 . . Q

 . ;

 . ; Put on queue to be printed

 . S SFN=$P(PSOALRXS(RXREC),U,2)

 . S DA=$P(^PS(52.5,SFN,0),"^"),RXPR(DA)=+$P(^(0),"^",5),RXFL(DA)=$P($G(^(0)),"^",13)

 . I $L($G(PPLHOLD))<240 S PPLHOLD=$S($G(PPLHOLD)="":$P(^PS(52.5,SFN,0),"^"),1:$G(PPLHOLD)_","_+^PS(52.5,SFN,0)) S:$P(^PS(52.5,SFN,0),"^",12) RXRP(DA)=1

 . I $L($G(PPLHOLD))'<240 S PPLHOLDX=$S($G(PPLHOLDX)="":$P(^PS(52.5,SFN,0),"^"),1:$G(PPLHOLDX)_","_+^PS(52.5,SFN,0)) S:$G(RXPR(DA)) RXPR1(DA)=DA_"^"_RXPR(DA) S:$P(^PS(52.5,SFN,0),"^",12) RXRP1(DA)=1 K RXPR(DA)

 . I '$D(^PSRX(RXREC,1)),'$G(RXPR(RXREC)),'$G(RXPR1(RXREC)) S PSOPROFL=1

 . ;

 . ; Save off old Routing/Method of Pickup values

 . 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")

 . ;

 . ; Update Routing and Method of Pickup

 . S $P(^PS(52.5,SFN,0),"^",4)=MW

 . D MAIL

 ;

 ;S HOLDPROF=$G(PSOPROFL) K PSOPROFL

 ;I $D(PSOPART) S (PSOPULL,PSODBQ)=1 F RR=0:0 S RR=$O(PSOPART(RR)) Q:'RR  S PDUZ=DUZ,PPL=RR,RXP=PSOPART(RR) D Q^PSORXL

 ;S PSOPROFL=HOLDPROF I $D(ZTSK),'$G(PPLHOLD) W !!,"LABEL(S) ARE QUEUED TO PRINT",!

 F GGGG=0:0 S GGGG=$O(RXPR(GGGG)) Q:'GGGG  K:'$G(RXPR(GGGG)) RXPR(GGGG)

 K RXP,PPL S PDUZ=DUZ,PSONOPRT=1

 I $G(PPLHOLD)'="" S PPL=PPLHOLD S:$G(SUSROUTE) BBRX(1)=PPL S HOLDPPL=PPL,PSOPULL=1,PSODBQ=1,RXLTOP=1 D WIND^PSOSUPRX D Q^PSORXL I '$G(PSOQFLAG) W !!,"LABEL(S) ARE QUEUED TO PRINT",! S PPL=$P(HOLDPPL,",") D PRF D:'$G(PSOQFLAG)  S PSOQFLAG=0

 .I $P(PSOPAR,"^",8),$G(PSOPROFL) W !!,"PROFILE(S) ARE QUEUED TO PRINT"

 ;call to bingo board

 I $G(PPLHOLDX),'$G(PSOQGLAG),$G(SUSROUTE) S BBRX(2)=PPLHOLDX

 D:$G(BINGRTE)&($D(DISGROUP))&('$G(PSOQFLAG)) ^PSOBING1 K BINGRTE,BBRX

 I $G(PPLHOLDX),'$G(PSOQFLAG) D  S PDUZ=DUZ,PPL=PPLHOLDX,PSNP=0,(PSODBQ,PSOPULL)=1 D Q^PSORXL

 .F XXX=0:0 S XXX=$O(RXPR1(XXX)) Q:'XXX  S RXPR(XXX)=$P(RXPR1(XXX),"^",2)

 .F WWWW=0:0 S WWWW=$O(RXRP1(WWWW)) Q:'WWWW  S:$D(RXRP1(WWWW)) RXRP(WWWW)=1

 I $G(PSOQFLAG) D RESET

EXIT K ACT,BCNUM,CBD,CNT,COM,DA,DEAD,DEL,DELCNT,DFN,DIRUT,DR,DTOUT,DUOUT,DTTM,GG,HOLD,HOLDPPL,OUT,PSOPULL,PSOWIN,PSOWINEN,PSODBQ,PPLHOLD,PPLHOLDX,HOLDPROF,RR,ZZZZ,PSDNAME,PSDDDATE,ZTSK,WWWW,RXRP,RXRP1,PSONOPRT,RXFL,RXRR

 S PSOALRX="" F  S PSOALRX=$O(PSOALRXS(PSOALRX)) Q:PSOALRX=""  D PSOUL^PSSLOCK(PSOALRX)

 K MW,PDUZ,PPL,PRF,PSPOP,PSOPROFL,RF,RFCNT,RX,RXPR,RXPR1,RXREC,SFN,GGGG,STOP,SUB,VADM,WARN,X,Y,Y(0),%,%W,%Y,%Y1,RXLTOP,PSOGET,PSOGETF,PSOGETFN

 Q

 ;

TEST I $D(^PS(55,DFN,"P",CBD,0)) S RXREC=+^(0) I +$P($G(^PSRX(RXREC,"STA")),"^")=5,$D(^PS(52.5,"B",RXREC)) S SFN=+$O(^(RXREC,0)) Q:SFN'>0!($G(PSOQFLAG))!('$D(^PS(52.5,SFN,0)))  S PSPOP=0 D:$G(PSODIV) DIV I 'PSPOP D CHKDEAD Q:DEAD  D BEG

 Q

 ;

CHKDEAD D DEM^VADPT S PSDNAME=$G(VADM(1)) I VADM(1)="" W !?10,"PATIENT NAME UNKNOWN" S DEAD=0 Q

 I VADM(6)="" S DEAD=0 Q

 S PSDDDATE=$P(VADM(6),"^",2) 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 W:'$G(WARN) !!,?10,$G(PSDNAME)," DIED ",$G(PSDDDATE) S WARN=1,DA=HOLD K HOLD,REA

 Q

 ;

DIV I $D(^PS(52.5,SFN,0)),$D(^PSRX(+$P(^PS(52.5,SFN,0),"^"),2)),$P(^PS(52.5,SFN,0),"^",6)'=$G(PSOSITE) S RXREC=+$P(^PS(52.5,SFN,0),"^") D CKDIV

 Q

 ;

CKDIV I '$P($G(PSOSYS),"^",2) W !!?10,$C(7),"Rx # ",$P(^PSRX(RXREC,0),"^")," is not a valid choice. (Different Division)" S PSPOP=1 Q

 I $P($G(PSOSYS),"^",3) W !!?10,$C(7) S DIR("A")="Rx # "_$P(^PSRX(RXREC,0),"^")_" is from another division.  Continue",DIR(0)="Y",DIR("B")="Y" D ^DIR K DIR I $G(DIRUT)!('Y) S PSPOP=1

 Q

 ;

BEG 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 PAUSE Q

 .D EX^PSOSUTL

 I '$D(^PS(52.5,SFN,0)) K PSOAL Q

 I +$G(^PS(52.5,SFN,"P")) W !!,$C(7),">>> Rx #",$P(^PSRX(+$P(^(0),"^"),0),"^")_" has already been printed from suspense.",!,?5,"Use the reprint routine under the rx option to produce a label." D PAUSE Q

 ; PSO*7*427 - 7/24/2015

 ; Check if Label Log indicates a label was already printed. If it does, ask the user if they still

 ; want to print. If they don't, remove from Suspense queue, then quit.

 N PRNTED,REFILL

 S REFILL=$P($G(^PS(52.5,SFN,0)),"^",13)

 S PRNTED=$$PRINTED^PSOSULBL(SFN,RXREC,REFILL)

 I PRNTED N CONT S CONT=$$PRTQUES^PSOSUPRX(RXREC,REFILL) I CONT'=1 D  Q

 . I CONT=0 D REMOVE^PSOSULBL(SFN,RXREC,REFILL,DUZ,1,PRNTED)

 . I CONT=-1 W !,"This prescription will not be pulled but will be left on suspense." D PAUSE

 ;

 S PSOALRX=$P($G(^PS(52.5,SFN,0)),"^") I 'PSOALRX Q

 ;

 ; Check if we can lock the order

 D PSOL^PSSLOCK(PSOALRX) I '$G(PSOMSG) D  D PAUSE K PSOMSG,PSOALRX Q

 .I $P($G(PSOMSG),"^",2)'="" W !!,"Rx: "_$P($G(^PSRX(PSOALRX,0)),"^")_" cannot be pulled from suspense.",!,$P($G(PSOMSG),"^",2),! Q

 .W !!,"Another person is editing Rx "_$P($G(^PSRX(PSOALRX,0)),"^"),!,"It cannot be pulled from suspense.",!

 ;

 ; Set array for Rx's that can still be processed

 S PSOALRXS(PSOALRX)=REFILL_"^"_SFN

 K PSOMSG,PSOALRX

 Q

 ;

PRF I $P(PSOPAR,"^",8),'$D(PRF(DFN)),$G(PSOPROFL) S HOLD=DFN D ^PSOPRF S DFN=HOLD,PRF(DFN)=""

 Q

 ;

PSOINST I '$D(^PSRX(+$P(Y,"-",2),0)) W !!,$C(7),"Non-existent prescription" S OUT=1 Q

 I $P(Y,"-")'=PSOINST W !!,$C(7),"The prescription is not from this institution." S OUT=1 Q

 Q

 ;

 ; Populate RX Suspense and RX with new Routing Code and Pickup Method

MAIL I $D(PSOWINEN),$G(PSOWIN) S ^PSRX(RXREC,"MP")=$S(PSOWINEN'="":PSOWINEN,1:"")

MAILS I $G(RXPR(RXREC)) S DA(1)=RXREC,DA=RXPR(RXREC),DIE="^PSRX("_DA(1)_",""P"",",DR=".02///"_MW D ^DIE K DIE Q

 I $G(RXPR1(RXREC)) S DA(1)=RXREC,DA=$P(RXPR1(RXREC),U,2),DIE="^PSRX("_DA(1)_",""P"",",DR=".02///"_MW D ^DIE K DIE Q

 S RFCNT=0 F RR=0:0 S RR=$O(^PSRX(RXREC,1,RR)) Q:'RR  S RFCNT=RR

 I 'RFCNT S DA=RXREC,DIE=52,DR="11///"_MW D ^DIE

 I RFCNT S DA(1)=RXREC,DA=RFCNT,DIE="^PSRX("_DA(1)_",1,",DR="2///"_MW D ^DIE

 K DIE,RFCNT,RR

 Q

 ;

RESET ;

 ; Reset Mail/Window value for all prescriptions in the RXRR array

 N PRSDA

 F PRSDA=0:0 S PRSDA=$O(RXRR(PRSDA)) Q:'PRSDA  D RESETRX(PRSDA)

 Q

 ;

RESETRX(RX) ;

 ; Reset fields in RX Suspense and Prescription files

 ; Input:

 ;   RX: Prescription IEN

 ;

 I '$G(RX) Q

 N SFN,PRMW,PRMP,PRFILL,PRFILLN,PRPSRX,DIE,DA,DR,DTOUT

 S SFN=$O(^PS(52.5,"B",RX,0))

 I 'SFN Q

 I '$D(^PS(52.5,SFN,0)) Q

 S PRMW=$S($P($G(RXRR(RX)),"^")="":"M",1:$P($G(RXRR(RX)),"^")),PRMP=$P($G(RXRR(RX)),"^",2)

 S PRFILL=$P($G(RXRR(RX)),"^",3),PRFILLN=$P($G(RXRR(RX)),"^",4)

 S PRPSRX=$S($P($G(RXRR(RX)),"^",5)="":"M",1:$P($G(RXRR(RX)),"^",5))

 I PRMW'="" S $P(^PS(52.5,SFN,0),"^",4)=PRMW D

 .I PRFILL="P" D  Q

 ..I $D(^PSRX(RX,"P",+$G(PRFILLN),0)) S $P(^PSRX(RX,"P",+$G(PRFILLN),0),"^",2)=$G(PRPSRX),$P(^PSRX(RX,"MP"),"^")=PRMP

 .I PRFILL="R",$G(PRFILLN) S DA(1)=RX,DA=PRFILLN,DIE="^PSRX("_DA(1)_",1,",DR="2////"_PRPSRX D ^DIE K DIE

 .I PRFILL="O" S DA=RX,DIE="^PSRX(",DR="11////"_PRPSRX D ^DIE K DIE

 .S $P(^PSRX(RX,"MP"),"^")=PRMP

 Q

 ;

PAUSE ;

 W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSOSUPAT   11477     printed  Apr 23, 2025@18:50                                                                                                                                                                                                      Page 2

PSOSUPAT  ;BIR/RTR - Pull all Rx's from suspense for a patient ;03/01/96

 +1       ;;7.0;OUTPATIENT PHARMACY;**8,130,185,427,544,562**;DEC 1997;Build 19

 +2       ;External reference to ^PS(55 supported by DBIA 2228

 +3       ;External reference to ^PSSLOCK supported by DBIA 2789

PAT        NEW PSOALRX,PSOALRXS,PSOSKIP

 +1        SET POP=0

           KILL RXP,RXRR,RXFL,RXRP,RXPR,ASKED,BC,DELCNT,WARN,PSOAL,PSOPROFL,PSOQFLAG,PSOPULL,PSOWIN,PSOWINEN,PPLHOLD,PPLHOLDX

 +2        WRITE !

           SET DIR("A")="Are you entering the patient name or barcode"

           SET DIR(0)="SBO^P:Patient Name;B:Barcode"

 +3        SET DIR("?")="Enter P if you are going to enter the patient name. Enter B if you are going to enter or wand the barcode."

 +4        DO ^DIR

           KILL DIR

           if $DATA(DIRUT)

               GOTO ^PSOSUPRX

           SET BC=Y

           DO NOW^%DTC

           SET TM=$EXTRACT(%,1,12)

           SET TM1=$PIECE(TM,".",2)

BC         SET (OUT,POP)=0

           IF BC="B"

               WRITE !

               SET DIR("A")="Enter/wand barcode"

               SET DIR(0)="FO^5:20"

               SET DIR("?")="Enter or wand a prescription barcode for the patient you wish to pull all Rx's for"

               DO ^DIR

               KILL DIR

               if $GET(DIRUT)

                   GOTO PAT

               SET BCNUM=Y

               Begin DoDot:1

 +1                DO PSOINST

                   if OUT

                       QUIT 

                   SET RX=$PIECE(BCNUM,"-",2)

                   if $DATA(^PSRX(RX,0))

                       Begin DoDot:2

 +2                        SET (DFN,PSODFN)=$PIECE(^PSRX(RX,0),"^",2)

                           WRITE " ",$PIECE($GET(^DPT(DFN,0)),"^")

 +3                        DO ICN^PSODPT(DFN)

                       End DoDot:2

 +4                IF '$DATA(^PSRX(RX,0))

                       WRITE !,$CHAR(7),"NO PRESCRIPTION RECORD FOR THIS BARCODE."

                       SET OUT=1

               End DoDot:1

 +5        if OUT

               GOTO BC

NAM        IF BC="P"

               WRITE !

               SET DIC(0)="AEMZQ"

               SET DIC="^DPT("

               SET DIC("S")="I $D(^PS(52.5,""AC"",+Y))!($D(^PS(52.5,""AG"",+Y)))"

               DO ^DIC

               KILL DIC

               if $DATA(DTOUT)!($DATA(DUOUT))!(Y<0)

                   GOTO PAT

               SET (DFN,PSODFN)=+Y

 +1        SET PSOLOUD=1

           if $PIECE($GET(^PS(55,PSODFN,0)),"^",6)'=2

               DO EN^PSOHLUP(PSODFN)

           KILL PSOLOUD

 +2       ;

 +3       ; PSO*7*427 - DMB - 7/24/2015 - Remove call to QUES^PSOSUPRX so that a ECME reject would not cause the entire process to abort.  TEST/BEG still checks

 +4       ;   for valid data, labels already printed, and locks but does not build PPLHOLD/arrays nor does it call QUES^PSOSPRX. If there still valid Rx's

 +5       ;   to process, then ask Routing, Pickup Method and whether to Pull the Rx's.  After that, we call ECME (but only quit for each

 +6       ;   RX if it fails), then add to PPLHOLD/arrays, and update the Routing/Pickup Method for RX SUSPENSE and the RX.

 +7        SET (ASKED,DELCNT,WARN)=0

 +8        FOR CBD=0:0

               SET CBD=$ORDER(^PS(55,DFN,"P",CBD))

               if CBD'>0

                   QUIT 

               DO TEST

 +9        IF $GET(PSOQFLAG)

               GOTO EXIT

 +10      ;

 +11      ; After the TEST/BEG checks, check if there are any prescription left to process

 +12       IF '$DATA(PSOALRXS)

               WRITE !!,"There are no prescriptions left to process - exiting!"

               DO PAUSE

               GOTO EXIT

 +13      ;

 +14      ; Get Routing

 +15       WRITE !

 +16       KILL DIR,DTOUT

           SET DIR("A")="Select routing for Rx(s)"

           SET DIR(0)="S^M:MAIL;W:WINDOW"

           SET DIR("B")="WINDOW"

           DO ^DIR

           SET MW=Y

 +17       IF Y["^"!($DATA(DTOUT))

               WRITE !!,"Nothing pulled from suspense!"

               DO PAUSE

               GOTO EXIT

 +18       IF MW="W"

               SET SUSROUTE=1

 +19      ;

 +20      ; If Routing is Window and site paramter to ask Method of Pickup, then get Method of Pickup

 +21       IF MW="W"

               IF $PIECE(PSOPAR,"^",12)

                   KILL DIR,DTOUT,DUOUT

                   SET DIR(0)="52,35"

                   DO ^DIR

                   SET PSOWIN=1

                   SET PSOWINEN=Y

                   IF $GET(DTOUT)!$GET(DUOUT)

                       WRITE !!,"Nothing pulled from suspense!"

                       DO PAUSE

                       GOTO EXIT

 +22      ;

 +23      ; Ask to Pull Rx's

 +24       WRITE !!

 +25       KILL DIR

 +26       SET DIR("A")="Pull Rx(s) and delete from suspense"

           SET DIR("B")="Y"

           SET DIR(0)="Y"

 +27       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"

 +28       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."

 +29       DO ^DIR

 +30       IF Y'=1

               WRITE $CHAR(7),!!,"Nothing pulled from suspense!"

               DO PAUSE

               GOTO EXIT

 +31      ;

 +32      ; Loop through the remaining Rx and process

 +33       SET RXREC=""

           FOR 

               SET RXREC=$ORDER(PSOALRXS(RXREC))

               if RXREC=""

                   QUIT 

               Begin DoDot:1

 +34      ; Resubmit to ECME if needed and check results

 +35               NEW RFL

                   SET RFL=$PIECE(PSOALRXS(RXREC),U,1)

                   IF RFL=""

                       SET RFL=$$LSTRFL^PSOBPSU1(RXREC)

 +36      ;

 +37      ; Do not send a claim if the last submission was rejected and

 +38      ; all rejects have been closed.

 +39      ;

 +40               SET PSOSKIP=0

 +41               IF $$SEND^PSOBPSU2(RXREC,RFL)

                       Begin DoDot:2

 +42                       DO ECMESND^PSOBPSU1(RXREC,RFL,,"PE")

 +43      ; Quit if there is an unresolved TRICARE/CHAMPVA non-billable reject code

                           IF $$PSOET^PSOREJP3(RXREC,RFL)

                               SET PSOSKIP=1

                               QUIT 

 +44                       NEW PSOTRIC

                           SET PSOTRIC=$$TRIC^PSOREJP1(RXREC,RFL)

 +45                       IF $$FIND^PSOREJUT(RXREC,RFL)

                               IF $$HDLG^PSOREJU1(RXREC,RFL,"79,88,943","PE","IOQ","I")="Q"

                                   SET PSOSKIP=1

                                   QUIT 

 +46      ;No label if discontinued via Reject Notification screen

                           IF $PIECE($GET(^PSRX(RXREC,"STA")),"^")=12

                               SET PSOSKIP=1

                               QUIT 

 +47                       QUIT 

                       End DoDot:2

                       IF PSOSKIP

                           QUIT 

 +48      ;

 +49      ; Put on queue to be printed

 +50               SET SFN=$PIECE(PSOALRXS(RXREC),U,2)

 +51               SET DA=$PIECE(^PS(52.5,SFN,0),"^")

                   SET RXPR(DA)=+$PIECE(^(0),"^",5)

                   SET RXFL(DA)=$PIECE($GET(^(0)),"^",13)

 +52               IF $LENGTH($GET(PPLHOLD))<240

                       SET PPLHOLD=$SELECT($GET(PPLHOLD)="":$PIECE(^PS(52.5,SFN,0),"^"),1:$GET(PPLHOLD)_","_+^PS(52.5,SFN,0))

                       if $PIECE(^PS(52.5,SFN,0),"^",12)

                           SET RXRP(DA)=1

 +53               IF $LENGTH($GET(PPLHOLD))'<240

                       SET PPLHOLDX=$SELECT($GET(PPLHOLDX)="":$PIECE(^PS(52.5,SFN,0),"^"),1:$GET(PPLHOLDX)_","_+^PS(52.5,SFN,0))

                       if $GET(RXPR(DA))

                           SET RXPR1(DA)=DA_"^"_RXPR(DA)

                       if $PIECE(^PS(52.5,SFN,0),"^",12)

                           SET RXRP1(DA)=1

                       KILL RXPR(DA)

 +54               IF '$DATA(^PSRX(RXREC,1))

                       IF '$GET(RXPR(RXREC))

                           IF '$GET(RXPR1(RXREC))

                               SET PSOPROFL=1

 +55      ;

 +56      ; Save off old Routing/Method of Pickup values

 +57               SET PSOGET="M"

                   DO GETMW^PSOSUPOE

 +58               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")

 +59      ;

 +60      ; Update Routing and Method of Pickup

 +61               SET $PIECE(^PS(52.5,SFN,0),"^",4)=MW

 +62               DO MAIL

               End DoDot:1

 +63      ;

 +64      ;S HOLDPROF=$G(PSOPROFL) K PSOPROFL

 +65      ;I $D(PSOPART) S (PSOPULL,PSODBQ)=1 F RR=0:0 S RR=$O(PSOPART(RR)) Q:'RR  S PDUZ=DUZ,PPL=RR,RXP=PSOPART(RR) D Q^PSORXL

 +66      ;S PSOPROFL=HOLDPROF I $D(ZTSK),'$G(PPLHOLD) W !!,"LABEL(S) ARE QUEUED TO PRINT",!

 +67       FOR GGGG=0:0

               SET GGGG=$ORDER(RXPR(GGGG))

               if 'GGGG

                   QUIT 

               if '$GET(RXPR(GGGG))

                   KILL RXPR(GGGG)

 +68       KILL RXP,PPL

           SET PDUZ=DUZ

           SET PSONOPRT=1

 +69       IF $GET(PPLHOLD)'=""

               SET PPL=PPLHOLD

               if $GET(SUSROUTE)

                   SET BBRX(1)=PPL

               SET HOLDPPL=PPL

               SET PSOPULL=1

               SET PSODBQ=1

               SET RXLTOP=1

               DO WIND^PSOSUPRX

               DO Q^PSORXL

               IF '$GET(PSOQFLAG)

                   WRITE !!,"LABEL(S) ARE QUEUED TO PRINT",!

                   SET PPL=$PIECE(HOLDPPL,",")

                   DO PRF

                   if '$GET(PSOQFLAG)

                       Begin DoDot:1

 +70                       IF $PIECE(PSOPAR,"^",8)

                               IF $GET(PSOPROFL)

                                   WRITE !!,"PROFILE(S) ARE QUEUED TO PRINT"

                       End DoDot:1

                   SET PSOQFLAG=0

 +71      ;call to bingo board

 +72       IF $GET(PPLHOLDX)

               IF '$GET(PSOQGLAG)

                   IF $GET(SUSROUTE)

                       SET BBRX(2)=PPLHOLDX

 +73       if $GET(BINGRTE)&($DATA(DISGROUP))&('$GET(PSOQFLAG))

               DO ^PSOBING1

           KILL BINGRTE,BBRX

 +74       IF $GET(PPLHOLDX)

               IF '$GET(PSOQFLAG)

                   Begin DoDot:1

 +75                   FOR XXX=0:0

                           SET XXX=$ORDER(RXPR1(XXX))

                           if 'XXX

                               QUIT 

                           SET RXPR(XXX)=$PIECE(RXPR1(XXX),"^",2)

 +76                   FOR WWWW=0:0

                           SET WWWW=$ORDER(RXRP1(WWWW))

                           if 'WWWW

                               QUIT 

                           if $DATA(RXRP1(WWWW))

                               SET RXRP(WWWW)=1

                   End DoDot:1

                   SET PDUZ=DUZ

                   SET PPL=PPLHOLDX

                   SET PSNP=0

                   SET (PSODBQ,PSOPULL)=1

                   DO Q^PSORXL

 +77       IF $GET(PSOQFLAG)

               DO RESET

EXIT       KILL ACT,BCNUM,CBD,CNT,COM,DA,DEAD,DEL,DELCNT,DFN,DIRUT,DR,DTOUT,DUOUT,DTTM,GG,HOLD,HOLDPPL,OUT,PSOPULL,PSOWIN,PSOWINEN,PSODBQ,PPLHOLD,PPLHOLDX,HOLDPROF,RR,ZZZZ,PSDNAME,PSDDDATE,ZTSK,WWWW,RXRP,RXRP1,PSONOPRT,RXFL,RXRR

 +1        SET PSOALRX=""

           FOR 

               SET PSOALRX=$ORDER(PSOALRXS(PSOALRX))

               if PSOALRX=""

                   QUIT 

               DO PSOUL^PSSLOCK(PSOALRX)

 +2        KILL MW,PDUZ,PPL,PRF,PSPOP,PSOPROFL,RF,RFCNT,RX,RXPR,RXPR1,RXREC,SFN,GGGG,STOP,SUB,VADM,WARN,X,Y,Y(0),%,%W,%Y,%Y1,RXLTOP,PSOGET,PSOGETF,PSOGETFN

 +3        QUIT 

 +4       ;

TEST       IF $DATA(^PS(55,DFN,"P",CBD,0))

               SET RXREC=+^(0)

               IF +$PIECE($GET(^PSRX(RXREC,"STA")),"^")=5

                   IF $DATA(^PS(52.5,"B",RXREC))

                       SET SFN=+$ORDER(^(RXREC,0))

                       if SFN'>0!($GET(PSOQFLAG))!('$DATA(^PS(52.5,SFN,0)))

                           QUIT 

                       SET PSPOP=0

                       if $GET(PSODIV)

                           DO DIV

                       IF 'PSPOP

                           DO CHKDEAD

                           if DEAD

                               QUIT 

                           DO BEG

 +1        QUIT 

 +2       ;

CHKDEAD    DO DEM^VADPT

           SET PSDNAME=$GET(VADM(1))

           IF VADM(1)=""

               WRITE !?10,"PATIENT NAME UNKNOWN"

               SET DEAD=0

               QUIT 

 +1        IF VADM(6)=""

               SET DEAD=0

               QUIT 

 +2        SET PSDDDATE=$PIECE(VADM(6),"^",2)

           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 

 +4       ;

DEAD       SET HOLD=DA

           SET REA="C"

           SET COM="Died ("_$GET(PSDDDATE)_")"

           SET DA=RXREC

           SET DEAD=1

           DO CAN^PSOCAN

           if '$GET(WARN)

               WRITE !!,?10,$GET(PSDNAME)," DIED ",$GET(PSDDDATE)

           SET WARN=1

           SET DA=HOLD

           KILL HOLD,REA

 +1        QUIT 

 +2       ;

DIV        IF $DATA(^PS(52.5,SFN,0))

               IF $DATA(^PSRX(+$PIECE(^PS(52.5,SFN,0),"^"),2))

                   IF $PIECE(^PS(52.5,SFN,0),"^",6)'=$GET(PSOSITE)

                       SET RXREC=+$PIECE(^PS(52.5,SFN,0),"^")

                       DO CKDIV

 +1        QUIT 

 +2       ;

CKDIV      IF '$PIECE($GET(PSOSYS),"^",2)

               WRITE !!?10,$CHAR(7),"Rx # ",$PIECE(^PSRX(RXREC,0),"^")," is not a valid choice. (Different Division)"

               SET PSPOP=1

               QUIT 

 +1        IF $PIECE($GET(PSOSYS),"^",3)

               WRITE !!?10,$CHAR(7)

               SET DIR("A")="Rx # "_$PIECE(^PSRX(RXREC,0),"^")_" is from another division.  Continue"

               SET DIR(0)="Y"

               SET DIR("B")="Y"

               DO ^DIR

               KILL DIR

               IF $GET(DIRUT)!('Y)

                   SET PSPOP=1

 +2        QUIT 

 +3       ;

BEG        IF $PIECE($GET(^PSRX(RXREC,2)),"^",6)<DT

               IF $PIECE($GET(^("STA")),"^")<11

                   Begin DoDot:1

 +1                    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 PAUSE

                   QUIT 

 +2        IF '$DATA(^PS(52.5,SFN,0))

               KILL PSOAL

               QUIT 

 +3        IF +$GET(^PS(52.5,SFN,"P"))

               WRITE !!,$CHAR(7),">>> Rx #",$PIECE(^PSRX(+$PIECE(^(0),"^"),0),"^")_" has already been printed from suspense.",!,?5,"Use the reprint routine under the rx option to produce a label."