- PSORXL ;BHAM ISC/SAB - action to be taken on prescriptions ; May 11, 2023@08:10:09
- ;;7.0;OUTPATIENT PHARMACY;**8,21,24,32,47,135,148,287,334,251,354,367,370,442,658,441,712**;DEC 1997;Build 20
- ;
- ; Reference to ^PSDRUG( in ICR #221
- ; Reference to CHPUS^IBACUS,TRI^IBACUS in ICR #2030
- ; Added kill for BINGRTE to force bypass of Bingo board prompt if choose H (Hold) or PK (Park) - PaPI ;441
- ;
- D PPLPARK^PSORXL1 I $G(PPL)="",'$O(RXRS(0)),$G(PSORX("PSOL",1))="" G RXSQUIT
- I $G(PSOTRVV),$G(PPL) S PSORX("PSOL",1)=PPL K PPL
- N SLBL,PSOSONE,PSOKLRXS,PSOSKIP S PSOSKIP=1
- S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$P(PSOPAR,"^",26) P
- LBL ;
- I $G(PPL) N PSOCKDC S PSOCKDC=1 D ECME^PSORXL1 I '$G(PPL) S PPL="" G RXSQUIT ;*334 ;don't prompt to print labels for DC'ed Rx's
- N RESULTS,PSOPARKX,PSOCNT
- S RESULTS="PSOPARKX" D GETPARK^PSORPC01()
- W !! S DIR("A",1)="Label Printer: "_$S($G(SUSPT):PSLION,1:$G(PSOLAP))
- I $$GET1^DIQ(59,PSOSITE,134)'="" D
- . I $G(PSOFDAPT)="" S PSOFDAPT=$$DEFPRT^PSOFDAUT(PSOSITE)
- . S DIR("A",2)="FDA Med Guide Printer: "_$S($G(PSOFDAPT)="":"HOME",1:$P(PSOFDAPT,"^"))
- S DIR("A")="LABEL: QUEUE/CHANGE PRINTER"_$S($P(PSOPAR,"^",23)&($D(^XUSEC("PSORPH",DUZ))!($D(^XUSEC("PSO TECH ADV",DUZ)))):"/HOLD",1:"")
- ;S DIR("A")=DIR("A")_$S($P(PSOPAR,"^",24):"/SUSPEND",1:"")_$S($P(PSOPAR,"^",26):"/LABEL",1:"")_$S($P(PSOPAR,"^",34):"/PARK(PK)",1:"")_" or '^' to bypass " ;papi 441
- S DIR("A")=DIR("A")_$S($P(PSOPAR,"^",24):"/SUSPEND",1:"")_$S($P(PSOPAR,"^",26):"/LABEL",1:"")_$S($G(PSOPARKX(0))="YES":"/PARK(PK)",1:"")_" or '^' to bypass " ;papi 441
- 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 'PR' for Rx profile"
- S PSOCNT=5
- I $G(PSOPARKX(0))="YES" S DIR("?",PSOCNT)="Enter 'PK' to Park prescription(s)",PSOCNT=PSOCNT+1 ;441 PAPI
- S DIR("?",PSOCNT)="Enter 'C' to select another label printer"
- I $P(PSOPAR,"^",26) S PSOCNT=PSOCNT+1,DIR("?",PSOCNT)="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 '$D(RESULTS) N RESULTS,PSOPARKX S RESULTS="PSOPARKX" D GETPARK^PSORPC01()
- I $E($G(DIR("A")),1,6)'="LABEL:" D RESDIR^PSOCPTRI
- S DIR(0)="SA^PR:PROFILE;Q:QUEUE;C:CHANGE PRINTER"_$S($P(PSOPAR,"^",23)&($D(^XUSEC("PSORPH",DUZ))!($D(^XUSEC("PSO TECH ADV",DUZ)))):";H:HOLD",1:"")
- ;S DIR(0)=DIR(0)_$S($P(PSOPAR,"^",24):";S:SUSPENSE",1:"")_$S($P(PSOPAR,"^",26):";L:PRINT",1:"")_$S($P(PSOPAR,"^",34):";PK:PARK",1:""),DIR("B")="Q" D ^DIR S:(Y="PR") Y="P" D G:$D(DIRUT)!($D(DUOUT)) EX ;*370 ;441 added PR & PARK
- S DIR(0)=DIR(0)_$S($P(PSOPAR,"^",24):";S:SUSPENSE",1:"")_$S($P(PSOPAR,"^",26):";L:PRINT",1:"")_$S($G(PSOPARKX(0))="YES":";PK:PARK",1:""),DIR("B")="Q" D ^DIR G:Y="PK" PK1 S:Y="PR" Y="P" D G:$D(DIRUT)!($D(DUOUT)) EX ;*370 ;441 added PR & PARK
- .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 ;441 PAPI
- K DIR S LBL=Y S:'$G(PSOPULL) SLBL=Y K:Y="H"!(Y="PK") BINGRTE G Q:Y="Q",S:Y="S",H1:Y="H",PK1:Y="PK",P:Y="L" I Y="P" W ! S PSDFN=DFN,PSFROM="" D ^PSODSPL K PSDFN,PSFROM G LBL ;441 PAPI
- 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 G RXSQUIT ;*334
- 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 Q2
- Q1 W ! K POP S %ZIS("B")="",%ZIS="MNQ",%ZIS("A")="Select LABEL DEVICE: " D ^%ZIS S PSLION=ION K %ZIS("A")
- G:$G(POP)&($G(PSPARTXX)) RXSQUIT G:$G(POP)&($G(PSOSONE)) RXSQ D:$G(POP)&($G(PSONOPRT))
- .S PSOQFLAG=1
- G:$G(PSOQFLAG) RXSQUIT G:POP!(IO=IO(0)) LBL S PSOLAP=ION ;*334
- N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
- S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10)
- D ^%ZISC S PSL=0
- Q2 ; Checking FDA Med Guide printer
- I ($$GET1^DIQ(59,PSOSITE,134)="")!($G(PSOEXREP)&'$G(PSOMGREP))!'$$FDARX(PPL)!($G(PSOSKIP)&($G(PSOFDAPT)'="")) G QLBL
- I $G(PSOEXREP),'$G(PSOMGREP) G QLBL
- N FDAPRT S FDAPRT=""
- F D Q:FDAPRT'=""!(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="") G LBL
- S PSOFDAPT=FDAPRT
- ;
- 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 G RXSQUIT ;*334
- ;
- ;S PDUZ=DUZ G DQ^PSOLBL
- S ZTRTN="DQ^PSOLBL",ZTIO=$S($G(SUSPT):PSLION,1:PSOLAP),ZTDTH=$S($G(PSOTIME):PSOTIME,1:$H),PDUZ=DUZ,OPAIO=ZTIO
- S ZTDESC="Outpatient Pharmacy "_$S($G(SUSPT):"SUSPENSE ",$G(DG):"DRUG INTERACTION ",1:"")_"LABELS OUTPUT ROUTINE"
- ;PSO 658 - Pass PSOLAP, remove PFION since it isn't used anyplace,
- F G="PPL1","PSOSYS","DFN","PSOPAR","PDUZ","PCOMX","PSOLAP","PPL" S:$D(@G) ZTSAVE(G)=""
- F G="RXY","PSOSITE","COPIES","SIDE","PSOSUSPR","PSOBARS","PSOBAR1","PSOBAR0","PSODELE" S:$D(@G) ZTSAVE(G)=""
- F G="PSOPULL","PSTAT","PSODBQ","PSOEXREP","PSOTREP","PSOFDAPT","PSOMGREP" S:$D(@G) ZTSAVE(G)=""
- S ZTSAVE("PSORX(")="",ZTSAVE("RXRP(")="",ZTSAVE("RXPR(")="",ZTSAVE("RXRS(")="",ZTSAVE("RXFL(")="",ZTSAVE("PCOMH(")=""
- D ^%ZISC,^%ZTLOAD K:$G(PSOSONE) RXRS
- I $D(ZTSK)&('$G(SUSPT))&('$G(PSOEXREP)) D
- . W !!,"LABEL(S) QUEUED TO PRINT",!!
- . D OPAI
- K OPAIO
- G:$G(PSPARTXX) RXSQUIT K G,PDUZ K:'$G(SUSPT) ZTSK G:$G(DG) RXSQUIT ;*334
- 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)) G:$G(PSOQFLAG) RXSQUIT S PSNP=0,PSOPRPAS=$G(HOLDRPAS) K:PSOPRPAS']"" PSOPRPAS K HOLDRPAS G D1 ;*334
- .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
- RXSQUIT K:'$G(PSOKLRXS) RXRS K ^TMP($J,"PSOBILL"),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 ;*334 ADDED TAG NAME
- 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
- S IOP=PSOLAP D ^%ZIS
- N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
- P1 S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10),PDUZ=DUZ D DQ1^PSOLBL,^%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
- FDARX(PPL) ; Check if any Rx to be printed has an FDA Med Guide
- N FDARX,FDARXIEN,I S FDARX=0
- F I=1:1:$L($G(PPL),",") D Q:FDARX
- . S FDARXIEN=+$P(PPL,",",I) I 'FDARXIEN Q
- . I $D(RXRP(FDARXIEN)),'$D(RXRP(FDARXIEN,"MG")) Q
- . I FDARXIEN,$$MGONFILE^PSOFDAUT(FDARXIEN) S FDARX=1
- Q FDARX
- ;
- 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 PMXZ="" F S PMXZ=$O(PSOHSAVE(PMXZ)) Q:PMXZ="" S RXRH(PMXZ)=PSOHSAVE(PMXZ)
- Q
- ;
- OPAI ;This section of code will display where an RX is routed.
- ;To determine where an RX will be routed, check:
- ;1) if the drug for the RX is associated with an ADD device in
- ; file #50 and if the printer is in the DISPENSING SYSTEM
- ; PRINTER multiple sub-file #59.02008. If it is then the RX
- ; will display as being routed to that device.
- ;2) Otherwise, the category of the ADD associated with the
- ; printer in sub-file #59.20081 will be used to determine
- ; where the RX will be routed and the ADD displayed.
- ;
- N DIC,X,Y,PN,II,RX,DEV,DDEV,ADD,DAT,DAT1,PDAT,DRG,DRG0,OPAI,CSB,RTE,FLG
- N ZTIO,MTH,NPPL
- I ($G(OPAIO)="")!($G(PPL)="") Q
- S DIC=3.5,DIC(0)="",X=OPAIO D ^DIC K DIC,X Q:Y=-1 S ZTIO=+Y
- S FLG=1,DEV=0,PN=$O(^PS(59,PSOSITE,"P","B",ZTIO,"")) I PN="" Q
- I '$P($G(PSOPAR),"^",30) Q
- I $$GET1^DIQ(59,PSOSITE_",",105,"I")'=2.4 Q
- ;
- ;ADD array built base on category.
- ; if category is not "S" then
- ; ADD(category)=ADD name^dns^port^inactive date
- ; if category is "S" then (Category "S" can be multiple)
- ; ADD(category,ADD name)=ADD name^dns^port^inactive date
- ;Array OPAI will be used to display the data on the screen.
- ; OPAI(ADD name)=ADD name^dns^port^inactive date
- ; OPAI(ADD name,RX)=drug
- ;
- F S DEV=$O(^PS(59,PSOSITE,"P",PN,"OPAI",DEV)) Q:'DEV D
- .S DAT=$G(^PS(59,PSOSITE,"P",PN,"OPAI",DEV,0)) I $P(DAT,"^",2)="" Q
- .S DAT1=$$ADDCHK^PSOHLDS($P(DAT,"^"))
- .I DAT1 D
- ..I $P(DAT,"^",2)'="S" S ADD($P(DAT,"^",2))=$P(DAT1,"^",2,99) Q
- ..S ADD($P(DAT,"^",2),$P(DAT1,"^",2))=$P(DAT1,"^",2,99)
- S NPPL=""
- F II=1:1:$L(PPL,",") S RX=$P(PPL,",",II) D:RX'=""
- .I $G(RXRP(RX,"RP")) Q
- .S PDAT=$G(^PSRX(RX,0)),DRG=$P(PDAT,"^",6),RTE=$$RTE()
- .S DRG0=$G(^PSDRUG(+DRG,0)),DDEV=$G(^PSDRUG(+DRG,"OPAI",PSOSITE,0))
- .I $S($P(PSOPAR,"^",30)=3:1,$P(PSOPAR,"^",30)=4:1,1:0),'$$GET1^DIQ(50,DRG,28,"I") Q
- .S NPPL=NPPL_","_RX,DAT1=$$ADDCHK^PSOHLDS($S(RTE="W":$P(DDEV,"^",2),RTE="M":$P(DDEV,"^",3),1:"")) I DAT1 D Q
- ..D SETOP($P(DAT1,"^",2,99),$P(PDAT,"^"),$P(DRG0,"^"))
- .I $D(ADD("A")) D SETOP(ADD("A"),$P(PDAT,"^"),$P(DRG0,"^")) Q
- .S CSB=+$P(DRG0,"^",3),CSB=$S((CSB>0)&(CSB<6):"CS",1:"NCS")
- .I $D(ADD(CSB)) D SETOP(ADD(CSB),$P(PDAT,"^"),$P(DRG0,"^")) Q
- .I $D(ADD(RTE_CSB)) D SETOP(ADD(RTE_CSB),$P(PDAT,"^"),$P(DRG0,"^")) Q
- .S MTH=$S(RTE="W":"WIND",RTE="M":"MAIL",1:"")
- .I MTH'="",$D(ADD(MTH)) D SETOP(ADD(MTH),$P(PDAT,"^"),$P(DRG0,"^"))
- .S FLG=0
- I FLG Q ;nothing found to print
- I ($D(OPAI))!($D(ADD("S"))) W !,"PRESCRIPTIONS SENT TO:" D
- .S DEV="" F S DEV=$O(OPAI(DEV)) Q:DEV="" W !?3,DEV D W !
- ..S RX=0 F S RX=$O(OPAI(DEV,RX)) Q:'RX W !?5,RX,?20,$P(OPAI(DEV,RX),"^")
- I $D(ADD("S")) W !,"STORAGE DEVICES" S II="" D
- .F S II=$O(ADD("S",II)) Q:II="" W !?3,II I $D(OPAI) ;W ?20,"The above Prescriptions"
- .F II=1:1:$L(NPPL,",") S RX=$P(NPPL,",",II) D:RX'=""
- ..Q:$G(RXRP(RX,"RP")) S PDAT=$G(^PSRX(RX,0)),DRG=$P($G(^PSDRUG(+$P(PDAT,"^",6),0)),"^")
- ..W !?5,$P(PDAT,"^"),?20,DRG
- .W !
- Q
- ;
- SETOP(DINF,DRX,DDRG) ; Set OPAI array
- N DNAM
- S DNAM=$P(DINF,"^"),OPAI(DNAM)=DINF,OPAI(DNAM,DRX)=DDRG,FLG=0
- Q
- ;
- RTE() ; get route for RX
- N FP,FPN,LRF,MW,XX
- S FP=$S($G(RXPR(RX)):"P",1:"F")
- I '$G(RXPR(RX)) S LRF=0 F XX=0:0 S XX=$O(^PSRX(RX,1,XX)) Q:'XX I +^(XX,0) S LRF=XX
- I '$G(RXPR(RX)),$G(RXFL(RX))'="" S LRF=$S($G(RXFL(RX))=0:0,$D(^PSRX(RX,1,+$G(RXFL(RX)),0)):+$G(RXFL(RX)),1:$G(LRF))
- S FPN=$S($G(RXPR(RX)):RXPR(RX),1:$G(LRF))
- I FP="F"&('FPN) S MW=$P($G(^PSRX(RX,0)),"^",11) ;original
- I FP="F"&(FPN) S MW=$P($G(^PSRX(RX,1,FPN,0)),"^",2) ;refill
- I FP="P"&(FPN) S MW=$P($G(^PSRX(RX,"P",FPN,0)),"^",2) ;partial
- Q $G(MW)
- PK1 ;
- G:$D(DTOUT) D1
- S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) ;441 PAPI
- I $D(RXRS) S PI=0 F S PI=$O(RXRS(PI)) Q:'PI D
- .I $G(PPL)="" S PPL=PI_"," Q
- .Q:PPL[PI
- .S PPL=PPL_PI_","
- G:$G(PPL)']"" D1
- PK ;
- D PK^PSORXL1 ;*712
- I $G(SPPL)]"" D DRUGINT
- G D1
- ;
- DRUGINT ;441 PAPI
- 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
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORXL 16522 printed Jan 18, 2025@03:35:40 Page 2
- PSORXL ;BHAM ISC/SAB - action to be taken on prescriptions ; May 11, 2023@08:10:09
- +1 ;;7.0;OUTPATIENT PHARMACY;**8,21,24,32,47,135,148,287,334,251,354,367,370,442,658,441,712**;DEC 1997;Build 20
- +2 ;
- +3 ; Reference to ^PSDRUG( in ICR #221
- +4 ; Reference to CHPUS^IBACUS,TRI^IBACUS in ICR #2030
- +5 ; Added kill for BINGRTE to force bypass of Bingo board prompt if choose H (Hold) or PK (Park) - PaPI ;441
- +6 ;
- +7 DO PPLPARK^PSORXL1
- IF $GET(PPL)=""
- IF '$ORDER(RXRS(0))
- IF $GET(PSORX("PSOL",1))=""
- GOTO RXSQUIT
- +8 IF $GET(PSOTRVV)
- IF $GET(PPL)
- SET PSORX("PSOL",1)=PPL
- KILL PPL
- +9 NEW SLBL,PSOSONE,PSOKLRXS,PSOSKIP
- SET PSOSKIP=1
- +10 if '$GET(PPL)
- SET PPL=$GET(PSORX("PSOL",1))
- if $PIECE(PSOPAR,"^",26)
- GOTO P
- LBL ;
- +1 ;*334 ;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=""
- GOTO RXSQUIT
- +2 NEW RESULTS,PSOPARKX,PSOCNT
- +3 SET RESULTS="PSOPARKX"
- DO GETPARK^PSORPC01()
- +4 WRITE !!
- SET DIR("A",1)="Label Printer: "_$SELECT($GET(SUSPT):PSLION,1:$GET(PSOLAP))
- +5 IF $$GET1^DIQ(59,PSOSITE,134)'=""
- Begin DoDot:1
- +6 IF $GET(PSOFDAPT)=""
- SET PSOFDAPT=$$DEFPRT^PSOFDAUT(PSOSITE)
- +7 SET DIR("A",2)="FDA Med Guide Printer: "_$SELECT($GET(PSOFDAPT)="":"HOME",1:$PIECE(PSOFDAPT,"^"))
- End DoDot:1
- +8 SET DIR("A")="LABEL: QUEUE/CHANGE PRINTER"_$SELECT($PIECE(PSOPAR,"^",23)&($DATA(^XUSEC("PSORPH",DUZ))!($DATA(^XUSEC("PSO TECH ADV",DUZ)))):"/HOLD",1:"")
- +9 ;S DIR("A")=DIR("A")_$S($P(PSOPAR,"^",24):"/SUSPEND",1:"")_$S($P(PSOPAR,"^",26):"/LABEL",1:"")_$S($P(PSOPAR,"^",34):"/PARK(PK)",1:"")_" or '^' to bypass " ;papi 441
- +10 ;papi 441
- SET DIR("A")=DIR("A")_$SELECT($PIECE(PSOPAR,"^",24):"/SUSPEND",1:"")_$SELECT($PIECE(PSOPAR,"^",26):"/LABEL",1:"")_$SELECT($GET(PSOPARKX(0))="YES":"/PARK(PK)",1:"")_" or '^' to bypass "
- +11 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"
- +12 SET DIR("?",2)="Enter 'H' to hold label until Rx can be filled"
- SET DIR("?",3)="Enter 'PR' for Rx profile"
- +13 SET PSOCNT=5
- +14 ;441 PAPI
- IF $GET(PSOPARKX(0))="YES"
- SET DIR("?",PSOCNT)="Enter 'PK' to Park prescription(s)"
- SET PSOCNT=PSOCNT+1
- +15 SET DIR("?",PSOCNT)="Enter 'C' to select another label printer"
- +16 IF $PIECE(PSOPAR,"^",26)
- SET PSOCNT=PSOCNT+1
- SET DIR("?",PSOCNT)="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 '$DATA(RESULTS)
- NEW RESULTS,PSOPARKX
- SET RESULTS="PSOPARKX"
- DO GETPARK^PSORPC01()
- +2 IF $EXTRACT($GET(DIR("A")),1,6)'="LABEL:"
- DO RESDIR^PSOCPTRI
- +3 SET DIR(0)="SA^PR:PROFILE;Q:QUEUE;C:CHANGE PRINTER"_$SELECT($PIECE(PSOPAR,"^",23)&($DATA(^XUSEC("PSORPH",DUZ))!($DATA(^XUSEC("PSO TECH ADV",DUZ)))):";H:HOLD",1:"")
- +4 ;S DIR(0)=DIR(0)_$S($P(PSOPAR,"^",24):";S:SUSPENSE",1:"")_$S($P(PSOPAR,"^",26):";L:PRINT",1:"")_$S($P(PSOPAR,"^",34):";PK:PARK",1:""),DIR("B")="Q" D ^DIR S:(Y="PR") Y="P" D G:$D(DIRUT)!($D(DUOUT)) EX ;*370 ;441 added PR & PARK
- +5 ;*370 ;441 added PR & PARK
- SET DIR(0)=DIR(0)_$SELECT($PIECE(PSOPAR,"^",24):";S:SUSPENSE",1:"")_$SELECT($PIECE(PSOPAR,"^",26):";L:PRINT",1:"")_$SELECT($GET(PSOPARKX(0))="YES":";PK:PARK",1:"")
- SET DIR("B")="Q"
- DO ^DIR
- if Y="PK"
- GOTO PK1
- if Y="PR"
- SET Y="P"
- Begin DoDot:1
- +6 IF $DATA(DIRUT)!($DATA(DUOUT))
- DO AL^PSOLBL("UT")
- IF $GET(PSOEXREP)
- SET PSOEXREX=1
- +7 IF $GET(PSOPULL)
- IF $DATA(DIRUT)!($DATA(DUOUT))
- SET PSOQFLAG=1
- End DoDot:1
- if $DATA(DIRUT)!($DATA(DUOUT))
- GOTO EX
- +8 if $GET(PSOBEDT)
- SET NOPP=Y
- +9 IF $GET(Y)="C"
- KILL PSOCLBL,%ZIS("B")
- SET PSOCLBL=1
- DO @$SELECT('$DATA(PSOPAR):"^PSOLSET",1:"PLBL^PSOLSET")
- KILL PSOCLBL
- GOTO LBL
- +10 IF $GET(Y)="Q"
- IF $DATA(RXRS)
- IF '$GET(PSOPULL)
- DO PPLADD^PSOSUPOE
- +11 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
- +12 ;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 ;441 PAPI
- +13 ;441 PAPI
- KILL DIR
- SET LBL=Y
- if '$GET(PSOPULL)
- SET SLBL=Y
- if Y="H"!(Y="PK")
- KILL BINGRTE
- if Y="Q"
- GOTO Q
- if Y="S"
- GOTO S
- if Y="H"
- GOTO H1
- if Y="PK"
- GOTO PK1
- if Y="L"
- GOTO P
- IF Y="P"
- WRITE !
- SET PSDFN=DFN
- SET PSFROM=""
- DO ^PSODSPL
- KILL PSDFN,PSFROM
- GOTO LBL
- EX ;*334
- 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
- GOTO RXSQUIT
- 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 Q2
- Q1 WRITE !
- KILL POP
- SET %ZIS("B")=""
- SET %ZIS="MNQ"
- SET %ZIS("A")="Select LABEL DEVICE: "
- DO ^%ZIS
- SET PSLION=ION
- KILL %ZIS("A")
- +1 if $GET(POP)&($GET(PSPARTXX))
- GOTO RXSQUIT
- if $GET(POP)&($GET(PSOSONE))
- GOTO RXSQ
- if $GET(POP)&($GET(PSONOPRT))
- Begin DoDot:1
- +2 SET PSOQFLAG=1
- End DoDot:1
- +3 ;*334
- if $GET(PSOQFLAG)
- GOTO RXSQUIT
- if POP!(IO=IO(0))
- GOTO LBL
- SET PSOLAP=ION
- +4 NEW PSOIOS
- SET PSOIOS=IOS
- DO DEVBAR^PSOBMST
- +5 SET PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$PIECE(PSOPAR,"^",10)
- +6 DO ^%ZISC
- SET PSL=0
- Q2 ; Checking FDA Med Guide printer
- +1 IF ($$GET1^DIQ(59,PSOSITE,134)="")!($GET(PSOEXREP)&'$GET(PSOMGREP))!'$$FDARX(PPL)!($GET(PSOSKIP)&($GET(PSOFDAPT)'=""))
- GOTO QLBL
- +2 IF $GET(PSOEXREP)
- IF '$GET(PSOMGREP)
- GOTO QLBL
- +3 NEW FDAPRT
- SET FDAPRT=""
- +4 FOR
- Begin DoDot:1
- +5 SET FDAPRT=$$SELPRT^PSOFDAUT($PIECE($GET(PSOFDAPT),"^"))
- +6 IF FDAPRT=""
- WRITE $CHAR(7),!,"You must select a valid FDA Medication Guide printer."
- End DoDot:1
- if FDAPRT'=""!(FDAPRT="^")
- QUIT
- +7 IF FDAPRT="^"!(FDAPRT="")
- GOTO LBL
- +8 SET PSOFDAPT=FDAPRT
- +9 ;
- 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 ;*334
- DO ECME^PSORXL1
- IF '$GET(PPL)
- WRITE !!,"No Label(s) printed.",!!
- SET PSOQFLAG=1
- GOTO RXSQUIT
- +4 ;
- +5 ;S PDUZ=DUZ G DQ^PSOLBL
- +6 SET ZTRTN="DQ^PSOLBL"
- SET ZTIO=$SELECT($GET(SUSPT):PSLION,1:PSOLAP)
- SET ZTDTH=$SELECT($GET(PSOTIME):PSOTIME,1:$HOROLOG)
- SET PDUZ=DUZ
- SET OPAIO=ZTIO
- +7 SET ZTDESC="Outpatient Pharmacy "_$SELECT($GET(SUSPT):"SUSPENSE ",$GET(DG):"DRUG INTERACTION ",1:"")_"LABELS OUTPUT ROUTINE"
- +8 ;PSO 658 - Pass PSOLAP, remove PFION since it isn't used anyplace,
- +9 FOR G="PPL1","PSOSYS","DFN","PSOPAR","PDUZ","PCOMX","PSOLAP","PPL"
- if $DATA(@G)
- SET ZTSAVE(G)=""
- +10 FOR G="RXY","PSOSITE","COPIES","SIDE","PSOSUSPR","PSOBARS","PSOBAR1","PSOBAR0","PSODELE"
- if $DATA(@G)
- SET ZTSAVE(G)=""
- +11 FOR G="PSOPULL","PSTAT","PSODBQ","PSOEXREP","PSOTREP","PSOFDAPT","PSOMGREP"
- if $DATA(@G)
- SET ZTSAVE(G)=""
- +12 SET ZTSAVE("PSORX(")=""
- SET ZTSAVE("RXRP(")=""
- SET ZTSAVE("RXPR(")=""
- SET ZTSAVE("RXRS(")=""
- SET ZTSAVE("RXFL(")=""
- SET ZTSAVE("PCOMH(")=""
- +13 DO ^%ZISC
- DO ^%ZTLOAD
- if $GET(PSOSONE)
- KILL RXRS
- +14 IF $DATA(ZTSK)&('$GET(SUSPT))&('$GET(PSOEXREP))
- Begin DoDot:1
- +15 WRITE !!,"LABEL(S) QUEUED TO PRINT",!!
- +16 DO OPAI
- End DoDot:1
- +17 KILL OPAIO
- +18 ;*334
- if $GET(PSPARTXX)
- GOTO RXSQUIT
- KILL G,PDUZ
- if '$GET(SUSPT)
- KILL ZTSK
- if $GET(DG)
- GOTO RXSQUIT
- +19 if '$GET(PSNP)
- GOTO QUEUP
- if $GET(PSOPRFLG)
- GOTO QUEUP
- SET HOLDRPAS=$GET(PSOPRPAS)
- SET PSOPRPAS=$PIECE(PSOPAR,"^",13)
- PLBL SET PSOION=ION
- +1 IF '$DATA(PSOPROP)!($GET(PSOPROP)=ION)
- WRITE $CHAR(7),!,"PROFILES MUST BE SENT TO PRINTER !!",!
- KILL IOP,%ZIS,IO("Q"),POP
- SET %ZIS="MNQ"
- SET %ZIS("A")="Select PROFILE DEVICE: "
- DO ^%ZIS
- KILL %ZIS("A")
- if POP
- GOTO QUEUP
- if $EXTRACT(IOST)["C"!(PSOION=ION)
- GOTO PLBL
- SET PSOPROP=ION
- QPRF SET ZTRTN="DQ^PSOPRF"
- SET ZTIO=PSOPROP
- SET ZTDESC="Outpatient Pharmacy "_$SELECT($GET(SUSPT):"SUSPENSE ",1:"")_"PATIENT PROFILES"
- SET ZTDTH=$SELECT($GET(PSOTIME):PSOTIME,1:$HOROLOG)
- +1 FOR G="PSOPAR","PSODTCUT","PSOPRPAS","DFN","PSOSITE","NEW1","NEW11","PSOBMST","PFIO","PPL"
- if $DATA(@G)
- SET ZTSAVE(G)=""
- +2 DO ^%ZTLOAD
- if $DATA(ZTSK)&('$GET(SUSPT))&('$GET(PSOEXREP))
- WRITE !,"PROFILE IS QUEUED TO PRINT",!!
- KILL G
- if '$GET(SUSPT)
- KILL ZTSK
- DO ^%ZISC
- QUEUP ;*334
- if $GET(POP)&($GET(PSONOPRT))
- Begin DoDot:1
- +1 SET PSOQFLAG=1
- End DoDot:1
- if $GET(PSOQFLAG)
- GOTO RXSQUIT
- SET PSNP=0
- SET PSOPRPAS=$GET(HOLDRPAS)
- if PSOPRPAS']""
- KILL PSOPRPAS
- KILL HOLDRPAS
- GOTO D1
- +2 QUIT
- +3 ;
- S GOTO S^PSORXL1
- SUS SET X="IBACUS"
- XECUTE ^%ZOSF("TEST")
- KILL X
- IF '$TEST
- GOTO SUSL1
- +1 NEW TRIDA
- SET TRIDA=DA
- IF '$$TRI^IBACUS()
- SET DA=TRIDA
- GOTO SUSL1
- +2 IF $GET(RXRP(TRIDA))!($GET(RXPR(TRIDA)))!($GET(RXRH(TRIDA)))
- SET DA=TRIDA
- GOTO SUSL1
- +3 NEW PBILL,PSTRD,PSTRDZ,PSTRF,PSTRP,GGG
- +4 DO DEV^PSOCPTRI
- +5 IF '$GET(DT)
- SET DT=$$DT^XLFDT
- +6 SET PSTRP=$PIECE($GET(^PSRX(+TRIDA,0)),"^",2)
- SET PSTRD=+$GET(PSOSITE)
- SET PSTRDZ=+$GET(DUZ)
- +7 SET PSTRF=0
- FOR GGG=0:0
- SET GGG=$ORDER(^PSRX(+TRIDA,1,GGG))
- if 'GGG
- QUIT
- SET PSTRF=GGG
- +8 SET PBILL=$$CHPUS^IBACUS(PSTRP,DT,TRIDA,PSTRF,PSOLAP,PSTRD,PSTRDZ)
- +9 IF '$GET(PBILL)
- SET DA=TRIDA
- GOTO SUSL1
- +10 SET FLD(99)="99"
- SET FLD(99.1)="Awaiting CHAMPUS billing approval"
- +11 NEW RSDT,ACT,PSUS,RXF,RFN,I,PSDA,NOW,IR,FDA
- +12 SET DA=TRIDA
- DO H^PSOCPTRH
- +13 QUIT
- SUSL1 GOTO SUS^PSORXL1
- H1 SET PPL1=1
- if '$GET(PPL)
- SET PPL=$GET(PSORX("PSOL",PPL1))
- +1 if '$DATA(^TMP($JOB,"PSOBILL"))
- DO NOOR^PSOHLD
- IF $DATA(DIRUT)
- KILL DIRUT
- GOTO PSORXL
- +2 IF $DATA(^TMP($JOB,"PSOBILL"))
- SET FLD(99)="99"
- SET FLD(99.1)="Awaiting CHAMPUS billing approval"
- GOTO H
- +3 if $GET(PPL)']""
- GOTO D1
- DO FLD^PSOHLD
- IF $DATA(DUOUT)!($DATA(DIRUT))
- KILL DIRUT,DUOUT,FLD,DIR
- GOTO LBL
- H KILL SPPL
- if $DATA(DTOUT)
- GOTO D1
- SET SPPL=""
- FOR PI=1:1
- if $PIECE(PPL,",",PI)=""
- QUIT
- Begin DoDot:1
- +1 SET DA=$PIECE(PPL,",",PI)
- IF $PIECE(^PSRX(DA,"STA"),"^")<10
- IF $PIECE(^("STA"),"^")'=4
- DO @$SELECT($DATA(^TMP($JOB,"PSOBILL")):"H^PSOCPTRH",1:"H^PSOHLD")
- QUIT
- +2 IF $PIECE(^PSRX(DA,"STA"),"^")=4
- SET SPPL=SPPL_DA_","
- QUIT
- End DoDot:1
- +3 IF $GET(SPPL)]""
- Begin DoDot:1
- +4 WRITE !!,$CHAR(7),"Drug Interaction Rx(s) "
- FOR I=1:1
- if $PIECE(SPPL,",",I)=""
- QUIT
- WRITE $PIECE(^PSRX($PIECE(SPPL,",",I),0),"^")_", "
- +5 SET PPL=SPPL
- SET DG=1
- DO Q
- KILL DG,SPPL
- End DoDot:1
- D1 KILL RXLTOP
- IF $GET(PPL1)
- IF $ORDER(PSORX("PSOL",$GET(PPL1)))
- SET PPL1=$ORDER(PSORX("PSOL",PPL1))
- SET PPL=PSORX("PSOL",PPL1)
- GOTO @$SELECT(LBL="H":"H",LBL="L":"P1",1:"QLBL")
- RXS IF $DATA(RXRS)
- IF '$GET(PSOKLRXS)
- IF $GET(SLBL)="H"!($GET(SLBL)="S")!($GET(SLBL)="^")!($GET(SLBL)="")
- Begin DoDot:1
- +1 KILL PPL,PSORX("PSOL")
- SET PSOSONE=1
- DO PPLADD^PSOSUPOE
- +2 if $GET(PPL)=""
- QUIT
- WRITE !!,"You have selected the following Rx(s) to be pulled from suspense:",!
- +3 FOR RXSS=0:0
- SET RXSS=$ORDER(RXRS(RXSS))
- if 'RXSS
- QUIT
- WRITE !," Rx # ",$PIECE($GET(^PSRX(+$GET(RXSS),0)),"^"),?23,$PIECE($GET(^PSDRUG(+$PIECE($GET(^PSRX(+$GET(RXSS),0)),"^",6),0)),"^")
- +4 KILL DIR
- WRITE !
- SET DIR(0)="Y"
- SET DIR("B")="YES"
- SET DIR("A")="Do you still want to pull these Rx(s) from suspense"
- DO ^DIR
- KILL DIR
- IF Y'=1
- WRITE !!,"Rx(s) will remain in Suspense!",!
- DO RESET^PSOSUPOE
- KILL RXRS,PPL
- End DoDot:1
- if $GET(PPL)'=""
- GOTO Q
- RXSQUIT ;*334 ADDED TAG NAME
- if '$GET(PSOKLRXS)
- KILL RXRS
- KILL ^TMP($JOB,"PSOBILL"),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
- QUIT
- P SET PPL1=1
- if '$GET(PPL)
- SET PPL=$GET(PSORX("PSOL",1))
- if $GET(PPL)']""
- GOTO D1
- +1 IF $GET(PSOLAP)']""
- WRITE !
- KILL POP,ZTSK
- SET %ZIS="M"
- SET %ZIS("A")="Select LABEL DEVICE: "
- DO ^%ZIS
- KILL %ZIS("A")
- if POP
- GOTO LBL
- SET PSOLAP=ION
- +2 SET IOP=PSOLAP
- DO ^%ZIS
- +3 NEW PSOIOS
- SET PSOIOS=IOS
- DO DEVBAR^PSOBMST
- P1 SET PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$PIECE(PSOPAR,"^",10)
- SET PDUZ=DUZ
- DO DQ1^PSOLBL
- DO ^%ZISC
- +1 if '$PIECE(PSOPAR,"^",8)!(+$GET(REPRINT))!($GET(PSOFROM)'="NEW")
- GOTO D1
- IF $GET(PSOPROP)']""
- SET PSOION=ION
- SET %ZIS="M"
- SET %ZIS("A")="Select PROFILE DEVICE: "
- DO ^%ZIS
- KILL %ZIS("A")
- if POP
- GOTO D1
- SET PSOPROP=ION
- +2 SET IOP=PSOPROP
- DO ^%ZIS
- DO DQ^PSOPRF
- DO ^%ZISC
- GOTO D1
- +3 QUIT
- RXSQ KILL RXRS
- GOTO RXS
- +1 QUIT
- FDARX(PPL) ; Check if any Rx to be printed has an FDA Med Guide
- +1 NEW FDARX,FDARXIEN,I
- SET FDARX=0
- +2 FOR I=1:1:$LENGTH($GET(PPL),",")
- Begin DoDot:1
- +3 SET FDARXIEN=+$PIECE(PPL,",",I)
- IF 'FDARXIEN
- QUIT
- +4 IF $DATA(RXRP(FDARXIEN))
- IF '$DATA(RXRP(FDARXIEN,"MG"))
- QUIT
- +5 IF FDARXIEN
- IF $$MGONFILE^PSOFDAUT(FDARXIEN)
- SET FDARX=1
- End DoDot:1
- if FDARX
- QUIT
- +6 QUIT FDARX
- +7 ;
- RSAVE NEW PMX
- +1 SET PMX=""
- FOR
- SET PMX=$ORDER(RXRP(PMX))
- if PMX=""
- QUIT
- SET PSORSAVE(PMX)=RXRP(PMX)
- +2 SET PMX=""
- FOR
- SET PMX=$ORDER(RXPR(PMX))
- if PMX=""
- QUIT
- SET PSOPSAVE(PMX)=RXPR(PMX)
- +3 SET PMX=""
- FOR
- SET PMX=$ORDER(RXRH(PMX))
- if PMX=""
- QUIT
- SET PSOHSAVE(PMX)=RXRH(PMX)
- +4 QUIT
- RREST NEW PMXZ
- +1 SET PMXZ=""
- FOR
- SET PMXZ=$ORDER(PSORSAVE(PMXZ))
- if PMXZ=""
- QUIT
- SET RXRP(PMXZ)=PSORSAVE(PMXZ)
- +2 SET PMXZ=""
- FOR
- SET PMXZ=$ORDER(PSOPSAVE(PMXZ))
- if PMXZ=""
- QUIT
- SET RXPR(PMXZ)=PSOPSAVE(PMXZ)
- +3 SET PMXZ=""
- FOR
- SET PMXZ=$ORDER(PSOHSAVE(PMXZ))
- if PMXZ=""
- QUIT
- SET RXRH(PMXZ)=PSOHSAVE(PMXZ)
- +4 QUIT
- +5 ;
- OPAI ;This section of code will display where an RX is routed.
- +1 ;To determine where an RX will be routed, check:
- +2 ;1) if the drug for the RX is associated with an ADD device in
- +3 ; file #50 and if the printer is in the DISPENSING SYSTEM
- +4 ; PRINTER multiple sub-file #59.02008. If it is then the RX
- +5 ; will display as being routed to that device.
- +6 ;2) Otherwise, the category of the ADD associated with the
- +7 ; printer in sub-file #59.20081 will be used to determine
- +8 ; where the RX will be routed and the ADD displayed.
- +9 ;
- +10 NEW DIC,X,Y,PN,II,RX,DEV,DDEV,ADD,DAT,DAT1,PDAT,DRG,DRG0,OPAI,CSB,RTE,FLG
- +11 NEW ZTIO,MTH,NPPL
- +12 IF ($GET(OPAIO)="")!($GET(PPL)="")
- QUIT
- +13 SET DIC=3.5
- SET DIC(0)=""
- SET X=OPAIO
- DO ^DIC
- KILL DIC,X
- if Y=-1
- QUIT
- SET ZTIO=+Y
- +14 SET FLG=1
- SET DEV=0
- SET PN=$ORDER(^PS(59,PSOSITE,"P","B",ZTIO,""))
- IF PN=""
- QUIT
- +15 IF '$PIECE($GET(PSOPAR),"^",30)
- QUIT
- +16 IF $$GET1^DIQ(59,PSOSITE_",",105,"I")'=2.4
- QUIT
- +17 ;
- +18 ;ADD array built base on category.
- +19 ; if category is not "S" then
- +20 ; ADD(category)=ADD name^dns^port^inactive date
- +21 ; if category is "S" then (Category "S" can be multiple)
- +22 ; ADD(category,ADD name)=ADD name^dns^port^inactive date
- +23 ;Array OPAI will be used to display the data on the screen.
- +24 ; OPAI(ADD name)=ADD name^dns^port^inactive date
- +25 ; OPAI(ADD name,RX)=drug
- +26 ;
- +27 FOR
- SET DEV=$ORDER(^PS(59,PSOSITE,"P",PN,"OPAI",DEV))
- if 'DEV
- QUIT
- Begin DoDot:1
- +28 SET DAT=$GET(^PS(59,PSOSITE,"P",PN,"OPAI",DEV,0))
- IF $PIECE(DAT,"^",2)=""
- QUIT
- +29 SET DAT1=$$ADDCHK^PSOHLDS($PIECE(DAT,"^"))
- +30 IF DAT1
- Begin DoDot:2
- +31 IF $PIECE(DAT,"^",2)'="S"
- SET ADD($PIECE(DAT,"^",2))=$PIECE(DAT1,"^",2,99)
- QUIT
- +32 SET ADD($PIECE(DAT,"^",2),$PIECE(DAT1,"^",2))=$PIECE(DAT1,"^",2,99)
- End DoDot:2
- End DoDot:1
- +33 SET NPPL=""
- +34 FOR II=1:1:$LENGTH(PPL,",")
- SET RX=$PIECE(PPL,",",II)
- if RX'=""
- Begin DoDot:1
- +35 IF $GET(RXRP(RX,"RP"))
- QUIT
- +36 SET PDAT=$GET(^PSRX(RX,0))
- SET DRG=$PIECE(PDAT,"^",6)
- SET RTE=$$RTE()
- +37 SET DRG0=$GET(^PSDRUG(+DRG,0))
- SET DDEV=$GET(^PSDRUG(+DRG,"OPAI",PSOSITE,0))
- +38 IF $SELECT($PIECE(PSOPAR,"^",30)=3:1,$PIECE(PSOPAR,"^",30)=4:1,1:0)
- IF '$$GET1^DIQ(50,DRG,28,"I")
- QUIT
- +39 SET NPPL=NPPL_","_RX
- SET DAT1=$$ADDCHK^PSOHLDS($SELECT(RTE="W":$PIECE(DDEV,"^",2),RTE="M":$PIECE(DDEV,"^",3),1:""))
- IF DAT1
- Begin DoDot:2
- +40 DO SETOP($PIECE(DAT1,"^",2,99),$PIECE(PDAT,"^"),$PIECE(DRG0,"^"))
- End DoDot:2
- QUIT
- +41 IF $DATA(ADD("A"))
- DO SETOP(ADD("A"),$PIECE(PDAT,"^"),$PIECE(DRG0,"^"))
- QUIT
- +42 SET CSB=+$PIECE(DRG0,"^",3)
- SET CSB=$SELECT((CSB>0)&(CSB<6):"CS",1:"NCS")
- +43 IF $DATA(ADD(CSB))
- DO SETOP(ADD(CSB),$PIECE(PDAT,"^"),$PIECE(DRG0,"^"))
- QUIT
- +44 IF $DATA(ADD(RTE_CSB))
- DO SETOP(ADD(RTE_CSB),$PIECE(PDAT,"^"),$PIECE(DRG0,"^"))
- QUIT
- +45 SET MTH=$SELECT(RTE="W":"WIND",RTE="M":"MAIL",1:"")
- +46 IF MTH'=""
- IF $DATA(ADD(MTH))
- DO SETOP(ADD(MTH),$PIECE(PDAT,"^"),$PIECE(DRG0,"^"))
- +47 SET FLG=0
- End DoDot:1
- +48 ;nothing found to print
- IF FLG
- QUIT
- +49 IF ($DATA(OPAI))!($DATA(ADD("S")))
- WRITE !,"PRESCRIPTIONS SENT TO:"
- Begin DoDot:1
- +50 SET DEV=""
- FOR
- SET DEV=$ORDER(OPAI(DEV))
- if DEV=""
- QUIT
- WRITE !?3,DEV
- Begin DoDot:2
- +51 SET RX=0
- FOR
- SET RX=$ORDER(OPAI(DEV,RX))
- if 'RX
- QUIT
- WRITE !?5,RX,?20,$PIECE(OPAI(DEV,RX),"^")
- End DoDot:2
- WRITE !
- End DoDot:1
- +52 IF $DATA(ADD("S"))
- WRITE !,"STORAGE DEVICES"
- SET II=""
- Begin DoDot:1
- +53 ;W ?20,"The above Prescriptions"
- FOR
- SET II=$ORDER(ADD("S",II))
- if II=""
- QUIT
- WRITE !?3,II
- IF $DATA(OPAI)
- +54 FOR II=1:1:$LENGTH(NPPL,",")
- SET RX=$PIECE(NPPL,",",II)
- if RX'=""
- Begin DoDot:2
- +55 if $GET(RXRP(RX,"RP"))
- QUIT
- SET PDAT=$GET(^PSRX(RX,0))
- SET DRG=$PIECE($GET(^PSDRUG(+$PIECE(PDAT,"^",6),0)),"^")
- +56 WRITE !?5,$PIECE(PDAT,"^"),?20,DRG
- End DoDot:2
- +57 WRITE !
- End DoDot:1
- +58 QUIT
- +59 ;
- SETOP(DINF,DRX,DDRG) ; Set OPAI array
- +1 NEW DNAM
- +2 SET DNAM=$PIECE(DINF,"^")
- SET OPAI(DNAM)=DINF
- SET OPAI(DNAM,DRX)=DDRG
- SET FLG=0
- +3 QUIT
- +4 ;
- RTE() ; get route for RX
- +1 NEW FP,FPN,LRF,MW,XX
- +2 SET FP=$SELECT($GET(RXPR(RX)):"P",1:"F")
- +3 IF '$GET(RXPR(RX))
- SET LRF=0
- FOR XX=0:0
- SET XX=$ORDER(^PSRX(RX,1,XX))
- if 'XX
- QUIT
- IF +^(XX,0)
- SET LRF=XX
- +4 IF '$GET(RXPR(RX))
- IF $GET(RXFL(RX))'=""
- SET LRF=$SELECT($GET(RXFL(RX))=0:0,$DATA(^PSRX(RX,1,+$GET(RXFL(RX)),0)):+$GET(RXFL(RX)),1:$GET(LRF))
- +5 SET FPN=$SELECT($GET(RXPR(RX)):RXPR(RX),1:$GET(LRF))
- +6 ;original
- IF FP="F"&('FPN)
- SET MW=$PIECE($GET(^PSRX(RX,0)),"^",11)
- +7 ;refill
- IF FP="F"&(FPN)
- SET MW=$PIECE($GET(^PSRX(RX,1,FPN,0)),"^",2)
- +8 ;partial
- IF FP="P"&(FPN)
- SET MW=$PIECE($GET(^PSRX(RX,"P",FPN,0)),"^",2)
- +9 QUIT $GET(MW)
- PK1 ;
- +1 if $DATA(DTOUT)
- GOTO D1
- +2 ;441 PAPI
- if '$GET(PPL)
- SET PPL=$GET(PSORX("PSOL",1))
- +3 IF $DATA(RXRS)
- SET PI=0
- FOR
- SET PI=$ORDER(RXRS(PI))
- if 'PI
- QUIT
- Begin DoDot:1
- +4 IF $GET(PPL)=""
- SET PPL=PI_","
- QUIT
- +5 if PPL[PI
- QUIT
- +6 SET PPL=PPL_PI_","
- End DoDot:1
- +7 if $GET(PPL)']""
- GOTO D1
- PK ;
- +1 ;*712
- DO PK^PSORXL1
- +2 IF $GET(SPPL)]""
- DO DRUGINT
- +3 GOTO D1
- +4 ;
- DRUGINT ;441 PAPI
- +1 WRITE !!,$CHAR(7),"Drug Interaction Rx(s) "
- FOR I=1:1
- if $PIECE(SPPL,",",I)=""
- QUIT
- WRITE $PIECE(^PSRX($PIECE(SPPL,",",I),0),"^")_", "
- +2 SET PPL=SPPL
- SET DG=1
- DO Q
- KILL DG,SPPL
- +3 QUIT