PSORXL.m

PSORXL ;BHAM ISC/SAB - action to be taken on prescriptions ;28-Mar-2013 16:45;DU

 ;;7.0;OUTPATIENT PHARMACY;**8,21,24,32,47,135,1008,1013,148,287,1015**;DEC 1997;Build 62

 ;External reference to File #50 supported by DBIA 221

 ;External references CHPUS^IBACUS and TRI^IBACUS supported by DBIA 2030

 ; Modified - IHS/CIA/PLS - 12/23/2003 - Line QLBL+2 and P1

 ;            IHS/MSC/PLS - 04/30/2009 - Line PSORXL+12

 ;                        - 11/04/2011 - Line PSORXL+9

 I $G(PSOTRVV),$G(PPL) S PSORX("PSOL",1)=PPL K PPL

 N SLBL,PSOSONE,PSOKLRXS

 N APSPPRIO

 D APRTY^APSPFUNC

 ; IHS/CIA/PLS - 03/24/04 - Removed conditional call to label prompt

 ;S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$P(PSOPAR,"^",26) P

 S:'$G(PPL) PPL=$G(PSORX("PSOL",1))

 D SAVEPRI(PPL)  ;IHS/MSC/PLS - 11/04/11 - P13

 I '$$GET1^DIQ(9009033,+$G(PSOSITE),316,"I") D ^APSPNE4 Q  ; IHS/CIA/PLS - 01/18/04 - Call IHS Label prompt

 D CHKFDT^APSPFUNC(.PPL) S PSORX("PSOL",1)=PPL  ;IHS/MSC/PLS - 04/30/09 - Remove RXs with future fill dates

 I 'PPL,'$D(RXRS) D  Q

 .W !!,"No other labels to print. Exiting..."

LBL ;

 I $G(PPL) N PSOCKDC S PSOCKDC=1 D ECME^PSORXL1 I '$G(PPL) S PPL="" Q  ;don't prompt to print labels for DC'ed Rx's

 W !! S DIR("A",1)="Label Printer: "_$S($G(SUSPT):PSLION,1:$G(PSOLAP))

 S DIR("A")="LABEL: QUEUE/CHANGE PRINTER"_$S($P(PSOPAR,"^",23):"/HOLD",1:"")_$S($P(PSOPAR,"^",24):"/SUSPEND",1:"")_$S($P(PSOPAR,"^",26):"/LABEL",1:"")_" or '^' to bypass "

 S DIR("?",1)="Enter 'Q' to queue labels to print",DIR("?")="Enter '^' to bypass label functions",DIR("?",4)="Enter 'S' to suspend labels to print later"

 S DIR("?",2)="Enter 'H' to hold label until Rx can be filled",DIR("?",3)="Enter 'P' for Rx profile"

 S DIR("?",5)="Enter 'C' to select another label printer"

 S:$P(PSOPAR,"^",26) DIR("?",5)="Enter 'L' to print labels without queuing"

TRI ;Tricare

 S X="IBACUS" X ^%ZOSF("TEST") K X I '$T G PASS

 I '$$TRI^IBACUS() G PASS

 I '$D(PSORX("PSOL",1))!($G(PSOSUREP))!($G(PSOEXREP)) G PASS

 N GGG,PBILL,PSTRD,PSTRDZ,PSTRF,PSTRP,TRXI,TRIRX,PSTRIVAR,VV,VVV,VVCT

 D DEV^PSOCPTRI

 K ^TMP($J,"PSONOB"),^TMP($J,"PSOBILL")

 S VVCT=0 F VV=0:0 S VV=$O(PSORX("PSOL",VV)) Q:'VV  F VVV=1:1 S TRXI=$P(PSORX("PSOL",VV),",",VVV) Q:'TRXI  D

 .I '$G(DT) S DT=$$DT^XLFDT

 .I $P($G(^PSRX(+TRXI,"STA")),"^")=3 Q

 .S PSTRP=$P($G(^PSRX(+TRXI,0)),"^",2),PSTRD=+$G(PSOSITE),PSTRDZ=+$G(DUZ)

 .S PSTRF=0 F GGG=0:0 S GGG=$O(^PSRX(+TRXI,1,GGG)) Q:'GGG  S PSTRF=GGG

 .S VVCT=VVCT+1

 .I $G(RXRP(TRXI))!($G(RXPR(TRXI)))!($G(RXRH(TRXI))) S ^TMP($J,"PSONOB",VVCT)=TRXI Q

 .S PBILL=$$CHPUS^IBACUS(PSTRP,DT,TRXI,PSTRF,PSOLAP,PSTRD,PSTRDZ) S ^TMP($J,$S($G(PBILL):"PSOBILL",1:"PSONOB"),VVCT)=TRXI

 I '$D(^TMP($J,"PSOBILL")) K ^TMP($J,"PSONOB") G PASS

 I '$D(^TMP($J,"PSONOB")),$D(^TMP($J,"PSOBILL")) S (Y,LBL)="H" G H1

 ;If some Rx's are billable, and some are not

SETP K PSORX("PSOL"),PPL S VVCT=1 F VV=0:0 S VV=$O(^TMP($J,$S($G(PSTRIVAR):"PSONOB",1:"PSOBILL"),VV)) Q:'VV  S TRIRX=^TMP($J,$S($G(PSTRIVAR):"PSONOB",1:"PSOBILL"),VV) I +TRIRX D

 .I $G(PSORX("PSOL",1))="" S PSORX("PSOL",1)=TRIRX_"," Q

 .I $L(PSORX("PSOL",VVCT))+$L(TRIRX)<220 S PSORX("PSOL",VVCT)=PSORX("PSOL",VVCT)_TRIRX_"," Q

 .S VVCT=VVCT+1 S PSORX("PSOL",VVCT)=TRIRX_","

 I '$G(PSTRIVAR) S (Y,LBL)="H" S PSOKLRXS=1 K PSORSAVE,PSOPSAVE,PSOHSAVE D RSAVE D H1 D RREST K PSORSAVE,PSOPSAVE,PSOHSAVE K PSOKLRXS S PSTRIVAR=1 G SETP

 K ^TMP($J,"PSONOB") S PPL=$G(PSORX("PSOL",1))

PASS ;

 I $E($G(DIR("A")),1,6)'="LABEL:" D RESDIR^PSOCPTRI

 S DIR(0)="SA^P:PROFILE;Q:QUEUE;C:CHANGE PRINTER"_$S($P(PSOPAR,"^",23):";H:HOLD",1:"")_$S($P(PSOPAR,"^",24):";S:SUSPENSE",1:"")_$S($P(PSOPAR,"^",26):";L:PRINT",1:""),DIR("B")="Q" D ^DIR D  G:$D(DIRUT)!($D(DUOUT)) EX

 .I $D(DIRUT)!($D(DUOUT)) D AL^PSOLBL("UT") I $G(PSOEXREP) S PSOEXREX=1

 .I $G(PSOPULL) I $D(DIRUT)!($D(DUOUT)) S PSOQFLAG=1

 S:$G(PSOBEDT) NOPP=Y

 I $G(Y)="C" K PSOCLBL,%ZIS("B") S PSOCLBL=1 D @$S('$D(PSOPAR):"^PSOLSET",1:"PLBL^PSOLSET") K PSOCLBL G LBL

 I $G(Y)="Q",$D(RXRS),'$G(PSOPULL) D PPLADD^PSOSUPOE

 I $G(PSXSYS),($G(Y)'="H"),($G(Y)'="P"),('$G(PSOEXREP)) S LBL=Y,(RXLTOP,PPL1)=1 S:'$G(PSOPULL) SLBL=Y D A^PSOCMOP G:'$G(PPL) D1

 K DIR S LBL=Y S:'$G(PSOPULL) SLBL=Y G Q:Y="Q",S:Y="S",H1:Y="H",P:Y="L" I Y="P" W ! S PSDFN=DFN,PSFROM="" D ^PSODSPL K PSDFN,PSFROM G LBL

EX I $D(DUOUT)!$D(DIRUT) K BINGCRT,BINGRTE,BBRX,BBFLG S:$D(RXRS) SLBL="^" G:$D(RXRS) RXS K DIR,X,DIRUT,DUOUT,ACT,Y,DTOUT,PPL,REPRINT S NOBG=1 Q

Q S PPL1=1 G:$G(PPL)']"" D1 S PSNP=0,PSL=1 D  I $G(PSOFROM)="NEW",$P(PSOPAR,"^",8) S PSNP=1

 .Q:'$P(PSOPAR,"^",8)!($G(PSONOPRT))

 .F SLPPL=0:0 S SLPPL=$O(RXRS(SLPPL)) Q:'SLPPL!($G(PSNP))  I '$O(^PSRX(SLPPL,1,0)),'$D(RXPR(SLPPL)) S PSNP=1

 I $G(PSOLAP)]"",$G(PSOLAP)'=ION G QLBL

Q1 W ! K POP S %ZIS("B")="",%ZIS="MNQ",%ZIS("A")="Select LABEL DEVICE: " D ^%ZIS S PSLION=ION K %ZIS("A") Q:$G(POP)&($G(PSPARTXX))  G:$G(POP)&($G(PSOSONE)) RXSQ D:$G(POP)&($G(PSONOPRT))  Q:$G(PSOQFLAG)  G:POP!(IO=IO(0)) LBL S PSOLAP=ION

 .S PSOQFLAG=1

 N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST

 S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10)

 D ^%ZISC S PSL=0

QLBL I $G(PSXSYS),('$G(RXLTOP)),('$G(PSOEXREP)) D RXL^PSOCMOP G:'$G(PPL) D1

 ;

 ;- Submitting list of Rx to ECME for DUR/79 REJECT check and possible submission to 3rd Pary Payer

 D ECME^PSORXL1 I '$G(PPL) W !!,"No Label(s) printed.",!! S PSOQFLAG=1 Q

 ;

 ; IHS/CIA/PLS - 12/23/2003 - Direct to IHS label routine

 ;S ZTRTN="DQ^PSOLBL",ZTIO=$S($G(SUSPT):PSLION,1:PSOLAP),ZTDESC="Outpatient Pharmacy "_$S($G(SUSPT):"SUSPENSE ",$G(DG):"DRUG INTERACTION ",1:"")_"LABELS OUTPUT ROUTINE",ZTDTH=$S($G(PSOTIME):PSOTIME,1:$H),PDUZ=DUZ

 S ZTRTN="DQ^APSPLBL",ZTIO=$S($G(SUSPT):PSLION,1:PSOLAP),ZTDESC="Outpatient Pharmacy "_$S($G(SUSPT):"SUSPENSE ",$G(DG):"DRUG INTERACTION ",1:"")_"LABELS OUTPUT ROUTINE",ZTDTH=$S($G(PSOTIME):PSOTIME,1:$H),PDUZ=DUZ

 F G="PPL1","PSOSYS","DFN","PSOPAR","PDUZ","PCOMX",$S($G(SUSPT):"PFION",1:"PSOLAP"),"PPL","PSOSITE","RXY","COPIES","SIDE","PSOSUSPR","PSOBARS","PSOBAR1","PSOBAR0","PSODELE","PSOPULL","PSTAT","PSODBQ","PSOEXREP","PSOTREP" S:$D(@G) ZTSAVE(G)=""

 ; IHS/CIA/PLS - 12/23/03 - Save additional variables

 F G="%APSITE","APSPMAN","APSPZRP","DUZ","PSOFROM","%APSITE","APSQSGLB","APSPREIS" S:$D(@G) ZTSAVE(G)=""

 S ZTSAVE("P*")=""

 S ZTSAVE("PSORX(")="",ZTSAVE("RXRP(")="",ZTSAVE("RXPR(")="",ZTSAVE("RXRS(")="",ZTSAVE("RXFL(")="",ZTSAVE("PCOMH(")=""

 D ^%ZISC,^%ZTLOAD K:$G(PSOSONE) RXRS W:$D(ZTSK)&('$G(SUSPT))&('$G(PSOEXREP)) !!,"LABEL(S) QUEUED TO PRINT",!!

 Q:$G(PSPARTXX)  K G,PDUZ K:'$G(SUSPT) ZTSK Q:$G(DG)

 G:'$G(PSNP) QUEUP G:$G(PSOPRFLG) QUEUP S HOLDRPAS=$G(PSOPRPAS),PSOPRPAS=$P(PSOPAR,"^",13)

PLBL S PSOION=ION

 I '$D(PSOPROP)!($G(PSOPROP)=ION) W $C(7),!,"PROFILES MUST BE SENT TO PRINTER !!",! K IOP,%ZIS,IO("Q"),POP S %ZIS="MNQ",%ZIS("A")="Select PROFILE DEVICE: " D ^%ZIS K %ZIS("A") G:POP QUEUP G:$E(IOST)["C"!(PSOION=ION) PLBL S PSOPROP=ION

QPRF S ZTRTN="DQ^PSOPRF",ZTIO=PSOPROP,ZTDESC="Outpatient Pharmacy "_$S($G(SUSPT):"SUSPENSE ",1:"")_"PATIENT PROFILES",ZTDTH=$S($G(PSOTIME):PSOTIME,1:$H)

 F G="PSOPAR","PSODTCUT","PSOPRPAS","DFN","PSOSITE","NEW1","NEW11","PSOBMST","PFIO","PPL" S:$D(@G) ZTSAVE(G)=""

 D ^%ZTLOAD W:$D(ZTSK)&('$G(SUSPT))&('$G(PSOEXREP)) !,"PROFILE IS QUEUED TO PRINT",!! K G K:'$G(SUSPT) ZTSK D ^%ZISC

QUEUP D:$G(POP)&($G(PSONOPRT))  Q:$G(PSOQFLAG)  S PSNP=0,PSOPRPAS=$G(HOLDRPAS) K:PSOPRPAS']"" PSOPRPAS K HOLDRPAS G D1

 .S PSOQFLAG=1

 Q

 ;

S G S^PSORXL1

SUS S X="IBACUS" X ^%ZOSF("TEST") K X I '$T G SUSL1

 N TRIDA S TRIDA=DA I '$$TRI^IBACUS() S DA=TRIDA G SUSL1

 I $G(RXRP(TRIDA))!($G(RXPR(TRIDA)))!($G(RXRH(TRIDA))) S DA=TRIDA G SUSL1

 N PBILL,PSTRD,PSTRDZ,PSTRF,PSTRP,GGG

 D DEV^PSOCPTRI

 I '$G(DT) S DT=$$DT^XLFDT

 S PSTRP=$P($G(^PSRX(+TRIDA,0)),"^",2),PSTRD=+$G(PSOSITE),PSTRDZ=+$G(DUZ)

 S PSTRF=0 F GGG=0:0 S GGG=$O(^PSRX(+TRIDA,1,GGG)) Q:'GGG  S PSTRF=GGG

 S PBILL=$$CHPUS^IBACUS(PSTRP,DT,TRIDA,PSTRF,PSOLAP,PSTRD,PSTRDZ)

 I '$G(PBILL) S DA=TRIDA G SUSL1

 S FLD(99)="99",FLD(99.1)="Awaiting CHAMPUS billing approval"

 N RSDT,ACT,PSUS,RXF,RFN,I,PSDA,NOW,IR,FDA

 S DA=TRIDA D H^PSOCPTRH

 Q

SUSL1 G SUS^PSORXL1

H1 S PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1))

 D:'$D(^TMP($J,"PSOBILL")) NOOR^PSOHLD I $D(DIRUT) K DIRUT G PSORXL

 I $D(^TMP($J,"PSOBILL")) S FLD(99)="99",FLD(99.1)="Awaiting CHAMPUS billing approval" G H

 G:$G(PPL)']"" D1 D FLD^PSOHLD I $D(DUOUT)!($D(DIRUT)) K DIRUT,DUOUT,FLD,DIR G LBL

H K SPPL G:$D(DTOUT) D1 S SPPL="" F PI=1:1 Q:$P(PPL,",",PI)=""  D

 .S DA=$P(PPL,",",PI) I $P(^PSRX(DA,"STA"),"^")<10,$P(^("STA"),"^")'=4 D @$S($D(^TMP($J,"PSOBILL")):"H^PSOCPTRH",1:"H^PSOHLD") Q

 .I $P(^PSRX(DA,"STA"),"^")=4 S SPPL=SPPL_DA_"," Q

 I $G(SPPL)]"" D

 .W !!,$C(7),"Drug Interaction Rx(s) " F I=1:1 Q:$P(SPPL,",",I)=""  W $P(^PSRX($P(SPPL,",",I),0),"^")_", "

 .S PPL=SPPL,DG=1 D Q K DG,SPPL

D1 K RXLTOP I $G(PPL1),$O(PSORX("PSOL",$G(PPL1))) S PPL1=$O(PSORX("PSOL",PPL1)),PPL=PSORX("PSOL",PPL1) G @$S(LBL="H":"H",LBL="L":"P1",1:"QLBL")

RXS I $D(RXRS),'$G(PSOKLRXS) I $G(SLBL)="H"!($G(SLBL)="S")!($G(SLBL)="^")!($G(SLBL)="") D  G:$G(PPL)'="" Q

 .K PPL,PSORX("PSOL") S PSOSONE=1 D PPLADD^PSOSUPOE

 .Q:$G(PPL)=""  W !!,"You have selected the following Rx(s) to be pulled from suspense:",!

 .F RXSS=0:0 S RXSS=$O(RXRS(RXSS)) Q:'RXSS  W !," Rx # ",$P($G(^PSRX(+$G(RXSS),0)),"^"),?23,$P($G(^PSDRUG(+$P($G(^PSRX(+$G(RXSS),0)),"^",6),0)),"^")

 .K DIR W ! S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you still want to pull these Rx(s) from suspense" D ^DIR K DIR I Y'=1 W !!,"Rx(s) will remain in Suspense!",! D RESET^PSOSUPOE K RXRS,PPL

 K:'$G(PSOKLRXS) RXRS K ^TMP($J,"PSOBILL"),RXPR,RXRP,RXRH,RXSS,LBL,PPL1,PPL,DIR,%DT,%,SD,COUNT,EXDT,L,PDUZ,REF,REPRINT,RFDATE,RFL1,RFLL,RXN,WARN,ZY,FLD,PI,ZD,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT Q

P S PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$G(PPL)']"" D1

 I $G(PSOLAP)']"" W ! K POP,ZTSK S %ZIS="M",%ZIS("A")="Select LABEL DEVICE: " D ^%ZIS K %ZIS("A") G:POP LBL S PSOLAP=ION

PZ S IOP=PSOLAP D ^%ZIS   ; IHS/CIA/PLS - 12/23/03 - PZ line label added

 I POP W !,"The label printer is busy, do you want to wait? " S %=1 D YN^DICN K POP Q:%=2  K %,%Y G PZ   ; IHS/CIA/PLS - 12/23/03 Wait for busy printer prompt.

 N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST

P1 ; IHS/CIA/PLS - 12/23/03 - Call IHS Label routine

 ;S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10),PDUZ=DUZ D DQ1^PSOLBL,^%ZISC

 S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10),PDUZ=DUZ D DQ1^APSPLBL,^%ZISC

 G:'$P(PSOPAR,"^",8)!(+$G(REPRINT))!($G(PSOFROM)'="NEW") D1 I $G(PSOPROP)']"" S PSOION=ION,%ZIS="M",%ZIS("A")="Select PROFILE DEVICE: " D ^%ZIS K %ZIS("A") G:POP D1 S PSOPROP=ION

 S IOP=PSOPROP D ^%ZIS D DQ^PSOPRF,^%ZISC G D1

 Q

RXSQ K RXRS G RXS

 Q

RSAVE N PMX

 S PMX="" F  S PMX=$O(RXRP(PMX)) Q:PMX=""  S PSORSAVE(PMX)=RXRP(PMX)

 S PMX="" F  S PMX=$O(RXPR(PMX)) Q:PMX=""  S PSOPSAVE(PMX)=RXPR(PMX)

 S PMX="" F  S PMX=$O(RXRH(PMX)) Q:PMX=""  S PSOHSAVE(PMX)=RXRH(PMX)

 Q

RREST N PMXZ

 S PMXZ="" F  S PMXZ=$O(PSORSAVE(PMXZ)) Q:PMXZ=""  S RXRP(PMXZ)=PSORSAVE(PMXZ)

 S PMXZ="" F  S PMXZ=$O(PSOPSAVE(PMXZ)) Q:PMXZ=""  S RXPR(PMXZ)=PSOPSAVE(PMXZ)

 S PSMX="" F  S PMXZ=$O(PSOHSAVE(PMXZ)) Q:PMXZ=""  S RXRH(PMXZ)=PSOHSAVE(PMXZ)

 Q

 ; Store Fill Priority

SAVEPRI(RXS) ;EP-

 N PPLARY,RX,LFN

 Q:'$L($G(RXS))

 D BPPLARY^APSPFUNC(RXS)

 S RX=0

 F  S RX=$O(PPLARY(RX)) Q:'RX  D

 .Q:'$D(^PSRX(RX,0))

 .S LFN=+$O(^(1,$C(1)),-1)

 .I LFN D  ;Refill

 ..S $P(^PSRX(RX,1,LFN,9999999),U,18)=APSPPRIO

 .E  D  ;

 ..S $P(^PSRX(RX,999999931),U,8)=APSPPRIO

 Q

PSORXL    ;BHAM ISC/SAB - action to be taken on prescriptions ;28-Mar-2013 16:45;DU

 +1       ;;7.0;OUTPATIENT PHARMACY;**8,21,24,32,47,135,1008,1013,148,287,1015**;DEC 1997;Build 62

 +2       ;External reference to File #50 supported by DBIA 221

 +3       ;External references CHPUS^IBACUS and TRI^IBACUS supported by DBIA 2030

 +4       ; Modified - IHS/CIA/PLS - 12/23/2003 - Line QLBL+2 and P1

 +5       ;            IHS/MSC/PLS - 04/30/2009 - Line PSORXL+12

 +6       ;                        - 11/04/2011 - Line PSORXL+9

 +7        IF $GET(PSOTRVV)

               IF $GET(PPL)

                   SET PSORX("PSOL",1)=PPL

                   KILL PPL

 +8        NEW SLBL,PSOSONE,PSOKLRXS

 +9        NEW APSPPRIO

 +10       DO APRTY^APSPFUNC

 +11      ; IHS/CIA/PLS - 03/24/04 - Removed conditional call to label prompt

 +12      ;S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$P(PSOPAR,"^",26) P

 +13       IF '$GET(PPL)

               SET PPL=$GET(PSORX("PSOL",1))

 +14      ;IHS/MSC/PLS - 11/04/11 - P13

           DO SAVEPRI(PPL)

 +15      ; IHS/CIA/PLS - 01/18/04 - Call IHS Label prompt

           IF '$$GET1^DIQ(9009033,+$GET(PSOSITE),316,"I")

               DO ^APSPNE4

               QUIT 

 +16      ;IHS/MSC/PLS - 04/30/09 - Remove RXs with future fill dates

           DO CHKFDT^APSPFUNC(.PPL)

           SET PSORX("PSOL",1)=PPL

 +17       IF 'PPL

               IF '$DATA(RXRS)

                   Begin DoDot:1

 +18                   WRITE !!,"No other labels to print. Exiting..."

                   End DoDot:1

                   QUIT 

LBL       ;

 +1       ;don't prompt to print labels for DC'ed Rx's

           IF $GET(PPL)

               NEW PSOCKDC

               SET PSOCKDC=1

               DO ECME^PSORXL1

               IF '$GET(PPL)

                   SET PPL=""

                   QUIT 

 +2        WRITE !!

           SET DIR("A",1)="Label Printer: "_$SELECT($GET(SUSPT):PSLION,1:$GET(PSOLAP))

 +3        SET DIR("A")="LABEL: QUEUE/CHANGE PRINTER"_$SELECT($PIECE(PSOPAR,"^",23):"/HOLD",1:"")_$SELECT($PIECE(PSOPAR,"^",24):"/SUSPEND",1:"")_$SELECT($PIECE(PSOPAR,"^",26):"/LABEL",1:"")_" or '^' to bypass "

 +4        SET DIR("?",1)="Enter 'Q' to queue labels to print"

           SET DIR("?")="Enter '^' to bypass label functions"

           SET DIR("?",4)="Enter 'S' to suspend labels to print later"

 +5        SET DIR("?",2)="Enter 'H' to hold label until Rx can be filled"

           SET DIR("?",3)="Enter 'P' for Rx profile"

 +6        SET DIR("?",5)="Enter 'C' to select another label printer"

 +7        IF $PIECE(PSOPAR,"^",26)

               SET DIR("?",5)="Enter 'L' to print labels without queuing"

TRI       ;Tricare

 +1        SET X="IBACUS"

           XECUTE ^%ZOSF("TEST")

           KILL X

           IF '$TEST

               GOTO PASS

 +2        IF '$$TRI^IBACUS()

               GOTO PASS

 +3        IF '$DATA(PSORX("PSOL",1))!($GET(PSOSUREP))!($GET(PSOEXREP))

               GOTO PASS

 +4        NEW GGG,PBILL,PSTRD,PSTRDZ,PSTRF,PSTRP,TRXI,TRIRX,PSTRIVAR,VV,VVV,VVCT

 +5        DO DEV^PSOCPTRI

 +6        KILL ^TMP($JOB,"PSONOB"),^TMP($JOB,"PSOBILL")

 +7        SET VVCT=0

           FOR VV=0:0

               SET VV=$ORDER(PSORX("PSOL",VV))

               IF 'VV

                   QUIT 

               FOR VVV=1:1

                   SET TRXI=$PIECE(PSORX("PSOL",VV),",",VVV)

                   IF 'TRXI

                       QUIT 

                   Begin DoDot:1

 +8                    IF '$GET(DT)

                           SET DT=$$DT^XLFDT

 +9                    IF $PIECE($GET(^PSRX(+TRXI,"STA")),"^")=3

                           QUIT 

 +10                   SET PSTRP=$PIECE($GET(^PSRX(+TRXI,0)),"^",2)

                       SET PSTRD=+$GET(PSOSITE)

                       SET PSTRDZ=+$GET(DUZ)

 +11                   SET PSTRF=0

                       FOR GGG=0:0

                           SET GGG=$ORDER(^PSRX(+TRXI,1,GGG))

                           IF 'GGG

                               QUIT 

                           SET PSTRF=GGG

 +12                   SET VVCT=VVCT+1

 +13                   IF $GET(RXRP(TRXI))!($GET(RXPR(TRXI)))!($GET(RXRH(TRXI)))

                           SET ^TMP($JOB,"PSONOB",VVCT)=TRXI

                           QUIT 

 +14                   SET PBILL=$$CHPUS^IBACUS(PSTRP,DT,TRXI,PSTRF,PSOLAP,PSTRD,PSTRDZ)

                       SET ^TMP($JOB,$SELECT($GET(PBILL):"PSOBILL",1:"PSONOB"),VVCT)=TRXI

                   End DoDot:1

 +15       IF '$DATA(^TMP($JOB,"PSOBILL"))

               KILL ^TMP($JOB,"PSONOB")

               GOTO PASS

 +16       IF '$DATA(^TMP($JOB,"PSONOB"))

               IF $DATA(^TMP($JOB,"PSOBILL"))

                   SET (Y,LBL)="H"

                   GOTO H1

 +17      ;If some Rx's are billable, and some are not

SETP       KILL PSORX("PSOL"),PPL

           SET VVCT=1

           FOR VV=0:0

               SET VV=$ORDER(^TMP($JOB,$SELECT($GET(PSTRIVAR):"PSONOB",1:"PSOBILL"),VV))

               IF 'VV

                   QUIT 

               SET TRIRX=^TMP($JOB,$SELECT($GET(PSTRIVAR):"PSONOB",1:"PSOBILL"),VV)

               IF +TRIRX

                   Begin DoDot:1

 +1                    IF $GET(PSORX("PSOL",1))=""

                           SET PSORX("PSOL",1)=TRIRX_","

                           QUIT 

 +2                    IF $LENGTH(PSORX("PSOL",VVCT))+$LENGTH(TRIRX)<220

                           SET PSORX("PSOL",VVCT)=PSORX("PSOL",VVCT)_TRIRX_","

                           QUIT 

 +3                    SET VVCT=VVCT+1

                       SET PSORX("PSOL",VVCT)=TRIRX_","

                   End DoDot:1

 +4        IF '$GET(PSTRIVAR)

               SET (Y,LBL)="H"

               SET PSOKLRXS=1

               KILL PSORSAVE,PSOPSAVE,PSOHSAVE

               DO RSAVE

               DO H1

               DO RREST

               KILL PSORSAVE,PSOPSAVE,PSOHSAVE

               KILL PSOKLRXS

               SET PSTRIVAR=1

               GOTO SETP

 +5        KILL ^TMP($JOB,"PSONOB")

           SET PPL=$GET(PSORX("PSOL",1))

PASS      ;

 +1        IF $EXTRACT($GET(DIR("A")),1,6)'="LABEL:"

               DO RESDIR^PSOCPTRI

 +2        SET DIR(0)="SA^P:PROFILE;Q:QUEUE;C:CHANGE PRINTER"_$SELECT($PIECE(PSOPAR,"^",23):";H:HOLD",1:"")_$SELECT($PIECE(PSOPAR,"^",24):";S:SUSPENSE",1:"")_$SELECT($PIECE(PSOPAR,"^",26):";L:PRINT",1:"")

           SET DIR("B")="Q"

           DO ^DIR

           Begin DoDot:1

 +3            IF $DATA(DIRUT)!($DATA(DUOUT))

                   DO AL^PSOLBL("UT")

                   IF $GET(PSOEXREP)

                       SET PSOEXREX=1

 +4            IF $GET(PSOPULL)

                   IF $DATA(DIRUT)!($DATA(DUOUT))

                       SET PSOQFLAG=1

           End DoDot:1

           IF $DATA(DIRUT)!($DATA(DUOUT))

               GOTO EX

 +5        IF $GET(PSOBEDT)

               SET NOPP=Y

 +6        IF $GET(Y)="C"

               KILL PSOCLBL,%ZIS("B")

               SET PSOCLBL=1

               DO @$SELECT('$DATA(PSOPAR):"^PSOLSET",1:"PLBL^PSOLSET")

               KILL PSOCLBL

               GOTO LBL

 +7        IF $GET(Y)="Q"

               IF $DATA(RXRS)

                   IF '$GET(PSOPULL)

                       DO PPLADD^PSOSUPOE

 +8        IF $GET(PSXSYS)

               IF ($GET(Y)'="H")

                   IF ($GET(Y)'="P")

                       IF ('$GET(PSOEXREP))

                           SET LBL=Y

                           SET (RXLTOP,PPL1)=1

                           IF '$GET(PSOPULL)

                               SET SLBL=Y

                           DO A^PSOCMOP

                           IF '$GET(PPL)

                               GOTO D1

 +9        KILL DIR

           SET LBL=Y

           IF '$GET(PSOPULL)

               SET SLBL=Y

           IF Y="Q"

               GOTO Q

           IF Y="S"

               GOTO S

           IF Y="H"

               GOTO H1

           IF Y="L"

               GOTO P

           IF Y="P"

               WRITE !

               SET PSDFN=DFN

               SET PSFROM=""

               DO ^PSODSPL

               KILL PSDFN,PSFROM

               GOTO LBL

EX         IF $DATA(DUOUT)!$DATA(DIRUT)

               KILL BINGCRT,BINGRTE,BBRX,BBFLG

               IF $DATA(RXRS)

                   SET SLBL="^"

               IF $DATA(RXRS)

                   GOTO RXS

               KILL DIR,X,DIRUT,DUOUT,ACT,Y,DTOUT,PPL,REPRINT

               SET NOBG=1

               QUIT 

Q          SET PPL1=1

           IF $GET(PPL)']""

               GOTO D1

           SET PSNP=0

           SET PSL=1

           Begin DoDot:1

 +1            IF '$PIECE(PSOPAR,"^",8)!($GET(PSONOPRT))

                   QUIT 

 +2            FOR SLPPL=0:0

                   SET SLPPL=$ORDER(RXRS(SLPPL))

                   IF 'SLPPL!($GET(PSNP))

                       QUIT 

                   IF '$ORDER(^PSRX(SLPPL,1,0))

                       IF '$DATA(RXPR(SLPPL))

                           SET PSNP=1

           End DoDot:1

           IF $GET(PSOFROM)="NEW"

               IF $PIECE(PSOPAR,"^",8)

                   SET PSNP=1

 +3        IF $GET(PSOLAP)]""

               IF $GET(PSOLAP)'=ION

                   GOTO QLBL

Q1         WRITE !

           KILL POP

           SET %ZIS("B")=""

           SET %ZIS="MNQ"

           SET %ZIS("A")="Select LABEL DEVICE: "

           DO ^%ZIS

           SET PSLION=ION

           KILL %ZIS("A")

           IF $GET(POP)&($GET(PSPARTXX))

               QUIT 

           IF $GET(POP)&($GET(PSOSONE))

               GOTO RXSQ

           IF $GET(POP)&($GET(PSONOPRT))

               Begin DoDot:1

 +1                SET PSOQFLAG=1

               End DoDot:1

           IF $GET(PSOQFLAG)

               QUIT 

           IF POP!(IO=IO(0))

               GOTO LBL

           SET PSOLAP=ION

 +2        NEW PSOIOS

           SET PSOIOS=IOS

           DO DEVBAR^PSOBMST

 +3        SET PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$PIECE(PSOPAR,"^",10)

 +4        DO ^%ZISC

           SET PSL=0

QLBL       IF $GET(PSXSYS)

               IF ('$GET(RXLTOP))

                   IF ('$GET(PSOEXREP))

                       DO RXL^PSOCMOP

                       IF '$GET(PPL)

                           GOTO D1

 +1       ;

 +2       ;- Submitting list of Rx to ECME for DUR/79 REJECT check and possible submission to 3rd Pary Payer

 +3        DO ECME^PSORXL1

           IF '$GET(PPL)

               WRITE !!,"No Label(s) printed.",!!

               SET PSOQFLAG=1

               QUIT 

 +4       ;

 +5       ; IHS/CIA/PLS - 12/23/2003 - Direct to IHS label routine

 +6       ;SORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">S ZTRTN="DQ^PSORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SOLBL",ZTIO=$SORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">S($G(SORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SUSORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SPT):PSORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SLION,1:PSORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SOLAP),ZTDESORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SC="Outpatient Pharmacy "_$SORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">S($G(SORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SUSORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SPT):"SORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SUSORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SPENSORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SE ",$G(DG):"DRUG INTERACTION ",1:"")_"LABELSORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">S OUTPUT ROUTINE",ZTDTH=$SORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">S($G(PSORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SOTIME):PSORXL_source.html#xS">SORXL_source.html#xSORXL_source.html#xS">S">SORXL_source.html#xS">SOTIME,1:$H),PDUZ=DUZ

 +7        SET ZTRTN="DQ^APSPLBL"

           SET ZTIO=$SELECT($GET(SUSPT):PSLION,1:PSOLAP)

           SET ZTDESC="Outpatient Pharmacy "_$SELECT($GET(SUSPT):"SUSPENSE ",$GET(DG):"DRUG INTERACTION ",1:"")_"LABELS OUTPUT ROUTINE"