PSOSULBL.m

PSOSULBL ;BHAM ISC/RTR,SAB - Print Suspended labels ;SEP 30, 2020@13:11

 ;;7.0;OUTPATIENT PHARMACY;**139,173,174,148,200,260,264,287,289,290,354,421,370,427,466,539,452,627,562,694,681,753**;DEC 1997;Build 53

 ; Reference to ^PS(55 in ICR #2228

 ; Reference to SAVNDC^PSSNDCUT in ICR #4707

 ; Reference to $$ECETREJ^PSXRPPL2 in ICR #7352

 ;

 ;*694 - add check for each local Rx# for CS vs NON-CS per appropriate new DAYS params in file #59

 ;

 K PDUZ,REPRINT G ^PSOSULB1

BEG ;

 K PSORUNIN,PSORETRY N BPSCNT

 S PSORUNIN="^XTMP(""PSOSUSP"")"

 L +@PSORUNIN:10 I '$T D

 . F PSORETRY=1:1:120 L +@PSORUNIN:60 I $T Q  ;wait Max of 2 hrs before continue

 . Q

 K ^UTILITY($J,"PSOPRO"),^TMP("PSOSBAI",$J)

 S PSOSEQ=1 F DFN=0:0 S DFN=$O(^PS(52.5,"AC",DFN)) Q:'DFN  D

 . S (PSOSFLAG,DEAD)=0

 . F ZZ=0:0 S ZZ=$O(^PS(52.5,"AC",DFN,ZZ)) Q:'ZZ!$G(PSOSFLAG)  D

 . . I ZZ'>PRTDT S PSOSFLAG=1

 . D:'$G(PSRT) PID^VADPT6 D CHKDEAD I $G(DEAD) Q

 . I $G(PSOSFLAG) D PRT

 D PPL

 D:$D(^UTILITY($J,"PSOPRO"))&($P(PSOPAR,"^",8)) PROF

 G EXIT

PRT F SDT=0:0 S SDT=$O(^PS(52.5,"AC",DFN,SDT)) D:SDT TMP Q:'SDT    ;*694 move date check to tmp tag

 Q

EXIT ;

 I $D(^TMP("PSOSBAI",$J)) D CHKMAIL

 K ^TMP($J),^TMP("PSOSBAI",$J)

 I $D(PSORUNIN) L -@PSORUNIN

 D ^%ZISC

 K %,%ZIS,CNT,COM,DA,DEAD,DFN,DIRUT,DTTM,G,HDPPL,JJ,JJJ,JJJJ,PDUZ,IOP,ORD,PFIOQ,PSLION,PSRT,POP,PRF,PRTDT,PSLIO,PSNP,PSODBQ,PSOSEQ,PSOSFLAG,PSOSU,PSOTIME,PSOOUT,PSOPRFLG,PSOSEQ,PSOSUSPR,PSSPND,PST,PTL,PPLHLD,PSFNIEN,ZTSK,PSOOK,PSOSULST

 K PSOBADDR,PSORUNIN,PSORETRY,PSRTONE,PSSRT,PSUSDEA,RF,RFCNT,RX,RXDFN,SDT,SFN,SREC,STOP,SUSPT,VADM,VAPA,X,X1,X2,XAK,XDATE,Y,Z,ZZ,WWW,PSDDDATE,SINRX,RXPR,RXPR1,GGGG,XXX,ZII,ZTDESC,ZTRTN,ZTSAVE,RRRR,RXRP,RXRP1,RXFL,SPR S:$D(ZTQUEUED) ZTREQ="@" Q

 Q

TMP F SFN=0:0 S SFN=$O(^PS(52.5,"AC",DFN,SDT,SFN)) Q:'SFN  D

 . Q:SDT>$$FMADD^XLFDT(PRTDT,$$SUSPDAYS^PSOUTLA2(SFN))      ;*694 check per each Rx CS vs Non-CS param value.  (Quit if Sus dt > Prt thru dt + pull ahead days param)

 . I '$D(^PS(52.5,SFN,0))!'$D(^DPT(+DFN,0)) K ^PS(52.5,"AC",DFN,SDT,SFN) Q

 . I $D(PSOSULST) N PSOOK D EN^PSOSUCAT Q:'PSOOK

 . N RXSITE,PRINTED,PSDFN,RXSTS,RXIEN,RXFILL,PARTIAL,RXEXPDT,RESP,DSHLD,ESTATUS

 . S RXIEN=+$$GET1^DIQ(52.5,SFN,.01,"I"),RXDFN=$$GET1^DIQ(52,RXIEN,2,"I")

 . S RXSTS=$$GET1^DIQ(52,RXIEN,100,"I"),RXSITE=+$$GET1^DIQ(52.5,SFN,.06,"I"),PRINTED=+$$GET1^DIQ(52.5,SFN,2,"I")

 . S PARTIAL=+$$GET1^DIQ(52.5,SFN,.05,"I"),RXEXPDT=$$GET1^DIQ(52,RXIEN,26,"I")

 . S RXFILL=$$GET1^DIQ(52.5,SFN,9,"I") I RXFILL="" S RXFILL=$$LSTRFL^PSOBPSU1(RXIEN)

 . I RXSITE=$G(PSOSITE),'PRINTED,RXDFN=DFN,RXSTS<9 D

 . . I PARTIAL,'$D(^PSRX(RXIEN,"P",PARTIAL)) Q

 . . ; If already printed and the REPRINT flag is not set, remove from queue and quit

 . . ; Line below commented out due to patient safety issue

 . . ; Refer to PSO*7.0*466

 . . ;I $$PRINTED(SFN,RXIEN,RXFILL)=1 D REMOVE(SFN,RXIEN,RXFILL,.5,"","") Q  

 . . I RXEXPDT<DT,RXSTS<11 D  Q

 . . . N RXREC S RXREC=RXIEN D EX^PSOSUTL

 . . . K DIE,DA S DIE=52,DA=RXIEN,DR="100///11" D ^DIE K DIE,DA

 . . . K DIK,DA S DA=SFN,DIK="^PS(52.5," D ^DIK K DIK,DA

 . . S PSOBADDR=0 D CHKBAI I PSOBADDR Q

 . . I PSRT="D" D

 . . . S PSSRT=$S($G(PSRTONE)="I":VA("PID"),1:$P(^DPT(DFN,0),"^")_$P(^(0),"^",9))

 . . . S PSUSDEA=$P($G(^PS(52.5,SFN,0)),"^",10)

 . . . S SRT=$S(PSUSDEA["A"!(PSUSDEA["C"):"A-"_PSSRT,PSUSDEA["S":"S-"_PSSRT,1:"Z-"_PSSRT)

 . . I PSRT'="D" D

 . . . S SRT=$S(PSRT:$P(^DPT(DFN,0),"^")_$P(^(0),"^",9),1:VA("PID"))

 . . ; - If not partial fill, sending Rx to ECME for 3rd Party billing

 . . I 'PARTIAL,$$RETRX^PSOBPSUT(RXIEN,RXFILL),SDT>DT Q

 . . S ESTATUS=$$STATUS^PSOBPSUT(RXIEN,RXFILL)

 . . ; Skip this one if it has an open/unresolved eT/eC reject.

 . . I $$TRIC^PSOREJP1(RXIEN,RXFILL),$$ECETREJ^PSXRPPL2(RXIEN) Q

 . . I 'PARTIAL,ESTATUS'="",ESTATUS'["PAYABLE",'$$ECMESTAT^PSOBPSU2(RXIEN,RXFILL) Q  ;check for existing epharmacy reject codes

 . . I 'PARTIAL,RXFILL>0,$$STATUS^PSOBPSUT(RXIEN,RXFILL-1)'="" S DSHLD=$$DSH^PSOSULB1(SFN) Q:'DSHLD  ;epharmacy-3/4 days supply (refill)

 . . I 'PARTIAL,RXFILL=0 S DSHLD=$$DSH^PSOSULB1(SFN) Q:'DSHLD  ;epharmacy-3/4 days supply (original fill)

 . . I 'PARTIAL,$$FIND^PSOREJUT(RXIEN,RXFILL,,"79,88,943",,1) Q  ;check for DUR/RTS/RRR (again as it is done in ECMESTAT above)

 . . I 'PARTIAL,($$RETRX^PSOBPSUT(RXIEN,RXFILL)!$$ECMEST2^PSOBPSU2(RXIEN,RXFILL)) D  Q:$$TRISTA^PSOREJU3(RXIEN,RXFILL,.RESP,"PL")

 . . . D ECMESND^PSOBPSU1(RXIEN,RXFILL,,"PL",,,,,,.RESP)

 . . . I $D(RESP),'RESP S BPSCNT=$G(BPSCNT)+1

 . . S ^TMP($J,SRT,SFN)=RXIEN

 Q

PPL ; Wait some time before printing so response from 3rd party payers can be received

 I $G(BPSCNT)>0 H 60+$S((BPSCNT*15)>7200:7200,1:(BPSCNT*15))

 K PPL,PPL1 S ORD="" F  S ORD=$O(^TMP($J,ORD)) Q:ORD=""  D PPL1

 Q

PPL1 ; Printing Labels

 N PARTIAL,REPRINT,REFILL,RXFL,Z,QUIT,ESTAT

 S (PSOPRFLG,SUSPT)=1 S:$D(PSOPROP) PFIO=PSOPROP

 S:'$D(PDUZ) PDUZ=DUZ K RXPR,RXPR1,PPL

 F SFN=0:0 S SFN=$O(^TMP($J,ORD,SFN)) Q:'SFN  D

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

 .; RXFL(SINRX) is related to downstream outpatient dispensing robots

 .; such as Optifill or ScriptPro

 .S Z=$G(^PS(52.5,SFN,0)),SINRX=+$P(Z,"^"),(REFILL,RXFL(SINRX))=+$P(Z,"^",13)

 .S PARTIAL=$P(Z,"^",5),REPRINT=$P(Z,"^",12)

 .; - Screening out OPEN/UNRESOLVED Rejects (3rd Party Payer) 

 .S QUIT=0

 .I 'PARTIAL,'REPRINT D  I QUIT Q

 ..I $$FIND^PSOREJUT(SINRX,REFILL,,"79,88,943",,1) S QUIT=1 Q

 ..S ESTAT=$$STATUS^PSOBPSUT(SINRX,REFILL)

 ..I ESTAT'="E PAYABLE",'$$ECMESTAT^PSOBPSU2(SINRX,REFILL) S QUIT=1 Q  ;host reject

 ..I ESTAT="E PAYABLE" D

 ...D SAVNDC^PSSNDCUT(+$$GET1^DIQ(52,SINRX,6,"I"),$$RXSITE^PSOBPSUT(SINRX,REFILL),$$GETNDC^PSONDCUT(SINRX,REFILL))

 .; 

 .I $L($G(PPL))<240 D

 ..S PPL=$P(^TMP($J,ORD,SFN),"^")_","_$G(PPL),RXPR(SINRX)=$P(^PS(52.5,SFN,0),"^",5)

 ..S:$P(^PS(52.5,SFN,0),"^",12) RXRP(SINRX)=1

 .E  D

 ..S PPL1=$P(^TMP($J,ORD,SFN),"^")_","_$G(PPL1),RXPR1(SINRX)=$P(^PS(52.5,SFN,0),"^",5)

 ..S:$P(^PS(52.5,SFN,0),"^",12) RXRP1(SINRX)=1

 .S DFN=$P(^PS(52.5,SFN,0),"^",3)

 .I $P(PSOPAR,"^",8),'$D(^PSRX($P(^PS(52.5,SFN,0),"^"),1)),'$G(RXPR(SINRX)),'$G(RXPR1(SINRX)) S PSOPRFLG=0

 S PSNP=$S($P(PSOPAR,"^",8):1,1:0)

 I $G(PPL) D

 .S PPLHLD=$G(PPL1),HDPPL=PPL K PPL1 S (PSODBQ,PSOSUSPR)=1

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

 I $G(PPL) S ZTIO=$G(PSLION) D DQ^PSOLBL,SEQ D:'$G(PSOPRFLG) 

 .I $G(PSOPROP)'=$G(PSLION) S ^UTILITY($J,"PSOPRO",DFN)="" Q

 .D DQ^PSOPRFSS

 I $G(PPLHLD) K RXPR S (PPL,HDPPL)=PPLHLD,(PSODBQ,PSOSUSPR)=1,PSNP=0 S:'$D(PDUZ) PDUZ=DUZ F XXX=0:0 S XXX=$O(RXPR1(XXX)) Q:'XXX  S:$G(RXPR1(XXX)) RXPR(XXX)=RXPR1(XXX)

 I $G(PPLHLD) F RRRR=0:0 S RRRR=$O(RXRP1(RRRR)) Q:'RRRR  S:$D(RXRP1(RRRR)) RXRP(RRRR)=1

 I $G(PPLHLD) S ZTIO=$G(PSLION) D DQ^PSOLBL,SEQ D:'$G(PSOPRFLG)

 .I $G(PSOPROP)'=$G(PSLION) S ^UTILITY($J,"PSOPRO",DFN)="" Q

 .D DQ^PSOPRFSS

 K PPL,PPL1,PPLHLD,RXPR,RXPR1,RXFL Q

SEQ ;

 S SQCOUNT=0 F JJJ=1:1:$L(HDPPL) S:$E(HDPPL,JJJ)="," SQCOUNT=SQCOUNT+1

 F JJJJ=1:1:SQCOUNT S PSFNIEN=$P(HDPPL,",",JJJJ) D:PSFNIEN

 .S PSFNIEN=$O(^PS(52.5,"B",PSFNIEN,0)) I PSFNIEN D

 ..S $P(^PS(52.5,PSFNIEN,0),"^",11)=PSOSEQ,PSOSEQ=PSOSEQ+1 S:$P(^PS(52.5,PSFNIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",6)) ^PS(52.5,"AS",$P(^PS(52.5,PSFNIEN,0),"^",8),$P(^(0),"^",9),$P(^(0),"^",6),$P(^(0),"^",11),PSFNIEN)=""

 Q

CHKDEAD D DEM^VADPT I VADM(1)="" S DEAD=0 Q

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

 S PSDDDATE=$P(VADM(6),"^",2) F WWW=0:0 S WWW=$O(^PS(55,DFN,"P",WWW)) Q:'WWW  I $D(^PS(55,DFN,"P",WWW,0)),$P($G(^(0)),"^") S (DA,RXREC)=$P(^(0),"^") S SFN=$O(^PS(52.5,"B",RXREC,0)) I SFN,$D(^PS(52.5,SFN,0)) S RX=$P(^(0),"^") D DEAD

 Q

DEAD S $P(^PSRX(RX,"STA"),"^")=12,COM="Died ("_$G(PSDDDATE)_")",DA(1)=RX

 S DEAD=1 D ARECD^PSOSUTL S DIK="^PS(52.5,",DA=SFN D ^DIK K DIK

 Q

PROF ;

 S ZTRTN="PRPROF^PSOSULBL",ZTDESC="PRINT PROFILES FROM SUSPENSE",ZTDTH=$H,ZTIO=PSOPROP

 S ZTSAVE("^UTILITY($J,""PSOPRO"",")="",ZTSAVE("PSOPAR")="",ZTSAVE("PSODTCUT")="",ZTSAVE("PSOSITE")="",ZTSAVE("PSOPRPAS")="" D ^%ZTLOAD Q

PRPROF ;

 F LLL=0:0 S LLL=$O(^UTILITY($J,"PSOPRO",LLL)) Q:'LLL  I $D(^DPT(LLL,0)) S DFN=LLL D DQ^PSOPRFSS

 K PSOPAR,PSODTCUT,PSOSITE,PSOPRPAS,LLL,DFN,^UTILITY($J,"PSOPRO") D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"

 Q

 ;

CHKBAI ; IF BAD ADDRESS INDICATOR, NO ACTIVE TEMPORARY ADDRESS AND ROUTING OF MAIL, DO NOT SEND TO OPAI AND/OR DO NOT PRINT LABEL

 N PSOBADR,ACTSEQ,XX,PSOFIRST,ACTTYPE

 I '$G(RXFILL),$P(^PSRX(RXIEN,0),"^",11)="W" Q

 I $P($G(^PSRX(RXIEN,1,RXFILL,0)),"^",2)="W" Q

 S ACTTYPE="BAD ADDRESS INDICATOR"

 S PSOBADR=$$CHKRX^PSOBAI(RXIEN)

 ; GOOD PERMANENT OR TEMPORARY ADDRESS - CHECK FOR DO NOT MAIL

 I PSOBADR,'$P(PSOBADR,"^",2) D SETTMP(ACTTYPE) Q

 S NOMAIL=0 D NOMAIL I NOMAIL Q

 D FOREIGN

 Q

 ;

SETTMP(ACTTYPE) ;

 N ACTSEQ,XX,PSOFIRST,ZZ

 S PSOFIRST=1

 S PSOBADDR=1

 S ACTSEQ=0 F  S ACTSEQ=$O(^PSRX(RXIEN,"A",ACTSEQ)) Q:ACTSEQ=""  D

 .S XX=$G(^PSRX(RXIEN,"A",ACTSEQ,0)) I $P(XX,"^",2)="S" S ZZ=$P(XX,"^",4),ZZ=$S(ZZ<6:ZZ,1:ZZ-1) I ZZ=RXFILL,$P(XX,"^",5)["due to "_ACTTYPE S PSOFIRST=0 Q

 I PSOFIRST D

 .S ^TMP("PSOSBAI",$J,RXIEN,+RXFILL)=ACTTYPE

 .D ACT(ACTTYPE)

 Q

 ;

NOMAIL ; SEE IF FILE 55 STATUS IS DO NOT MAIL

 N ACTTYPE,DFN,MAILST,MAILEXP

 S ACTTYPE="DO NOT MAIL"

 S DFN=+$P($G(^PSRX(RXIEN,0)),"^",2),MAILST=$P($G(^PS(55,DFN,0)),"^",3)

 S MAILEXP=$P(^PS(55,DFN,0),"^",5)

 I $$GET1^DIQ(52,RXIEN,100.2,"I")]"" S MAILST=$$GET1^DIQ(52,RXIEN,100.2,"I"),MAILEXP="" ;p753

 I MAILST'=2 Q

 I MAILEXP=""!(MAILEXP>DT) D SETTMP(ACTTYPE)

 Q

 ;

FOREIGN ;

 N DFN,PSOFORGN

 S DFN=$$GET1^DIQ(52,RXIEN,2,"I")  ;*370

 D ADD^VADPT

 S PSOFORGN=$P($G(VAPA(25)),"^",2) I PSOFORGN'="" D  ; *370

 . N PSON,PSOFOREN S PSOFOREN=1

 . S PSON=$$GET1^DIQ(59,PSOSITE,.01)

 . I PSON'["MANILA",PSOFORGN["UNITED STATES" S PSOFOREN=0

 . I PSON["MANILA",PSOFORGN["PHILIPPINES" S PSOFOREN=0

 . S PSOFORGN=PSOFOREN

 I PSOFORGN D SETTMP("FOREIGN ADDRESS")

 Q

 ;

CHKMAIL ; SEE IF MAILMAN MESSAGE SHOULD BE SENT FOR BAI/MAIL ROUTING

 N RXIEN,RXFILL,ACTSEQ,XX,DFN,SSN,NAME,ACTTYPE,ZZ

 K ^TMP("PSOSM",$J)

 S RXIEN=0 F  S RXIEN=$O(^TMP("PSOSBAI",$J,RXIEN)) Q:'RXIEN  D

 .S RXFILL="" F  S RXFILL=$O(^TMP("PSOSBAI",$J,RXIEN,RXFILL)) Q:RXFILL=""  D

 ..S ACTTYPE=^TMP("PSOSBAI",$J,RXIEN,RXFILL)

 ..S ACTSEQ=0 F  S ACTSEQ=$O(^PSRX(RXIEN,"A",ACTSEQ)) Q:ACTSEQ=""  D

 ...S XX=$G(^PSRX(RXIEN,"A",ACTSEQ,0)) I $P(XX,"^",2)="S" S ZZ=$P(XX,"^",4),ZZ=$S(ZZ<6:ZZ,1:ZZ-1) I ZZ=RXFILL,$P(XX,"^",5)["due to "_ACTTYPE Q

 ...S DFN=$P(^PSRX(RXIEN,0),"^",2),NAME=$P(^DPT(DFN,0),"^"),SSN=$P(^(0),"^",9) I SSN="" S SSN=0

 ...S ^TMP("PSOSM",$J,NAME,SSN,RXIEN,RXFILL)=ACTTYPE

 I $D(^TMP("PSOSM",$J)) D BAIMAIL^PSOSULB1

 K ^TMP("PSOSM",$J)

 Q

 ;

ACT(ACTTYPE) ;adds activity info for rx not printed from suspense/not sent to OPAI

 N NOW,IR,FDA

 D NOW^%DTC S NOW=%

 S IR=0 F FDA=0:0 S FDA=$O(^PSRX(RXIEN,"A",FDA)) Q:'FDA  S IR=FDA

 S IR=IR+1,^PSRX(RXIEN,"A",0)="^52.3DA^"_IR_"^"_IR

 S ^PSRX(RXIEN,"A",IR,0)=NOW_"^"_"S"_"^"_DUZ_"^"_$S(+RXFILL>5:RXFILL+1,1:+RXFILL)_"^"_"RX not printed from suspense due to "_ACTTYPE

 K PSUS,RXF,I,FDA,DIC,DIE,DR,Y,X,%,%I,%H,RSDT

 Q

 ;

PRINTED(SFN,RX,RFL) ;

 ; Check if a label log indicates that a label has already been printed

 ; Input Parameters

 ;    SFN - IEN of RX Suspense file (#52.5)

 ;    RX  - IEN of Prescription file (#50)

 ;    RFL - Refill number

 ; Output

 ;     0 - Label not printed

 ;     1 - Label already printed

 ;     2 - Label already printed and reprint flag is set

 ;

 ; Check parameters

 I '$G(SFN) Q 0

 I '$G(RX) Q 0

 I $G(RFL)="" S RFL=$$LSTRFL^PSOBPSU1(RX)

 ;

 N LBL,PTLBL

 ; Check label log

 S LBL=0,PTLBL=0

 F  S LBL=$O(^PSRX(RX,"L",LBL)) Q:'LBL  D  Q:PTLBL

 . I +$$GET1^DIQ(52.032,LBL_","_RX,1,"I")'=RFL Q

 . I $$GET1^DIQ(52.032,LBL_","_RX,4,"I") Q    ; Warning Label printed

 . I $$GET1^DIQ(52.032,LBL_","_RX,2)["INTERACTION" Q  ; Comment contains "Interaction"

 . S PTLBL=1

 ; If the label log indicates a label was printed and the REPRINT flag is set, change the output to 2

 I PTLBL=1,$$GET1^DIQ(52.5,SFN_",",8,"I") S PTLBL=2

 ; 

 Q PTLBL

 ;

REMOVE(SFN,RX,RFL,USR,DSP,PRTFLG) ;

 ; Remove the RX from the RX Suspense queue (#52.5)

 ; Input Parameters

 ;    SFN - IEN of RX Suspense file (#52.5)

 ;    RX  - IEN of Prescription file (#52)

 ;    RFL - Refill number

 ;    USR - User to enter into the Activity Log

 ;    DSP - Display message

 ;    PRTFLG - 1:Printed,2:Printed and Reprint Flag

 ;

 ; If Reprint flag and display flags are on, display message and quit

 I $G(PRTFLG)=2,$G(DSP)  W !,"Reprint Flag is on.  Prescription left on suspense." H 1 Q

 ;

 ; Check parameters

 I '$G(SFN) Q

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

 I '$G(RX) Q

 I '$D(^PSRX(RX,0)) Q

 I $G(RFL)="" S RFL=$$LSTRFL^PSOBPSU1(RX)

 ;

 N DIK,DA,DIE,DR,DTOUT

 ;

 ; Remove from the suspense queue

 S DIK="^PS(52.5,",DA=SFN D ^DIK

 ;

 ; Update status in the PRESCRIPTION file

 K DIE,DA

 S DIE=52,DA=RX,DR="100///0" D ^DIE

 ; 

 ; Update the Activity Log

 I '$D(USR) S USR=DUZ

 I '$D(^VA(200,+USR,0)) S USR=DUZ

 N X,DIC,DA,DD,DO,DR,DINUM,Y,DLAYGO

 S DA(1)=RX,DIC="^PSRX("_RX_",""A"",",DLAYGO=52.3,DIC(0)="L",X=$$NOW^XLFDT()

 S DIC("DR")=".02///S;.03////"_USR_";.04///"_$S(RFL>5:RFL+1,1:RFL)_";.05///Rx removed from suspense due to previous label print"

 D FILE^DICN

 I $G(DSP) W !,"Prescription has been removed from suspense." H 1

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSOSULBL   13350     printed  Feb 19, 2025@00:01:55                                                                                                                                                                                                   Page 2

PSOSULBL  ;BHAM ISC/RTR,SAB - Print Suspended labels ;SEP 30, 2020@13:11

 +1       ;;7.0;OUTPATIENT PHARMACY;**139,173,174,148,200,260,264,287,289,290,354,421,370,427,466,539,452,627,562,694,681,753**;DEC 1997;Build 53

 +2       ; Reference to ^PS(55 in ICR #2228

 +3       ; Reference to SAVNDC^PSSNDCUT in ICR #4707

 +4       ; Reference to $$ECETREJ^PSXRPPL2 in ICR #7352

 +5       ;

 +6       ;*694 - add check for each local Rx# for CS vs NON-CS per appropriate new DAYS params in file #59

 +7       ;

 +8        KILL PDUZ,REPRINT

           GOTO ^PSOSULB1

BEG       ;

 +1        KILL PSORUNIN,PSORETRY

           NEW BPSCNT

 +2        SET PSORUNIN="^XTMP(""PSOSUSP"")"

 +3        LOCK +@PSORUNIN:10

           IF '$TEST

               Begin DoDot:1

 +4       ;wait Max of 2 hrs before continue

                   FOR PSORETRY=1:1:120

                       LOCK +@PSORUNIN:60

                       IF $TEST

                           QUIT 

 +5                QUIT 

               End DoDot:1

 +6        KILL ^UTILITY($JOB,"PSOPRO"),^TMP("PSOSBAI",$JOB)

 +7        SET PSOSEQ=1

           FOR DFN=0:0

               SET DFN=$ORDER(^PS(52.5,"AC",DFN))

               if 'DFN

                   QUIT 

               Begin DoDot:1

 +8                SET (PSOSFLAG,DEAD)=0

 +9                FOR ZZ=0:0

                       SET ZZ=$ORDER(^PS(52.5,"AC",DFN,ZZ))

                       if 'ZZ!$GET(PSOSFLAG)

                           QUIT 

                       Begin DoDot:2

 +10                       IF ZZ'>PRTDT

                               SET PSOSFLAG=1

                       End DoDot:2

 +11               if '$GET(PSRT)

                       DO PID^VADPT6

                   DO CHKDEAD

                   IF $GET(DEAD)

                       QUIT 

 +12               IF $GET(PSOSFLAG)

                       DO PRT

               End DoDot:1

 +13       DO PPL

 +14       if $DATA(^UTILITY($JOB,"PSOPRO"))&($PIECE(PSOPAR,"^",8))

               DO PROF

 +15       GOTO EXIT

PRT       ;*694 move date check to tmp tag

           FOR SDT=0:0

               SET SDT=$ORDER(^PS(52.5,"AC",DFN,SDT))

               if SDT

                   DO TMP

               if 'SDT

                   QUIT 

 +1        QUIT 

EXIT      ;

 +1        IF $DATA(^TMP("PSOSBAI",$JOB))

               DO CHKMAIL

 +2        KILL ^TMP($JOB),^TMP("PSOSBAI",$JOB)

 +3        IF $DATA(PSORUNIN)

               LOCK -@PSORUNIN

 +4        DO ^%ZISC

 +5        KILL %,%ZIS,CNT,COM,DA,DEAD,DFN,DIRUT,DTTM,G,HDPPL,JJ,JJJ,JJJJ,PDUZ,IOP,ORD,PFIOQ,PSLION,PSRT,POP,PRF,PRTDT,PSLIO,PSNP,PSODBQ,PSOSEQ,PSOSFLAG,PSOSU,PSOTIME,PSOOUT,PSOPRFLG,PSOSEQ,PSOSUSPR,PSSPND,PST,PTL,PPLHLD,PSFNIEN,ZTSK,PSOOK,PSOSULST

 +6        KILL PSOBADDR,PSORUNIN,PSORETRY,PSRTONE,PSSRT,PSUSDEA,RF,RFCNT,RX,RXDFN,SDT,SFN,SREC,STOP,SUSPT,VADM,VAPA,X,X1,X2,XAK,XDATE,Y,Z,ZZ,WWW,PSDDDATE,SINRX,RXPR,RXPR1,GGGG,XXX,ZII,ZTDESC,ZTRTN,ZTSAVE,RRRR,RXRP,RXRP1,RXFL,SPR

           if $DATA(ZTQUEUED)

               SET ZTREQ="@"

           QUIT 

 +7        QUIT 

TMP        FOR SFN=0:0

               SET SFN=$ORDER(^PS(52.5,"AC",DFN,SDT,SFN))

               if 'SFN

                   QUIT 

               Begin DoDot:1

 +1       ;*694 check per each Rx CS vs Non-CS param value.  (Quit if Sus dt > Prt thru dt + pull ahead days param)

                   if SDT>$$FMADD^XLFDT(PRTDT,$$SUSPDAYS^PSOUTLA2(SFN))

                       QUIT 

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

                       KILL ^PS(52.5,"AC",DFN,SDT,SFN)

                       QUIT 

 +3                IF $DATA(PSOSULST)

                       NEW PSOOK

                       DO EN^PSOSUCAT

                       if 'PSOOK

                           QUIT 

 +4                NEW RXSITE,PRINTED,PSDFN,RXSTS,RXIEN,RXFILL,PARTIAL,RXEXPDT,RESP,DSHLD,ESTATUS

 +5                SET RXIEN=+$$GET1^DIQ(52.5,SFN,.01,"I")

                   SET RXDFN=$$GET1^DIQ(52,RXIEN,2,"I")

 +6                SET RXSTS=$$GET1^DIQ(52,RXIEN,100,"I")

                   SET RXSITE=+$$GET1^DIQ(52.5,SFN,.06,"I")

                   SET PRINTED=+$$GET1^DIQ(52.5,SFN,2,"I")

 +7                SET PARTIAL=+$$GET1^DIQ(52.5,SFN,.05,"I")

                   SET RXEXPDT=$$GET1^DIQ(52,RXIEN,26,"I")

 +8                SET RXFILL=$$GET1^DIQ(52.5,SFN,9,"I")

                   IF RXFILL=""

                       SET RXFILL=$$LSTRFL^PSOBPSU1(RXIEN)

 +9                IF RXSITE=$GET(PSOSITE)

                       IF 'PRINTED

                           IF RXDFN=DFN

                               IF RXSTS<9

                                   Begin DoDot:2

 +10                                   IF PARTIAL

                                           IF '$DATA(^PSRX(RXIEN,"P",PARTIAL))

                                               QUIT 

 +11      ; If already printed and the REPRINT flag is not set, remove from queue and quit

 +12      ; Line below commented out due to patient safety issue

 +13      ; Refer to PSO*7.0*466

 +14      ;I $$PRINTED(SFN,RXIEN,RXFILL)=1 D REMOVE(SFN,RXIEN,RXFILL,.5,"","") Q  

 +15                                   IF RXEXPDT<DT

                                           IF RXSTS<11

                                               Begin DoDot:3

 +16                                               NEW RXREC

                                                   SET RXREC=RXIEN

                                                   DO EX^PSOSUTL

 +17                                               KILL DIE,DA

                                                   SET DIE=52

                                                   SET DA=RXIEN

                                                   SET DR="100///11"

                                                   DO ^DIE

                                                   KILL DIE,DA

 +18                                               KILL DIK,DA

                                                   SET DA=SFN

                                                   SET DIK="^PS(52.5,"

                                                   DO ^DIK

                                                   KILL DIK,DA

                                               End DoDot:3

                                               QUIT 

 +19                                   SET PSOBADDR=0

                                       DO CHKBAI

                                       IF PSOBADDR

                                           QUIT 

 +20                                   IF PSRT="D"

                                           Begin DoDot:3

 +21                                           SET PSSRT=$SELECT($GET(PSRTONE)="I":VA("PID"),1:$PIECE(^DPT(DFN,0),"^")_$PIECE(^(0),"^",9))

 +22                                           SET PSUSDEA=$PIECE($GET(^PS(52.5,SFN,0)),"^",10)

 +23                                           SET SRT=$SELECT(PSUSDEA["A"!(PSUSDEA["C"):"A-"_PSSRT,PSUSDEA["S":"S-"_PSSRT,1:"Z-"_PSSRT)

                                           End DoDot:3

 +24                                   IF PSRT'="D"

                                           Begin DoDot:3

 +25                                           SET SRT=$SELECT(PSRT:$PIECE(^DPT(DFN,0),"^")_$PIECE(^(0),"^",9),1:VA("PID"))

                                           End DoDot:3

 +26      ; - If not partial fill, sending Rx to ECME for 3rd Party billing

 +27                                   IF 'PARTIAL

                                           IF $$RETRX^PSOBPSUT(RXIEN,RXFILL)

                                               IF SDT>DT

                                                   QUIT 

 +28                                   SET ESTATUS=$$STATUS^PSOBPSUT(RXIEN,RXFILL)

 +29      ; Skip this one if it has an open/unresolved eT/eC reject.

 +30                                   IF $$TRIC^PSOREJP1(RXIEN,RXFILL)

                                           IF $$ECETREJ^PSXRPPL2(RXIEN)

                                               QUIT 

 +31      ;check for existing epharmacy reject codes

                                       IF 'PARTIAL

                                           IF ESTATUS'=""

                                               IF ESTATUS'["PAYABLE"

                                                   IF '$$ECMESTAT^PSOBPSU2(RXIEN,RXFILL)

                                                       QUIT 

 +32      ;epharmacy-3/4 days supply (refill)

                                       IF 'PARTIAL

                                           IF RXFILL>0

                                               IF $$STATUS^PSOBPSUT(RXIEN,RXFILL-1)'=""

                                                   SET DSHLD=$$DSH^PSOSULB1(SFN)

                                                   if 'DSHLD

                                                       QUIT 

 +33      ;epharmacy-3/4 days supply (original fill)

                                       IF 'PARTIAL

                                           IF RXFILL=0

                                               SET DSHLD=$$DSH^PSOSULB1(SFN)

                                               if 'DSHLD

                                                   QUIT 

 +34      ;check for DUR/RTS/RRR (again as it is done in ECMESTAT above)

                                       IF 'PARTIAL

                                           IF $$FIND^PSOREJUT(RXIEN,RXFILL,,"79,88,943",,1)

                                               QUIT 

 +35                                   IF 'PARTIAL

                                           IF ($$RETRX^PSOBPSUT(RXIEN,RXFILL)!$$ECMEST2^PSOBPSU2(RXIEN,RXFILL))

                                               Begin DoDot:3

 +36                                               DO ECMESND^PSOBPSU1(RXIEN,RXFILL,,"PL",,,,,,.RESP)

 +37                                               IF $DATA(RESP)

                                                       IF 'RESP

                                                           SET BPSCNT=$GET(BPSCNT)+1

                                               End DoDot:3

                                               if $$TRISTA^PSOREJU3(RXIEN,RXFILL,.RESP,"PL")

                                                   QUIT 

 +38                                   SET ^TMP($JOB,SRT,SFN)=RXIEN

                                   End DoDot:2

               End DoDot:1

 +39       QUIT 

PPL       ; Wait some time before printing so response from 3rd party payers can be received

 +1        IF $GET(BPSCNT)>0

               HANG 60+$SELECT((BPSCNT*15)>7200:7200,1:(BPSCNT*15))

 +2        KILL PPL,PPL1

           SET ORD=""

           FOR 

               SET ORD=$ORDER(^TMP($JOB,ORD))

               if ORD=""

                   QUIT 

               DO PPL1

 +3        QUIT 

PPL1      ; Printing Labels

 +1        NEW PARTIAL,REPRINT,REFILL,RXFL,Z,QUIT,ESTAT

 +2        SET (PSOPRFLG,SUSPT)=1

           if $DATA(PSOPROP)

               SET PFIO=PSOPROP

 +3        if '$DATA(PDUZ)

               SET PDUZ=DUZ

           KILL RXPR,RXPR1,PPL

 +4        FOR SFN=0:0

               SET SFN=$ORDER(^TMP($JOB,ORD,SFN))

               if 'SFN

                   QUIT 

               Begin DoDot:1

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

                       QUIT 

 +6       ; RXFL(SINRX) is related to downstream outpatient dispensing robots

 +7       ; such as Optifill or ScriptPro

 +8                SET Z=$GET(^PS(52.5,SFN,0))

                   SET SINRX=+$PIECE(Z,"^")

                   SET (REFILL,RXFL(SINRX))=+$PIECE(Z,"^",13)

 +9                SET PARTIAL=$PIECE(Z,"^",5)

                   SET REPRINT=$PIECE(Z,"^",12)

 +10      ; - Screening out OPEN/UNRESOLVED Rejects (3rd Party Payer) 

 +11               SET QUIT=0

 +12               IF 'PARTIAL

                       IF 'REPRINT

                           Begin DoDot:2

 +13                           IF $$FIND^PSOREJUT(SINRX,REFILL,,"79,88,943",,1)

                                   SET QUIT=1

                                   QUIT 

 +14                           SET ESTAT=$$STATUS^PSOBPSUT(SINRX,REFILL)

 +15      ;host reject

                               IF ESTAT'="E PAYABLE"

                                   IF '$$ECMESTAT^PSOBPSU2(SINRX,REFILL)

                                       SET QUIT=1

                                       QUIT 

 +16                           IF ESTAT="E PAYABLE"

                                   Begin DoDot:3

 +17                                   DO SAVNDC^PSSNDCUT(+$$GET1^DIQ(52,SINRX,6,"I"),$$RXSITE^PSOBPSUT(SINRX,REFILL),$$GETNDC^PSONDCUT(SINRX,REFILL))

                                   End DoDot:3

                           End DoDot:2

                           IF QUIT

                               QUIT 

 +18      ; 

 +19               IF $LENGTH($GET(PPL))<240

                       Begin DoDot:2

 +20                       SET PPL=$PIECE(^TMP($JOB,ORD,SFN),"^")_","_$GET(PPL)

                           SET RXPR(SINRX)=$PIECE(^PS(52.5,SFN,0),"^",5)

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

                               SET RXRP(SINRX)=1

                       End DoDot:2

 +22              IF '$TEST

                       Begin DoDot:2

 +23                       SET PPL1=$PIECE(^TMP($JOB,ORD,SFN),"^")_","_$GET(PPL1)

                           SET RXPR1(SINRX)=$PIECE(^PS(52.5,SFN,0),"^",5)