PSXRPPL.m

PSXRPPL ;BIR/WPB,BAB-Gathers data for the CMOP Transmission ;29-Apr-2013 09:58;PLS

 ;;2.0;CMOP;**3,23,33,28,40,42,41,48,62,58,66,65,1015**;11 Apr 97;Build 62

 ;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 ^PSOBPSUT supported by DBIA #4701

 ;Reference to ^PSOREJUT supported by DBIA #4706

 ;Reference to ^BPSUTIL supported by DBIA #4410

 ;Reference to ^PSOREJU3 supported by DBIA #5186

 ;

 ;Modified - IHS/MSC/PLS - 05/28/2010 - Line SDT+4

 ;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),ZCNT,PSXBAT D:$D(XRTL) T0^%ZOSV

 S PSXTDIV=PSOSITE,PSXTYP=$S(+$G(PSXCS):"C",1:"N")

 ;

 ; - Submitting prescriptions to ECME (Electronic Claims Mgmt Engine) - 3rd pary

 ;IHS/MSC/PLS - 05/28/2010 - The next four lines have been commented out

 ;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))

 ;

 ; - Transmitting prescription to CMOP (up to THROUGH DATE)

 K ^TMP("PSXEPHIN",$J)

 S SDT=0 F  S SDT=$O(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT)) S XDFN=0 Q:(SDT>PRTDT)!(SDT'>0)  D

 . F  S XDFN=$O(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,XDFN)) S 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)

 ;

 ; - Pulling prescriptions ahead (parameter in OUTPATIENT SITE file #59)

 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,NDFN,%,CNT,COM,DTTM,FILL,JJ,PRTDT,PSXDIV,XDFN,NFLAG,CIND,XDFN

 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") D EPHARM^PSXRPPL2 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

 ;the rest of the sub-routines go through the ^PSX(550.2,,15,"C"

 ;global and checks for RXs within the days ahead range and

 ;builds the ^PSX(550.2,PSXBAT,

CHKDFN ; use the patient 'C' index under RX multiple in file 550.2 to GET dfn to gather Patients' future RXs

 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)),NDFN=0 Q:(SDT>PSXDTRG)!(SDT="")  D

 . . . F  S NDFN=$O(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,NDFN)),REC=0 Q:NDFN'>0  I NDFN=XDFN D

 . . . . F  S REC=$O(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,NDFN,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) Q

 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

 Q

PRT ; w auto error trapping

 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

PSXRPPL   ;BIR/WPB,BAB-Gathers data for the CMOP Transmission ;29-Apr-2013 09:58;PLS

 +1       ;;2.0;CMOP;**3,23,33,28,40,42,41,48,62,58,66,65,1015**;11 Apr 97;Build 62

 +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 ^PSOBPSUT supported by DBIA #4701

 +12      ;Reference to ^PSOREJUT supported by DBIA #4706

 +13      ;Reference to ^BPSUTIL supported by DBIA #4410

 +14      ;Reference to ^PSOREJU3 supported by DBIA #5186

 +15      ;

 +16      ;Modified - IHS/MSC/PLS - 05/28/2010 - Line SDT+4

 +17      ;Called from PSXRSUS -Builds ^PSX(550.2,,15,"C" , and returns to PSXRSUS or PSXRTRAN

 +18      ;

SDT        KILL ^TMP($JOB,"PSX"),^TMP($JOB,"PSXDFN"),^TMP("PSXEPHNB",$JOB),ZCNT,PSXBAT

           IF $DATA(XRTL)

               DO T0^%ZOSV

 +1        SET PSXTDIV=PSOSITE

           SET PSXTYP=$SELECT(+$GET(PSXCS):"C",1:"N")

 +2       ;

 +3       ; - Submitting prescriptions to ECME (Electronic Claims Mgmt Engine) - 3rd pary

 +4       ;IHS/MSC/PLS - 05/28/2010 - The next four lines have been commented out

 +5       ;I $$ECMEON^BPSUTIL(PSXTDIV),$$CMOPON^BPSUTIL(PSXTDIV) D

 +6       ;. N BPSCNT S BPSCNT=$$SBTECME^PSXRPPL1(PSXTYP,PSXTDIV,PRTDT,PSXDTRG)

 +7       ;. ; - Wait 15 seconds per prescription sent to ECME (max of 2 hours)

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

 +9       ;

 +10      ; - Transmitting prescription to CMOP (up to THROUGH DATE)

 +11       KILL ^TMP("PSXEPHIN",$JOB)

 +12       SET SDT=0

           FOR 

               SET SDT=$ORDER(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT))

               SET XDFN=0

               IF (SDT>PRTDT)!(SDT'>0)

                   QUIT 

               Begin DoDot:1

 +13               FOR 

                       SET XDFN=$ORDER(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,XDFN))

                       SET REC=0

                       IF (XDFN'>0)!(XDFN="")

                           QUIT 

                       Begin DoDot:2

 +14                       FOR 

                               SET REC=$ORDER(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,XDFN,REC))

                               IF (REC'>0)!(REC="")

                                   QUIT 

                               Begin DoDot:3

 +15                               DO GETDATA

                                   IF $GET(RXN)

                                       DO PSOUL^PSSLOCK(RXN)

                                       DO OERRLOCK(RXN)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +16      ;

 +17      ; - Pulling prescriptions ahead (parameter in OUTPATIENT SITE file #59)

 +18       IF $GET(PSXBAT)

               IF '$GET(PSXRTRAN)

                   DO CHKDFN^PSXRPPL2(PRTDT)

 +19       IF $GET(PSXBAT)

               IF '$GET(PSXRTRAN)

                   DO CHKDFN

 +20      ;

 +21      ; - Sends a Mailman message if there were transmission problems with the 3rd Party Payer

 +22       IF $DATA(^TMP("PSXEPHIN",$JOB))

               DO ^PSXBPSMS

               KILL ^TMP("PSXEPHIN",$JOB),^TMP("PSXEPHNB",$JOB)

 +23      ;

EXIT      ;

 +1        KILL SDT,DFN,REC,RXNUM,PSXOK,FILNUM,REF,PNAME,CNAME,DIE,DR,NDFN,%,CNT,COM,DTTM,FILL,JJ,PRTDT,PSXDIV,XDFN,NFLAG,CIND,XDFN

 +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 

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

           SET EPHQT=0

 +19       IF $$PATCH^XPDUTL("PSO*7.0*148")

               DO EPHARM^PSXRPPL2

               IF EPHQT

                   QUIT 

 +20       DO CHKDATA^PSXMISC1

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       ;the rest of the sub-routines go through the ^PSX(550.2,,15,"C"

 +7       ;global and checks for RXs within the days ahead range and

 +8       ;builds the ^PSX(550.2,PSXBAT,

CHKDFN    ; use the patient 'C' index under RX multiple in file 550.2 to GET dfn to gather Patients' future RXs

 +1        IF '$DATA(^PSX(550.2,PSXBAT,15,"C"))

               QUIT 

 +2        SET PSXPTNM=""

           FOR 

               SET PSXPTNM=$ORDER(^PSX(550.2,PSXBAT,15,"C",PSXPTNM))

               IF PSXPTNM=""

                   QUIT 

               Begin DoDot:1

 +3                SET XDFN=0

                   FOR 

                       SET XDFN=$ORDER(^PSX(550.2,PSXBAT,"15","C",PSXPTNM,XDFN))

                       IF (XDFN'>0)

                           QUIT 

                       Begin DoDot:2

 +4                        SET SDT=PRTDT

                           FOR 

                               SET SDT=$ORDER(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT))

                               SET NDFN=0

                               IF (SDT>PSXDTRG)!(SDT="")

                                   QUIT 

                               Begin DoDot:3

 +5                                FOR 

                                       SET NDFN=$ORDER(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,NDFN))

                                       SET REC=0

                                       IF NDFN'>0

                                           QUIT 

                                       IF NDFN=XDFN

                                           Begin DoDot:4

 +6                                            FOR 

                                                   SET REC=$ORDER(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,NDFN,REC))

                                                   IF REC'>0

                                                       QUIT 

                                                   Begin DoDot:5

 +7                                                    DO GETDATA

                                                       IF $GET(RXN)

                                                           DO PSOUL^PSSLOCK(RXN)

                                                           DO OERRLOCK(RXN)

                                                   End DoDot:5

                                           End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +8        QUIT 

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

PROFILE    IF $DATA(PSOPROP)

               IF ($GET(PSOPROP)'=ION)

                   QUIT 

 +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        QUIT 

PRT       ; w auto error trapping

 +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 

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 

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 

PPL        KILL PPL,PPL1

           SET ORD=""

           FOR 

               SET ORD=$ORDER(PSOSU(ORD))

               IF (ORD="")!(ORD'>0)

                   QUIT 

               DO PPL1

 +1        QUIT 

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 

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