- 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 Jan 18, 2025@02:46:09 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 ;