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 ---[H[J[2J[HPSOSULBL 13350 printed Oct 16, 2024@18:36:08 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)
+24 if $PIECE(^PS(52.5,SFN,0),"^",12)
SET RXRP1(SINRX)=1
End DoDot:2
+25 SET DFN=$PIECE(^PS(52.5,SFN,0),"^",3)
+26 IF $PIECE(PSOPAR,"^",8)
IF '$DATA(^PSRX($PIECE(^PS(52.5,SFN,0),"^"),1))
IF '$GET(RXPR(SINRX))
IF '$GET(RXPR1(SINRX))
SET PSOPRFLG=0
End DoDot:1
+27 SET PSNP=$SELECT($PIECE(PSOPAR,"^",8):1,1:0)
+28 IF $GET(PPL)
Begin DoDot:1
+29 SET PPLHLD=$GET(PPL1)
SET HDPPL=PPL
KILL PPL1
SET (PSODBQ,PSOSUSPR)=1
+30 FOR GGGG=0:0
SET GGGG=$ORDER(RXPR(GGGG))
if 'GGGG
QUIT
if '$GET(RXPR(GGGG))
KILL RXPR(GGGG)
End DoDot:1
+31 IF $GET(PPL)
SET ZTIO=$GET(PSLION)
DO DQ^PSOLBL
DO SEQ
if '$GET(PSOPRFLG)
Begin DoDot:1
+32 IF $GET(PSOPROP)'=$GET(PSLION)
SET ^UTILITY($JOB,"PSOPRO",DFN)=""
QUIT
+33 DO DQ^PSOPRFSS
End DoDot:1
+34 IF $GET(PPLHLD)
KILL RXPR
SET (PPL,HDPPL)=PPLHLD
SET (PSODBQ,PSOSUSPR)=1
SET PSNP=0
if '$DATA(PDUZ)
SET PDUZ=DUZ
FOR XXX=0:0
SET XXX=$ORDER(RXPR1(XXX))
if 'XXX
QUIT
if $GET(RXPR1(XXX))
SET RXPR(XXX)=RXPR1(XXX)
+35 IF $GET(PPLHLD)
FOR RRRR=0:0
SET RRRR=$ORDER(RXRP1(RRRR))
if 'RRRR
QUIT
if $DATA(RXRP1(RRRR))
SET RXRP(RRRR)=1
+36 IF $GET(PPLHLD)
SET ZTIO=$GET(PSLION)
DO DQ^PSOLBL
DO SEQ
if '$GET(PSOPRFLG)
Begin DoDot:1
+37 IF $GET(PSOPROP)'=$GET(PSLION)
SET ^UTILITY($JOB,"PSOPRO",DFN)=""
QUIT
+38 DO DQ^PSOPRFSS
End DoDot:1
+39 KILL PPL,PPL1,PPLHLD,RXPR,RXPR1,RXFL
QUIT
SEQ ;
+1 SET SQCOUNT=0
FOR JJJ=1:1:$LENGTH(HDPPL)
if $EXTRACT(HDPPL,JJJ)=","
SET SQCOUNT=SQCOUNT+1
+2 FOR JJJJ=1:1:SQCOUNT
SET PSFNIEN=$PIECE(HDPPL,",",JJJJ)
if PSFNIEN
Begin DoDot:1
+3 SET PSFNIEN=$ORDER(^PS(52.5,"B",PSFNIEN,0))
IF PSFNIEN
Begin DoDot:2
+4 SET $PIECE(^PS(52.5,PSFNIEN,0),"^",11)=PSOSEQ
SET PSOSEQ=PSOSEQ+1
if $PIECE(^PS(52.5,PSFNIEN,0),"^",8)&($PIECE(^(0),"^",9))&($PIECE(^(0),"^",6))
SET ^PS(52.5,"AS",$PIECE(^PS(52.5,PSFNIEN,0),"^",8),$PIECE(^(0),"^",9),$PIECE(^(0),"^",6),$PIECE(^(0),"^",11),PSFNIEN)=""
End DoDot:2
End DoDot:1
+5 QUIT
CHKDEAD DO DEM^VADPT
IF VADM(1)=""
SET DEAD=0
QUIT
+1 IF VADM(6)=""
SET DEAD=0
QUIT
+2 SET PSDDDATE=$PIECE(VADM(6),"^",2)
FOR WWW=0:0
SET WWW=$ORDER(^PS(55,DFN,"P",WWW))
if 'WWW
QUIT
IF $DATA(^PS(55,DFN,"P",WWW,0))
IF $PIECE($GET(^(0)),"^")
SET (DA,RXREC)=$PIECE(^(0),"^")
SET SFN=$ORDER(^PS(52.5,"B",RXREC,0))
IF SFN
IF $DATA(^PS(52.5,SFN,0))
SET RX=$PIECE(^(0),"^")
DO DEAD
+3 QUIT
DEAD SET $PIECE(^PSRX(RX,"STA"),"^")=12
SET COM="Died ("_$GET(PSDDDATE)_")"
SET DA(1)=RX
+1 SET DEAD=1
DO ARECD^PSOSUTL
SET DIK="^PS(52.5,"
SET DA=SFN
DO ^DIK
KILL DIK
+2 QUIT
PROF ;
+1 SET ZTRTN="PRPROF^PSOSULBL"
SET ZTDESC="PRINT PROFILES FROM SUSPENSE"
SET ZTDTH=$HOROLOG
SET ZTIO=PSOPROP
+2 SET ZTSAVE("^UTILITY($J,""PSOPRO"",")=""
SET ZTSAVE("PSOPAR")=""
SET ZTSAVE("PSODTCUT")=""
SET ZTSAVE("PSOSITE")=""
SET ZTSAVE("PSOPRPAS")=""
DO ^%ZTLOAD
QUIT
PRPROF ;
+1 FOR LLL=0:0
SET LLL=$ORDER(^UTILITY($JOB,"PSOPRO",LLL))
if 'LLL
QUIT
IF $DATA(^DPT(LLL,0))
SET DFN=LLL
DO DQ^PSOPRFSS
+2 KILL PSOPAR,PSODTCUT,PSOSITE,PSOPRPAS,LLL,DFN,^UTILITY($JOB,"PSOPRO")
DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 QUIT
+4 ;
CHKBAI ; IF BAD ADDRESS INDICATOR, NO ACTIVE TEMPORARY ADDRESS AND ROUTING OF MAIL, DO NOT SEND TO OPAI AND/OR DO NOT PRINT LABEL
+1 NEW PSOBADR,ACTSEQ,XX,PSOFIRST,ACTTYPE
+2 IF '$GET(RXFILL)
IF $PIECE(^PSRX(RXIEN,0),"^",11)="W"
QUIT
+3 IF $PIECE($GET(^PSRX(RXIEN,1,RXFILL,0)),"^",2)="W"
QUIT
+4 SET ACTTYPE="BAD ADDRESS INDICATOR"
+5 SET PSOBADR=$$CHKRX^PSOBAI(RXIEN)
+6 ; GOOD PERMANENT OR TEMPORARY ADDRESS - CHECK FOR DO NOT MAIL
+7 IF PSOBADR
IF '$PIECE(PSOBADR,"^",2)
DO SETTMP(ACTTYPE)
QUIT
+8 SET NOMAIL=0
DO NOMAIL
IF NOMAIL
QUIT
+9 DO FOREIGN
+10 QUIT
+11 ;
SETTMP(ACTTYPE) ;
+1 NEW ACTSEQ,XX,PSOFIRST,ZZ
+2 SET PSOFIRST=1
+3 SET PSOBADDR=1
+4 SET ACTSEQ=0
FOR
SET ACTSEQ=$ORDER(^PSRX(RXIEN,"A",ACTSEQ))
if ACTSEQ=""
QUIT
Begin DoDot:1
+5 SET XX=$GET(^PSRX(RXIEN,"A",ACTSEQ,0))
IF $PIECE(XX,"^",2)="S"
SET ZZ=$PIECE(XX,"^",4)
SET ZZ=$SELECT(ZZ<6:ZZ,1:ZZ-1)
IF ZZ=RXFILL
IF $PIECE(XX,"^",5)["due to "_ACTTYPE
SET PSOFIRST=0
QUIT
End DoDot:1
+6 IF PSOFIRST
Begin DoDot:1
+7 SET ^TMP("PSOSBAI",$JOB,RXIEN,+RXFILL)=ACTTYPE
+8 DO ACT(ACTTYPE)
End DoDot:1
+9 QUIT
+10 ;
NOMAIL ; SEE IF FILE 55 STATUS IS DO NOT MAIL
+1 NEW ACTTYPE,DFN,MAILST,MAILEXP
+2 SET ACTTYPE="DO NOT MAIL"
+3 SET DFN=+$PIECE($GET(^PSRX(RXIEN,0)),"^",2)
SET MAILST=$PIECE($GET(^PS(55,DFN,0)),"^",3)
+4 SET MAILEXP=$PIECE(^PS(55,DFN,0),"^",5)
+5 ;p753
IF $$GET1^DIQ(52,RXIEN,100.2,"I")]""
SET MAILST=$$GET1^DIQ(52,RXIEN,100.2,"I")
SET MAILEXP=""
+6 IF MAILST'=2
QUIT
+7 IF MAILEXP=""!(MAILEXP>DT)
DO SETTMP(ACTTYPE)
+8 QUIT
+9 ;
FOREIGN ;
+1 NEW DFN,PSOFORGN
+2 ;*370
SET DFN=$$GET1^DIQ(52,RXIEN,2,"I")
+3 DO ADD^VADPT
+4 ; *370
SET PSOFORGN=$PIECE($GET(VAPA(25)),"^",2)
IF PSOFORGN'=""
Begin DoDot:1
+5 NEW PSON,PSOFOREN
SET PSOFOREN=1
+6 SET PSON=$$GET1^DIQ(59,PSOSITE,.01)
+7 IF PSON'["MANILA"
IF PSOFORGN["UNITED STATES"
SET PSOFOREN=0
+8 IF PSON["MANILA"
IF PSOFORGN["PHILIPPINES"
SET PSOFOREN=0
+9 SET PSOFORGN=PSOFOREN
End DoDot:1
+10 IF PSOFORGN
DO SETTMP("FOREIGN ADDRESS")
+11 QUIT
+12 ;
CHKMAIL ; SEE IF MAILMAN MESSAGE SHOULD BE SENT FOR BAI/MAIL ROUTING
+1 NEW RXIEN,RXFILL,ACTSEQ,XX,DFN,SSN,NAME,ACTTYPE,ZZ
+2 KILL ^TMP("PSOSM",$JOB)
+3 SET RXIEN=0
FOR
SET RXIEN=$ORDER(^TMP("PSOSBAI",$JOB,RXIEN))
if 'RXIEN
QUIT
Begin DoDot:1
+4 SET RXFILL=""
FOR
SET RXFILL=$ORDER(^TMP("PSOSBAI",$JOB,RXIEN,RXFILL))
if RXFILL=""
QUIT
Begin DoDot:2
+5 SET ACTTYPE=^TMP("PSOSBAI",$JOB,RXIEN,RXFILL)
+6 SET ACTSEQ=0
FOR
SET ACTSEQ=$ORDER(^PSRX(RXIEN,"A",ACTSEQ))
if ACTSEQ=""
QUIT
Begin DoDot:3
+7 SET XX=$GET(^PSRX(RXIEN,"A",ACTSEQ,0))
IF $PIECE(XX,"^",2)="S"
SET ZZ=$PIECE(XX,"^",4)
SET ZZ=$SELECT(ZZ<6:ZZ,1:ZZ-1)
IF ZZ=RXFILL
IF $PIECE(XX,"^",5)["due to "_ACTTYPE
QUIT
+8 SET DFN=$PIECE(^PSRX(RXIEN,0),"^",2)
SET NAME=$PIECE(^DPT(DFN,0),"^")
SET SSN=$PIECE(^(0),"^",9)
IF SSN=""
SET SSN=0
+9 SET ^TMP("PSOSM",$JOB,NAME,SSN,RXIEN,RXFILL)=ACTTYPE
End DoDot:3
End DoDot:2
End DoDot:1
+10 IF $DATA(^TMP("PSOSM",$JOB))
DO BAIMAIL^PSOSULB1
+11 KILL ^TMP("PSOSM",$JOB)
+12 QUIT
+13 ;
ACT(ACTTYPE) ;adds activity info for rx not printed from suspense/not sent to OPAI
+1 NEW NOW,IR,FDA
+2 DO NOW^%DTC
SET NOW=%
+3 SET IR=0
FOR FDA=0:0
SET FDA=$ORDER(^PSRX(RXIEN,"A",FDA))
if 'FDA
QUIT
SET IR=FDA
+4 SET IR=IR+1
SET ^PSRX(RXIEN,"A",0)="^52.3DA^"_IR_"^"_IR
+5 SET ^PSRX(RXIEN,"A",IR,0)=NOW_"^"_"S"_"^"_DUZ_"^"_$SELECT(+RXFILL>5:RXFILL+1,1:+RXFILL)_"^"_"RX not printed from suspense due to "_ACTTYPE
+6 KILL PSUS,RXF,I,FDA,DIC,DIE,DR,Y,X,%,%I,%H,RSDT
+7 QUIT
+8 ;
PRINTED(SFN,RX,RFL) ;
+1 ; Check if a label log indicates that a label has already been printed
+2 ; Input Parameters
+3 ; SFN - IEN of RX Suspense file (#52.5)
+4 ; RX - IEN of Prescription file (#50)
+5 ; RFL - Refill number
+6 ; Output
+7 ; 0 - Label not printed
+8 ; 1 - Label already printed
+9 ; 2 - Label already printed and reprint flag is set
+10 ;
+11 ; Check parameters
+12 IF '$GET(SFN)
QUIT 0
+13 IF '$GET(RX)
QUIT 0
+14 IF $GET(RFL)=""
SET RFL=$$LSTRFL^PSOBPSU1(RX)
+15 ;
+16 NEW LBL,PTLBL
+17 ; Check label log
+18 SET LBL=0
SET PTLBL=0
+19 FOR
SET LBL=$ORDER(^PSRX(RX,"L",LBL))
if 'LBL
QUIT
Begin DoDot:1
+20 IF +$$GET1^DIQ(52.032,LBL_","_RX,1,"I")'=RFL
QUIT
+21 ; Warning Label printed
IF $$GET1^DIQ(52.032,LBL_","_RX,4,"I")
QUIT
+22 ; Comment contains "Interaction"
IF $$GET1^DIQ(52.032,LBL_","_RX,2)["INTERACTION"
QUIT
+23 SET PTLBL=1
End DoDot:1
if PTLBL
QUIT
+24 ; If the label log indicates a label was printed and the REPRINT flag is set, change the output to 2
+25 IF PTLBL=1
IF $$GET1^DIQ(52.5,SFN_",",8,"I")
SET PTLBL=2
+26 ;
+27 QUIT PTLBL
+28 ;
REMOVE(SFN,RX,RFL,USR,DSP,PRTFLG) ;
+1 ; Remove the RX from the RX Suspense queue (#52.5)
+2 ; Input Parameters
+3 ; SFN - IEN of RX Suspense file (#52.5)
+4 ; RX - IEN of Prescription file (#52)
+5 ; RFL - Refill number
+6 ; USR - User to enter into the Activity Log
+7 ; DSP - Display message
+8 ; PRTFLG - 1:Printed,2:Printed and Reprint Flag
+9 ;
+10 ; If Reprint flag and display flags are on, display message and quit
+11 IF $GET(PRTFLG)=2
IF $GET(DSP)
WRITE !,"Reprint Flag is on. Prescription left on suspense."
HANG 1
QUIT
+12 ;
+13 ; Check parameters
+14 IF '$GET(SFN)
QUIT
+15 IF '$DATA(^PS(52.5,SFN,0))
QUIT
+16 IF '$GET(RX)
QUIT
+17 IF '$DATA(^PSRX(RX,0))
QUIT
+18 IF $GET(RFL)=""
SET RFL=$$LSTRFL^PSOBPSU1(RX)
+19 ;
+20 NEW DIK,DA,DIE,DR,DTOUT
+21 ;
+22 ; Remove from the suspense queue
+23 SET DIK="^PS(52.5,"
SET DA=SFN
DO ^DIK
+24 ;
+25 ; Update status in the PRESCRIPTION file
+26 KILL DIE,DA
+27 SET DIE=52
SET DA=RX
SET DR="100///0"
DO ^DIE
+28 ;
+29 ; Update the Activity Log
+30 IF '$DATA(USR)
SET USR=DUZ
+31 IF '$DATA(^VA(200,+USR,0))
SET USR=DUZ
+32 NEW X,DIC,DA,DD,DO,DR,DINUM,Y,DLAYGO
+33 SET DA(1)=RX
SET DIC="^PSRX("_RX_",""A"","
SET DLAYGO=52.3
SET DIC(0)="L"
SET X=$$NOW^XLFDT()
+34 SET DIC("DR")=".02///S;.03////"_USR_";.04///"_$SELECT(RFL>5:RFL+1,1:RFL)_";.05///Rx removed from suspense due to previous label print"
+35 DO FILE^DICN
+36 IF $GET(DSP)
WRITE !,"Prescription has been removed from suspense."
HANG 1
+37 QUIT
