PSXRPPL ;BIR/WPB,BAB-Gathers data for the CMOP Transmission ;13 Mar 2002 10:31 AM
;;2.0;CMOP;**3,23,33,28,40,42,41,48,62,58,66,65,69,70,81,83,87,91**;11 Apr 97;Build 33
;Reference to ^PS(52.5, supported by DBIA #1978
;Reference to ^PSRX( supported by DBIA #1977
;Reference to ^PSOHLSN1 supported by DBIA #2385
;Reference to ^PSORXL supported by DBIA #1969
;Reference to ^PSOLSET supported by DBIA #1973
;Reference to %ZIS(1 supported by DBIA #290
;Reference to %ZIS(2 supported by DBIA #2247
;Reference to ^PSSLOCK supported by DBIA #2789
;Reference to ^XTMP("ORLK-" supported by DBIA #4001
;Reference to ^BPSUTIL supported by DBIA #4410
;Reference to ^PS(59 supported by DBIA #1976
;Reference to $$SELPRT^PSOFDAUT supported by DBIA #5740
;Reference to LOG^BPSOSL supported by ICR# 6764
;Reference to IEN59^BPSOSRX supported by ICR# 4412
;
;Called from PSXRSUS -Builds ^PSX(550.2,,15,"C" , and returns to PSXRSUS or PSXRTRAN
;
SDT ;
K ^TMP($J,"PSX"),^TMP($J,"PSXDFN"),^TMP("PSXEPHNB",$J)
K PSXBAT,ZCNT
I $D(XRTL) D T0^%ZOSV
S PSXTDIV=PSOSITE,PSXTYP=$S(+$G(PSXCS):"C",1:"N")
;
; $$SBTECME^PSXRPPL1 goes through the suspense queue for either CS
; or non-CS prescriptions (according to PSXTYP), up to and including
; the through date (PRTDT). For each Rx, it will send a claim if
; the patient has insurance.
;
I $$ECMEON^BPSUTIL(PSXTDIV),$$CMOPON^BPSUTIL(PSXTDIV) D
. N BPSCNT S BPSCNT=$$SBTECME^PSXRPPL1(PSXTYP,PSXTDIV,PRTDT,PSXDTRG)
. ; - Wait 15 seconds per prescription sent to ECME (max of 2 hours)
. I BPSCNT>0 H 60+$S((BPSCNT*15)>7200:7200,1:(BPSCNT*15))
;
; After many additional checks, GETDATA^PSXRPPL will eventually add
; each prescription to this batch (see RS550215, below). Later in
; the process, either they will be sent to CMOP (EN^PSXRTR) or
; labels will be printed (PRT^PSXRPPL).
;
K ^TMP("PSXEPHIN",$J)
S SDT=0
F S SDT=$O(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT)),XDFN=0 Q:(SDT>PRTDT)!(SDT'>0) D
. F S XDFN=$O(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,XDFN)),REC=0 Q:(XDFN'>0)!(XDFN="") D
. . F S REC=$O(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,XDFN,REC)) Q:(REC'>0)!(REC="") D
. . . D GETDATA D:$G(RXN) PSOUL^PSSLOCK(RXN),OERRLOCK(RXN)
;
; After making a first pass through the suspense queue (SBTECME^
; PSXRPPL1), it will now make a second pass (CHKDFN^PSXRPPL2) to look
; for additional Rxs for patients who already have an Rx in the batch.
; CHKDFN^PSXRPPL2 makes a pass and sends claims when appropriate, and
; CHKDFN^PSXRPPL makes the same pass and calls GETDATA, which condi-
; tionally adds each Rx to the batch.
;
I $G(PSXBAT),'$G(PSXRTRAN) D CHKDFN^PSXRPPL2(PRTDT)
I $G(PSXBAT),'$G(PSXRTRAN) D CHKDFN
;
; - Sends a Mailman message if there were transmission problems with the 3rd Party Payer
I $D(^TMP("PSXEPHIN",$J)) D ^PSXBPSMS K ^TMP("PSXEPHIN",$J),^TMP("PSXEPHNB",$J)
;
EXIT ;
K SDT,DFN,REC,RXNUM,PSXOK,FILNUM,REF,PNAME,CNAME,DIE,DR,%,CNT,COM,DTTM,FILL,JJ,PRTDT,PSXDIV,XDFN,NFLAG,CIND
K CHKDT,DAYS,DRUG,DRUGCHK,NM,OPDT,PHARCLK,PHY,PSTAT,PTRA,PTRB,QTY,REL,RXERR,RXF,SFN,PSXDGST,PSXMC,PSXMDT
S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV
K ^TMP("PSXEPHIN",$J),^TMP("PSXEPHNB",$J)
Q
;
GETDATA ;Screens rxs and builds data
;PSXOK=1:NOT CMOP DRUG OR DO NOT MAIL,2:TRADENAME,3:WINDOW,4:PRINTED,5:NOT SUSPENDED
;PSXOK=6:ALREADY RELEASED,7:DIFFERENT DIVISION,8:BAD DATA IN 52.5
;9:CS Mismatch,10:DEA 1 or 2
I '$D(^PS(52.5,REC,0)) K ^PS(52.5,"AQ",SDT,XDFN,REC),^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,XDFN,REC) Q
I $P(^PS(52.5,REC,0),"^",7)="" K ^PS(52.5,"AQ",SDT,XDFN,REC),^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,XDFN,REC) Q
I ($P(^PS(52.5,REC,0),"^",3)'=XDFN) K ^PS(52.5,"AQ",SDT,XDFN,REC),^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,XDFN,REC) Q
N DFN S DFN=XDFN D DEM^VADPT
I $G(VADM(6))'="" D DELETE K VADM Q
S PSXOK=0,NFLAG=0
S RXN=$P($G(^PS(52.5,REC,0)),"^",1) I RXN="" S PSXOK=8 Q
S RFL=+$$GET1^DIQ(52.5,REC,9,"I")
I '$D(^TMP($J,"PSXBAI",DFN)) D
.S PSXGOOD=$$ADDROK^PSXMISC1(RXN)
.I 'PSXGOOD S PSXFIRST=1 D I 'PSXFIRST S PSXOK=8
..D CHKACT^PSXMISC1(RXN)
I PSXOK=8 K RXN Q
;
N EPHQT
S EPHQT=0
I $$PATCH^XPDUTL("PSO*7.0*148"),'$$TRICVANB^PSXRPPL1(RXN,RFL) D EPHARM^PSXRPPL2
D LOG^BPSOSL($$IEN59^BPSOSRX(RXN,RFL),$T(+0)_"-GETDATA, EPHQT="_EPHQT) ; ICR #4412,6764
I EPHQT Q
;
D CHKDATA^PSXMISC1
;
SET Q:(PSXOK=7)!(PSXOK=8)!(PSXOK=9)
S PNAME=$G(VADM(1))
I ($G(PSXCSRX)=1)&($G(PSXCS)=1) S ^XTMP("PSXCS",PSOSITE,DT,RXN)=""
I (PSXOK=0)&(PSXFLAG=1) S ^TMP($J,"PSXDFN",XDFN)="",NFLAG=4 D DQUE,RX550215 Q
I (PSXOK=0)&(PSXFLAG=2) D RX550215 Q
I (PSXOK>0)&(PSXOK<7)!(PSXOK=10) D DELETE Q
Q
;
DELETE ; deletes the CMOP STATUS field in PS(52.5, reindex 'AC' x-ref
L +^PS(52.5,REC):600 Q:'$T
N DR,DIE,DA S DIE="^PS(52.5,",DA=REC,DR="3///@" D ^DIE
S ^PS(52.5,"AC",$P(^PS(52.5,REC,0),"^",3),$P(^PS(52.5,REC,0),"^",2),REC)=""
L -^PS(52.5,REC)
Q
;
CHKDFN ;
I '$D(^PSX(550.2,PSXBAT,15,"C")) Q
S PSXPTNM=""
F S PSXPTNM=$O(^PSX(550.2,PSXBAT,15,"C",PSXPTNM)) Q:PSXPTNM="" D
. S XDFN=0
. F S XDFN=$O(^PSX(550.2,PSXBAT,"15","C",PSXPTNM,XDFN)) Q:(XDFN'>0) D
. . S SDT=PRTDT
. . F S SDT=$O(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT)) Q:(SDT>PSXDTRG)!(SDT="") D
. . . S REC=0
. . . F S REC=$O(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,XDFN,REC)) Q:REC'>0 D
. . . . D GETDATA D:$G(RXN) PSOUL^PSSLOCK(RXN),OERRLOCK(RXN)
Q
;
BEGIN ; Select print device
I '$D(PSOPAR) D ^PSOLSET
I $D(PSOLAP),($G(PSOLAP)'=ION) S PSLION=PSOLAP G PROFILE
W ! S %ZIS("A")="PRINTER 'LABEL' DEVICE: ",%ZIS("B")="",%ZIS="MQN" D ^%ZIS S PSLION=ION G:POP EXIT
I $G(IOST)["C-" W !,"You must select a printer!",! G BEGIN
F J=0,1 S @("PSOBAR"_J)="" I $D(^%ZIS(2,^%ZIS(1,IOS,"SUBTYPE"),"BAR"_J)) S @("PSOBAR"_J)=^("BAR"_J)
S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19)
K PSOION,J D ^%ZISC I $D(IO("Q")) K IO("Q")
;
PROFILE I $D(PSOPROP),($G(PSOPROP)'=ION) G FDAMG
I $P(PSOPAR,"^",8) S %ZIS="MNQ",%ZIS("A")="Select PROFILE PRINTER: " D ^%ZIS K %ZIS,IO("Q"),IOP G:POP EXIT S PSOPROP=ION D ^%ZISC
I $G(PSOPROP)=ION W !,"You must select a printer!",! G PROFILE
;
FDAMG ; Selects FDA Medication Guide Printer
I $$GET1^DIQ(59,PSOSITE,134)'="" N FDAPRT S FDAPRT="" D I FDAPRT="^"!($G(PSOFDAPT)="") S POP=1 G EXIT
. F D Q:FDAPRT'=""
. . S FDAPRT=$$SELPRT^PSOFDAUT($P($G(PSOFDAPT),"^"))
. . I FDAPRT="" W $C(7),!,"You must select a valid FDA Medication Guide printer."
. I FDAPRT'="",(FDAPRT'="^") S PSOFDAPT=FDAPRT
Q
;
PRT ; Print labels.
D NOW^%DTC S DTTM=% K %
S NM="" F S NM=$O(^PSX(550.2,PSXBAT,15,"C",NM)) Q:NM="" D DFN,PPL ;gather patient RXs, print patient RXs
S DIK="^PSX(550.2,",DA=PSXBAT D ^DIK K PSXBAT
K CHKDT,CIND,DAYS,DRUG,DRUGCHK,NFLAG,NM,ORD,PDT,PHARCLK,PHY,PSTAT,PTRA,PTRB,QTY,REL,RXERR,RXF,SFN,SIG,SITE,SUS,SUSPT
Q
;
DFN S DFN=0,NFLAG=2
F S DFN=$O(^PSX(550.2,PSXBAT,15,"C",NM,DFN)),RXN=0 Q:(DFN="")!(DFN'>0) D
.F S RXN=$O(^PSX(550.2,PSXBAT,15,"C",NM,DFN,RXN)),RXF="" Q:(RXN="")!(RXN'>0) D
..F S RXF=$O(^PSX(550.2,PSXBAT,15,"C",NM,DFN,RXN,RXF)) Q:RXF="" D BLD
Q
;
BLD ;
S BATRXDA=$O(^PSX(550.2,PSXBAT,15,"B",RXN,0)) D NOW^%DTC S DTTM=%
S REC=$P(^PSX(550.2,PSXBAT,15,BATRXDA,0),U,5),SUS=$O(^PS(52.5,"B",RXN,0))
I SUS=REC,+SUS'=0 I 1 ;rx still valid in suspense
E D Q ;rx gone
. N DA,DIK S DIK=550.2,DA(1)=PSXBAT,DA=BATRXDA
. D ^DIK
S PSOSU(DFN,SUS)=RXN,RXCNTR=$G(RXCNTR)+1,NFLAG=2
S $P(^PSRX(RXN,0),U,15)=0,$P(^PSRX(RXN,"STA"),U,1)=0
K % S COM="CMOP Suspense Label "_$S($G(^PS(52.5,SUS,"P"))=0:"Printed",$G(^PS(52.5,SUS,"P"))="":"Printed",1:"Reprinted")_$S($G(^PSRX(RXN,"TYPE"))>0:" (PARTIAL)",1:"")
D EN^PSOHLSN1(RXN,"SC","ZU",COM)
S DA=SUS D DQUE K DA
ACTLOG F JJ=0:0 S JJ=$O(^PSRX(RXN,"A",JJ)) Q:'JJ S CNT=JJ
S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF S RFCNT=$S(RF<6:RF,1:RF+1)
S CNT=CNT+1,^PSRX(RXN,"A",0)="^52.3DA^"_CNT_"^"_CNT
LOCK L +^PSRX(RXN):600 G:'$T LOCK
S ^PSRX(RXN,"A",CNT,0)=DTTM_"^S^"_DUZ_"^"_RFCNT_"^"_COM L -^PSRX(RXN)
K CNT,COM,RFCNT,%,JJ,RF,Y,RXCNTR
Q
;
PPL K PPL,PPL1 S ORD="" F S ORD=$O(PSOSU(ORD)) Q:(ORD="")!(ORD'>0) D PPL1
Q
;
PPL1 ; print patient labels
F SFN=0:0 S SFN=$O(PSOSU(ORD,SFN)) Q:'SFN D
. S:$L($G(PPL))<240 PPL=$P(PSOSU(ORD,SFN),"^")_","_$G(PPL)
. S:$L($G(PPL))>239 PPL1=$P(PSOSU(ORD,SFN),"^")_","_$G(PPL1)
. S DFN=$P(^PS(52.5,SFN,0),"^",3)
S SUSPT=1,PSNP=$S($P(PSOPAR,"^",8):1,1:0) S:$D(PSOPROP) PFIO=PSOPROP
D QLBL^PSORXL
I $D(PPL1) S PSNP=0,PPL=PPL1 D QLBL^PSORXL
K PPL,PPL1,PSOSU(ORD)
Q
;
DQUE ; sets the CMOP indicator field, and printed field in 52.5
L +^PS(52.5,REC):600 G:'$T DQUE
I NFLAG=4 D
. S DA=REC,DIE="^PS(52.5,",DR="3////L;4////"_DT D ^DIE K DIE,DA,DR L -^PS(52.5,REC) ; the rest moved into PSXRTR
S CIND=$S(NFLAG=1:"X",NFLAG=2:"P",NFLAG=3:"@",1:0)
I $G(NFLAG)'=2 D
.S DA=REC,DIE="^PS(52.5,",DR="3////"_CIND_";4////"_DT
.D ^DIE K DIE,DA,DR
.S ^PS(52.5,REC,"P")=1,^PS(52.5,"ADL",DT,REC)=""
I $G(NFLAG)=2 D ;print label cycle
. S DA=REC,DIE="^PS(52.5,",DR="3////"_CIND_";4////"_DTTM_";5////"_DUZ_";7////"_RXCNTR
. D ^DIE K DIE,DA,DR
. S ^PS(52.5,REC,"P")=1,^PS(52.5,"ADL",$E($P(^PS(52.5,REC,0),"^",8),1,7),REC)=""
L -^PS(52.5,REC)
I $G(NFLAG)=2 D EN^PSOHLSN1(RXN,"SC","ZU","CMOP Suspense Label Printed")
Q
;
RX550215 ; put RX into RX multiple TRANS 550.215 for PSXBAT
I '$G(PSXBAT) D BATCH^PSXRSYU ; first time through create batch, & return PSXBAT
K DD,DO,DIC,DA,DR,D0
S:'$D(^PSX(550.2,PSXBAT,15,0)) ^PSX(550.2,PSXBAT,15,0)="^550.215P^^"
S X=RXN,DA(1)=PSXBAT
S DIC="^PSX(550.2,"_PSXBAT_",15,",DIC("DR")=".02////^S X=RXF;.03////^S X=DFN;.05////^S X=REC",DIC(0)="ZF"
D FILE^DICN
S PSXRXTDA=+Y ;RX DA within PSXBAT 'T'ransmission
K DD,DO,DIC,DA,DR,D0
Q
;
OERRLOCK(RXN) ; set XTMP for OERR/CPRS order locking
I $G(PSXBAT),$G(RXN),$G(PSXRXTDA) I 1
E Q
I $P(^PSX(550.2,PSXBAT,15,PSXRXTDA,0),U,1)'=RXN Q
RXNSET ; set ^XTMP("ORLK-"_ORDER per IA 4001 needs RXN
Q:'$G(RXN)
N ORD,NOW,NOW1 S ORD=+$P($G(^PSRX(+$G(RXN),"OR1")),"^",2)
Q:'ORD
S NOW=$$NOW^XLFDT,NOW1=$$FMADD^XLFDT(NOW,1)
S ^XTMP("ORLK-"_+ORD,0)=NOW1_U_NOW_"^CPRS/CMOP RX/Order Lock",^(1)=DUZ_U_$J
Q
;
RXNCLEAR ; needs RXN
Q:'$G(RXN)
N ORD S ORD=+$P($G(^PSRX(+$G(RXN),"OR1")),"^",2) Q:'ORD
I $D(^XTMP("ORLK-"_ORD,0)),^(0)["CPRS/CMOP" K ^XTMP("ORLK-"_ORD)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXRPPL 10444 printed Apr 09, 2024@20:50:11 Page 2
PSXRPPL ;BIR/WPB,BAB-Gathers data for the CMOP Transmission ;13 Mar 2002 10:31 AM
+1 ;;2.0;CMOP;**3,23,33,28,40,42,41,48,62,58,66,65,69,70,81,83,87,91**;11 Apr 97;Build 33
+2 ;Reference to ^PS(52.5, supported by DBIA #1978
+3 ;Reference to ^PSRX( supported by DBIA #1977
+4 ;Reference to ^PSOHLSN1 supported by DBIA #2385
+5 ;Reference to ^PSORXL supported by DBIA #1969
+6 ;Reference to ^PSOLSET supported by DBIA #1973
+7 ;Reference to %ZIS(1 supported by DBIA #290
+8 ;Reference to %ZIS(2 supported by DBIA #2247
+9 ;Reference to ^PSSLOCK supported by DBIA #2789
+10 ;Reference to ^XTMP("ORLK-" supported by DBIA #4001
+11 ;Reference to ^BPSUTIL supported by DBIA #4410
+12 ;Reference to ^PS(59 supported by DBIA #1976
+13 ;Reference to $$SELPRT^PSOFDAUT supported by DBIA #5740
+14 ;Reference to LOG^BPSOSL supported by ICR# 6764
+15 ;Reference to IEN59^BPSOSRX supported by ICR# 4412
+16 ;
+17 ;Called from PSXRSUS -Builds ^PSX(550.2,,15,"C" , and returns to PSXRSUS or PSXRTRAN
+18 ;
SDT ;
+1 KILL ^TMP($JOB,"PSX"),^TMP($JOB,"PSXDFN"),^TMP("PSXEPHNB",$JOB)
+2 KILL PSXBAT,ZCNT
+3 IF $DATA(XRTL)
DO T0^%ZOSV
+4 SET PSXTDIV=PSOSITE
SET PSXTYP=$SELECT(+$GET(PSXCS):"C",1:"N")
+5 ;
+6 ; $$SBTECME^PSXRPPL1 goes through the suspense queue for either CS
+7 ; or non-CS prescriptions (according to PSXTYP), up to and including
+8 ; the through date (PRTDT). For each Rx, it will send a claim if
+9 ; the patient has insurance.
+10 ;
+11 IF $$ECMEON^BPSUTIL(PSXTDIV)
IF $$CMOPON^BPSUTIL(PSXTDIV)
Begin DoDot:1
+12 NEW BPSCNT
SET BPSCNT=$$SBTECME^PSXRPPL1(PSXTYP,PSXTDIV,PRTDT,PSXDTRG)
+13 ; - Wait 15 seconds per prescription sent to ECME (max of 2 hours)
+14 IF BPSCNT>0
HANG 60+$SELECT((BPSCNT*15)>7200:7200,1:(BPSCNT*15))
End DoDot:1
+15 ;
+16 ; After many additional checks, GETDATA^PSXRPPL will eventually add
+17 ; each prescription to this batch (see RS550215, below). Later in
+18 ; the process, either they will be sent to CMOP (EN^PSXRTR) or
+19 ; labels will be printed (PRT^PSXRPPL).
+20 ;
+21 KILL ^TMP("PSXEPHIN",$JOB)
+22 SET SDT=0
+23 FOR
SET SDT=$ORDER(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT))
SET XDFN=0
if (SDT>PRTDT)!(SDT'>0)
QUIT
Begin DoDot:1
+24 FOR
SET XDFN=$ORDER(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,XDFN))
SET REC=0
if (XDFN'>0)!(XDFN="")
QUIT
Begin DoDot:2
+25 FOR
SET REC=$ORDER(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,XDFN,REC))
if (REC'>0)!(REC="")
QUIT
Begin DoDot:3
+26 DO GETDATA
if $GET(RXN)
DO PSOUL^PSSLOCK(RXN)
DO OERRLOCK(RXN)
End DoDot:3
End DoDot:2
End DoDot:1
+27 ;
+28 ; After making a first pass through the suspense queue (SBTECME^
+29 ; PSXRPPL1), it will now make a second pass (CHKDFN^PSXRPPL2) to look
+30 ; for additional Rxs for patients who already have an Rx in the batch.
+31 ; CHKDFN^PSXRPPL2 makes a pass and sends claims when appropriate, and
+32 ; CHKDFN^PSXRPPL makes the same pass and calls GETDATA, which condi-
+33 ; tionally adds each Rx to the batch.
+34 ;
+35 IF $GET(PSXBAT)
IF '$GET(PSXRTRAN)
DO CHKDFN^PSXRPPL2(PRTDT)
+36 IF $GET(PSXBAT)
IF '$GET(PSXRTRAN)
DO CHKDFN
+37 ;
+38 ; - Sends a Mailman message if there were transmission problems with the 3rd Party Payer
+39 IF $DATA(^TMP("PSXEPHIN",$JOB))
DO ^PSXBPSMS
KILL ^TMP("PSXEPHIN",$JOB),^TMP("PSXEPHNB",$JOB)
+40 ;
EXIT ;
+1 KILL SDT,DFN,REC,RXNUM,PSXOK,FILNUM,REF,PNAME,CNAME,DIE,DR,%,CNT,COM,DTTM,FILL,JJ,PRTDT,PSXDIV,XDFN,NFLAG,CIND
+2 KILL CHKDT,DAYS,DRUG,DRUGCHK,NM,OPDT,PHARCLK,PHY,PSTAT,PTRA,PTRB,QTY,REL,RXERR,RXF,SFN,PSXDGST,PSXMC,PSXMDT
+3 if $DATA(XRT0)
SET XRTN=$TEXT(+0)
if $DATA(XRT0)
DO T1^%ZOSV
+4 KILL ^TMP("PSXEPHIN",$JOB),^TMP("PSXEPHNB",$JOB)
+5 QUIT
+6 ;
GETDATA ;Screens rxs and builds data
+1 ;PSXOK=1:NOT CMOP DRUG OR DO NOT MAIL,2:TRADENAME,3:WINDOW,4:PRINTED,5:NOT SUSPENDED
+2 ;PSXOK=6:ALREADY RELEASED,7:DIFFERENT DIVISION,8:BAD DATA IN 52.5
+3 ;9:CS Mismatch,10:DEA 1 or 2
+4 IF '$DATA(^PS(52.5,REC,0))
KILL ^PS(52.5,"AQ",SDT,XDFN,REC),^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,XDFN,REC)
QUIT
+5 IF $PIECE(^PS(52.5,REC,0),"^",7)=""
KILL ^PS(52.5,"AQ",SDT,XDFN,REC),^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,XDFN,REC)
QUIT
+6 IF ($PIECE(^PS(52.5,REC,0),"^",3)'=XDFN)
KILL ^PS(52.5,"AQ",SDT,XDFN,REC),^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,XDFN,REC)
QUIT
+7 NEW DFN
SET DFN=XDFN
DO DEM^VADPT
+8 IF $GET(VADM(6))'=""
DO DELETE
KILL VADM
QUIT
+9 SET PSXOK=0
SET NFLAG=0
+10 SET RXN=$PIECE($GET(^PS(52.5,REC,0)),"^",1)
IF RXN=""
SET PSXOK=8
QUIT
+11 SET RFL=+$$GET1^DIQ(52.5,REC,9,"I")
+12 IF '$DATA(^TMP($JOB,"PSXBAI",DFN))
Begin DoDot:1
+13 SET PSXGOOD=$$ADDROK^PSXMISC1(RXN)
+14 IF 'PSXGOOD
SET PSXFIRST=1
Begin DoDot:2
+15 DO CHKACT^PSXMISC1(RXN)
End DoDot:2
IF 'PSXFIRST
SET PSXOK=8
End DoDot:1
+16 IF PSXOK=8
KILL RXN
QUIT
+17 ;
+18 NEW EPHQT
+19 SET EPHQT=0
+20 IF $$PATCH^XPDUTL("PSO*7.0*148")
IF '$$TRICVANB^PSXRPPL1(RXN,RFL)
DO EPHARM^PSXRPPL2
+21 ; ICR #4412,6764
DO LOG^BPSOSL($$IEN59^BPSOSRX(RXN,RFL),$TEXT(+0)_"-GETDATA, EPHQT="_EPHQT)
+22 IF EPHQT
QUIT
+23 ;
+24 DO CHKDATA^PSXMISC1
+25 ;
SET if (PSXOK=7)!(PSXOK=8)!(PSXOK=9)
QUIT
+1 SET PNAME=$GET(VADM(1))
+2 IF ($GET(PSXCSRX)=1)&($GET(PSXCS)=1)
SET ^XTMP("PSXCS",PSOSITE,DT,RXN)=""
+3 IF (PSXOK=0)&(PSXFLAG=1)
SET ^TMP($JOB,"PSXDFN",XDFN)=""
SET NFLAG=4
DO DQUE
DO RX550215
QUIT
+4 IF (PSXOK=0)&(PSXFLAG=2)
DO RX550215
QUIT
+5 IF (PSXOK>0)&(PSXOK<7)!(PSXOK=10)
DO DELETE
QUIT
+6 QUIT
+7 ;
DELETE ; deletes the CMOP STATUS field in PS(52.5, reindex 'AC' x-ref
+1 LOCK +^PS(52.5,REC):600
if '$TEST
QUIT
+2 NEW DR,DIE,DA
SET DIE="^PS(52.5,"
SET DA=REC
SET DR="3///@"
DO ^DIE
+3 SET ^PS(52.5,"AC",$PIECE(^PS(52.5,REC,0),"^",3),$PIECE(^PS(52.5,REC,0),"^",2),REC)=""
+4 LOCK -^PS(52.5,REC)
+5 QUIT
+6 ;
CHKDFN ;
+1 IF '$DATA(^PSX(550.2,PSXBAT,15,"C"))
QUIT
+2 SET PSXPTNM=""
+3 FOR
SET PSXPTNM=$ORDER(^PSX(550.2,PSXBAT,15,"C",PSXPTNM))
if PSXPTNM=""
QUIT
Begin DoDot:1
+4 SET XDFN=0
+5 FOR
SET XDFN=$ORDER(^PSX(550.2,PSXBAT,"15","C",PSXPTNM,XDFN))
if (XDFN'>0)
QUIT
Begin DoDot:2
+6 SET SDT=PRTDT
+7 FOR
SET SDT=$ORDER(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT))
if (SDT>PSXDTRG)!(SDT="")
QUIT
Begin DoDot:3
+8 SET REC=0
+9 FOR
SET REC=$ORDER(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,XDFN,REC))
if REC'>0
QUIT
Begin DoDot:4
+10 DO GETDATA
if $GET(RXN)
DO PSOUL^PSSLOCK(RXN)
DO OERRLOCK(RXN)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
BEGIN ; Select print device
+1 IF '$DATA(PSOPAR)
DO ^PSOLSET
+2 IF $DATA(PSOLAP)
IF ($GET(PSOLAP)'=ION)
SET PSLION=PSOLAP
GOTO PROFILE
+3 WRITE !
SET %ZIS("A")="PRINTER 'LABEL' DEVICE: "
SET %ZIS("B")=""
SET %ZIS="MQN"
DO ^%ZIS
SET PSLION=ION
if POP
GOTO EXIT
+4 IF $GET(IOST)["C-"
WRITE !,"You must select a printer!",!
GOTO BEGIN
+5 FOR J=0,1
SET @("PSOBAR"_J)=""
IF $DATA(^%ZIS(2,^%ZIS(1,IOS,"SUBTYPE"),"BAR"_J))
SET @("PSOBAR"_J)=^("BAR"_J)
+6 SET PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$PIECE(PSOPAR,"^",19)
+7 KILL PSOION,J
DO ^%ZISC
IF $DATA(IO("Q"))
KILL IO("Q")
+8 ;
PROFILE IF $DATA(PSOPROP)
IF ($GET(PSOPROP)'=ION)
GOTO FDAMG
+1 IF $PIECE(PSOPAR,"^",8)
SET %ZIS="MNQ"
SET %ZIS("A")="Select PROFILE PRINTER: "
DO ^%ZIS
KILL %ZIS,IO("Q"),IOP
if POP
GOTO EXIT
SET PSOPROP=ION
DO ^%ZISC
+2 IF $GET(PSOPROP)=ION
WRITE !,"You must select a printer!",!
GOTO PROFILE
+3 ;
FDAMG ; Selects FDA Medication Guide Printer
+1 IF $$GET1^DIQ(59,PSOSITE,134)'=""
NEW FDAPRT
SET FDAPRT=""
Begin DoDot:1
+2 FOR
Begin DoDot:2
+3 SET FDAPRT=$$SELPRT^PSOFDAUT($PIECE($GET(PSOFDAPT),"^"))
+4 IF FDAPRT=""
WRITE $CHAR(7),!,"You must select a valid FDA Medication Guide printer."
End DoDot:2
if FDAPRT'=""
QUIT
+5 IF FDAPRT'=""
IF (FDAPRT'="^")
SET PSOFDAPT=FDAPRT
End DoDot:1
IF FDAPRT="^"!($GET(PSOFDAPT)="")
SET POP=1
GOTO EXIT
+6 QUIT
+7 ;
PRT ; Print labels.
+1 DO NOW^%DTC
SET DTTM=%
KILL %
+2 ;gather patient RXs, print patient RXs
SET NM=""
FOR
SET NM=$ORDER(^PSX(550.2,PSXBAT,15,"C",NM))
if NM=""
QUIT
DO DFN
DO PPL
+3 SET DIK="^PSX(550.2,"
SET DA=PSXBAT
DO ^DIK
KILL PSXBAT
+4 KILL CHKDT,CIND,DAYS,DRUG,DRUGCHK,NFLAG,NM,ORD,PDT,PHARCLK,PHY,PSTAT,PTRA,PTRB,QTY,REL,RXERR,RXF,SFN,SIG,SITE,SUS,SUSPT
+5 QUIT
+6 ;
DFN SET DFN=0
SET NFLAG=2
+1 FOR
SET DFN=$ORDER(^PSX(550.2,PSXBAT,15,"C",NM,DFN))
SET RXN=0
if (DFN="")!(DFN'>0)
QUIT
Begin DoDot:1
+2 FOR
SET RXN=$ORDER(^PSX(550.2,PSXBAT,15,"C",NM,DFN,RXN))
SET RXF=""
if (RXN="")!(RXN'>0)
QUIT
Begin DoDot:2
+3 FOR
SET RXF=$ORDER(^PSX(550.2,PSXBAT,15,"C",NM,DFN,RXN,RXF))
if RXF=""
QUIT
DO BLD
End DoDot:2
End DoDot:1
+4 QUIT
+5 ;
BLD ;
+1 SET BATRXDA=$ORDER(^PSX(550.2,PSXBAT,15,"B",RXN,0))
DO NOW^%DTC
SET DTTM=%
+2 SET REC=$PIECE(^PSX(550.2,PSXBAT,15,BATRXDA,0),U,5)
SET SUS=$ORDER(^PS(52.5,"B",RXN,0))
+3 ;rx still valid in suspense
IF SUS=REC
IF +SUS'=0
IF 1
+4 ;rx gone
IF '$TEST
Begin DoDot:1
+5 NEW DA,DIK
SET DIK=550.2
SET DA(1)=PSXBAT
SET DA=BATRXDA
+6 DO ^DIK
End DoDot:1
QUIT
+7 SET PSOSU(DFN,SUS)=RXN
SET RXCNTR=$GET(RXCNTR)+1
SET NFLAG=2
+8 SET $PIECE(^PSRX(RXN,0),U,15)=0
SET $PIECE(^PSRX(RXN,"STA"),U,1)=0
+9 KILL %
SET COM="CMOP Suspense Label "_$SELECT($GET(^PS(52.5,SUS,"P"))=0:"Printed",$GET(^PS(52.5,SUS,"P"))="":"Printed",1:"Reprinted")_$SELECT($GET(^PSRX(RXN,"TYPE"))>0:" (PARTIAL)",1:"")
+10 DO EN^PSOHLSN1(RXN,"SC","ZU",COM)
+11 SET DA=SUS
DO DQUE
KILL DA
ACTLOG FOR JJ=0:0
SET JJ=$ORDER(^PSRX(RXN,"A",JJ))
if 'JJ
QUIT
SET CNT=JJ
+1 SET RFCNT=0
FOR RF=0:0
SET RF=$ORDER(^PSRX(RXN,1,RF))
if 'RF
QUIT
SET RFCNT=$SELECT(RF<6:RF,1:RF+1)
+2 SET CNT=CNT+1
SET ^PSRX(RXN,"A",0)="^52.3DA^"_CNT_"^"_CNT
LOCK LOCK +^PSRX(RXN):600
if '$TEST
GOTO LOCK
+1 SET ^PSRX(RXN,"A",CNT,0)=DTTM_"^S^"_DUZ_"^"_RFCNT_"^"_COM
LOCK -^PSRX(RXN)
+2 KILL CNT,COM,RFCNT,%,JJ,RF,Y,RXCNTR
+3 QUIT
+4 ;
PPL KILL PPL,PPL1
SET ORD=""
FOR
SET ORD=$ORDER(PSOSU(ORD))
if (ORD="")!(ORD'>0)
QUIT
DO PPL1
+1 QUIT
+2 ;
PPL1 ; print patient labels
+1 FOR SFN=0:0
SET SFN=$ORDER(PSOSU(ORD,SFN))
if 'SFN
QUIT
Begin DoDot:1
+2 if $LENGTH($GET(PPL))<240
SET PPL=$PIECE(PSOSU(ORD,SFN),"^")_","_$GET(PPL)
+3 if $LENGTH($GET(PPL))>239
SET PPL1=$PIECE(PSOSU(ORD,SFN),"^")_","_$GET(PPL1)
+4 SET DFN=$PIECE(^PS(52.5,SFN,0),"^",3)
End DoDot:1
+5 SET SUSPT=1
SET PSNP=$SELECT($PIECE(PSOPAR,"^",8):1,1:0)
if $DATA(PSOPROP)
SET PFIO=PSOPROP
+6 DO QLBL^PSORXL
+7 IF $DATA(PPL1)
SET PSNP=0
SET PPL=PPL1
DO QLBL^PSORXL
+8 KILL PPL,PPL1,PSOSU(ORD)
+9 QUIT
+10 ;
DQUE ; sets the CMOP indicator field, and printed field in 52.5
+1 LOCK +^PS(52.5,REC):600
if '$TEST
GOTO DQUE
+2 IF NFLAG=4
Begin DoDot:1
+3 ; the rest moved into PSXRTR
SET DA=REC
SET DIE="^PS(52.5,"
SET DR="3////L;4////"_DT
DO ^DIE
KILL DIE,DA,DR
LOCK -^PS(52.5,REC)
End DoDot:1
+4 SET CIND=$SELECT(NFLAG=1:"X",NFLAG=2:"P",NFLAG=3:"@",1:0)
+5 IF $GET(NFLAG)'=2
Begin DoDot:1
+6 SET DA=REC
SET DIE="^PS(52.5,"
SET DR="3////"_CIND_";4////"_DT
+7 DO ^DIE
KILL DIE,DA,DR
+8 SET ^PS(52.5,REC,"P")=1
SET ^PS(52.5,"ADL",DT,REC)=""
End DoDot:1
+9 ;print label cycle
IF $GET(NFLAG)=2
Begin DoDot:1
+10 SET DA=REC
SET DIE="^PS(52.5,"
SET DR="3////"_CIND_";4////"_DTTM_";5////"_DUZ_";7////"_RXCNTR
+11 DO ^DIE
KILL DIE,DA,DR
+12 SET ^PS(52.5,REC,"P")=1
SET ^PS(52.5,"ADL",$EXTRACT($PIECE(^PS(52.5,REC,0),"^",8),1,7),REC)=""
End DoDot:1
+13 LOCK -^PS(52.5,REC)
+14 IF $GET(NFLAG)=2
DO EN^PSOHLSN1(RXN,"SC","ZU","CMOP Suspense Label Printed")
+15 QUIT
+16 ;
RX550215 ; put RX into RX multiple TRANS 550.215 for PSXBAT
+1 ; first time through create batch, & return PSXBAT
IF '$GET(PSXBAT)
DO BATCH^PSXRSYU
+2 KILL DD,DO,DIC,DA,DR,D0
+3 if '$DATA(^PSX(550.2,PSXBAT,15,0))
SET ^PSX(550.2,PSXBAT,15,0)="^550.215P^^"
+4 SET X=RXN
SET DA(1)=PSXBAT
+5 SET DIC="^PSX(550.2,"_PSXBAT_",15,"
SET DIC("DR")=".02////^S X=RXF;.03////^S X=DFN;.05////^S X=REC"
SET DIC(0)="ZF"
+6 DO FILE^DICN
+7 ;RX DA within PSXBAT 'T'ransmission
SET PSXRXTDA=+Y
+8 KILL DD,DO,DIC,DA,DR,D0
+9 QUIT
+10 ;
OERRLOCK(RXN) ; set XTMP for OERR/CPRS order locking
+1 IF $GET(PSXBAT)
IF $GET(RXN)
IF $GET(PSXRXTDA)
IF 1
+2 IF '$TEST
QUIT
+3 IF $PIECE(^PSX(550.2,PSXBAT,15,PSXRXTDA,0),U,1)'=RXN
QUIT
RXNSET ; set ^XTMP("ORLK-"_ORDER per IA 4001 needs RXN
+1 if '$GET(RXN)
QUIT
+2 NEW ORD,NOW,NOW1
SET ORD=+$PIECE($GET(^PSRX(+$GET(RXN),"OR1")),"^",2)
+3 if 'ORD
QUIT
+4 SET NOW=$$NOW^XLFDT
SET NOW1=$$FMADD^XLFDT(NOW,1)
+5 SET ^XTMP("ORLK-"_+ORD,0)=NOW1_U_NOW_"^CPRS/CMOP RX/Order Lock"
SET ^(1)=DUZ_U_$JOB
+6 QUIT
+7 ;
RXNCLEAR ; needs RXN
+1 if '$GET(RXN)
QUIT
+2 NEW ORD
SET ORD=+$PIECE($GET(^PSRX(+$GET(RXN),"OR1")),"^",2)
if 'ORD
QUIT
+3 IF $DATA(^XTMP("ORLK-"_ORD,0))
IF ^(0)["CPRS/CMOP"
KILL ^XTMP("ORLK-"_ORD)
+4 QUIT
+5 ;
