Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSORXL

PSORXL.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Reference to ^PSDRUG( in ICR #221
  1. ; Reference to CHPUS^IBACUS,TRI^IBACUS in ICR #2030
  1. ; Added kill for BINGRTE to force bypass of Bingo board prompt if choose H (Hold) or PK (Park) - PaPI ;441
  1. ;
  1. D PPLPARK^PSORXL1 I $G(PPL)="",'$O(RXRS(0)),$G(PSORX("PSOL",1))="" G RXSQUIT
  1. I $G(PSOTRVV),$G(PPL) S PSORX("PSOL",1)=PPL K PPL
  1. N SLBL,PSOSONE,PSOKLRXS,PSOSKIP S PSOSKIP=1
  1. S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$P(PSOPAR,"^",26) P
  1. LBL ;
  1. 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
  1. N RESULTS,PSOPARKX,PSOCNT
  1. S RESULTS="PSOPARKX" D GETPARK^PSORPC01()
  1. W !! S DIR("A",1)="Label Printer: "_$S($G(SUSPT):PSLION,1:$G(PSOLAP))
  1. I $$GET1^DIQ(59,PSOSITE,134)'="" D
  1. . I $G(PSOFDAPT)="" S PSOFDAPT=$$DEFPRT^PSOFDAUT(PSOSITE)
  1. . S DIR("A",2)="FDA Med Guide Printer: "_$S($G(PSOFDAPT)="":"HOME",1:$P(PSOFDAPT,"^"))
  1. S DIR("A")="LABEL: QUEUE/CHANGE PRINTER"_$S($P(PSOPAR,"^",23)&($D(^XUSEC("PSORPH",DUZ))!($D(^XUSEC("PSO TECH ADV",DUZ)))):"/HOLD",1:"")
  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
  1. 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
  1. 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"
  1. S DIR("?",2)="Enter 'H' to hold label until Rx can be filled",DIR("?",3)="Enter 'PR' for Rx profile"
  1. S PSOCNT=5
  1. I $G(PSOPARKX(0))="YES" S DIR("?",PSOCNT)="Enter 'PK' to Park prescription(s)",PSOCNT=PSOCNT+1 ;441 PAPI
  1. S DIR("?",PSOCNT)="Enter 'C' to select another label printer"
  1. I $P(PSOPAR,"^",26) S PSOCNT=PSOCNT+1,DIR("?",PSOCNT)="Enter 'L' to print labels without queuing"
  1. TRI ;Tricare
  1. S X="IBACUS" X ^%ZOSF("TEST") K X I '$T G PASS
  1. I '$$TRI^IBACUS() G PASS
  1. I '$D(PSORX("PSOL",1))!($G(PSOSUREP))!($G(PSOEXREP)) G PASS
  1. N GGG,PBILL,PSTRD,PSTRDZ,PSTRF,PSTRP,TRXI,TRIRX,PSTRIVAR,VV,VVV,VVCT
  1. D DEV^PSOCPTRI
  1. K ^TMP($J,"PSONOB"),^TMP($J,"PSOBILL")
  1. 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
  1. .I '$G(DT) S DT=$$DT^XLFDT
  1. .I $P($G(^PSRX(+TRXI,"STA")),"^")=3 Q
  1. .S PSTRP=$P($G(^PSRX(+TRXI,0)),"^",2),PSTRD=+$G(PSOSITE),PSTRDZ=+$G(DUZ)
  1. .S PSTRF=0 F GGG=0:0 S GGG=$O(^PSRX(+TRXI,1,GGG)) Q:'GGG S PSTRF=GGG
  1. .S VVCT=VVCT+1
  1. .I $G(RXRP(TRXI))!($G(RXPR(TRXI)))!($G(RXRH(TRXI))) S ^TMP($J,"PSONOB",VVCT)=TRXI Q
  1. .S PBILL=$$CHPUS^IBACUS(PSTRP,DT,TRXI,PSTRF,PSOLAP,PSTRD,PSTRDZ) S ^TMP($J,$S($G(PBILL):"PSOBILL",1:"PSONOB"),VVCT)=TRXI
  1. I '$D(^TMP($J,"PSOBILL")) K ^TMP($J,"PSONOB") G PASS
  1. I '$D(^TMP($J,"PSONOB")),$D(^TMP($J,"PSOBILL")) S (Y,LBL)="H" G H1
  1. ;If some Rx's are billable, and some are not
  1. 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
  1. .I $G(PSORX("PSOL",1))="" S PSORX("PSOL",1)=TRIRX_"," Q
  1. .I $L(PSORX("PSOL",VVCT))+$L(TRIRX)<220 S PSORX("PSOL",VVCT)=PSORX("PSOL",VVCT)_TRIRX_"," Q
  1. .S VVCT=VVCT+1 S PSORX("PSOL",VVCT)=TRIRX_","
  1. 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
  1. K ^TMP($J,"PSONOB") S PPL=$G(PSORX("PSOL",1))
  1. PASS ;
  1. I '$D(RESULTS) N RESULTS,PSOPARKX S RESULTS="PSOPARKX" D GETPARK^PSORPC01()
  1. I $E($G(DIR("A")),1,6)'="LABEL:" D RESDIR^PSOCPTRI
  1. 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:"")
  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
  1. 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
  1. .I $D(DIRUT)!($D(DUOUT)) D AL^PSOLBL("UT") I $G(PSOEXREP) S PSOEXREX=1
  1. .I $G(PSOPULL) I $D(DIRUT)!($D(DUOUT)) S PSOQFLAG=1
  1. S:$G(PSOBEDT) NOPP=Y
  1. I $G(Y)="C" K PSOCLBL,%ZIS("B") S PSOCLBL=1 D @$S('$D(PSOPAR):"^PSOLSET",1:"PLBL^PSOLSET") K PSOCLBL G LBL
  1. I $G(Y)="Q",$D(RXRS),'$G(PSOPULL) D PPLADD^PSOSUPOE
  1. 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
  1. ;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
  1. 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
  1. 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
  1. Q S PPL1=1 G:$G(PPL)']"" D1 S PSNP=0,PSL=1 D I $G(PSOFROM)="NEW",$P(PSOPAR,"^",8) S PSNP=1
  1. .Q:'$P(PSOPAR,"^",8)!($G(PSONOPRT))
  1. .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
  1. I $G(PSOLAP)]"",$G(PSOLAP)'=ION G Q2
  1. Q1 W ! K POP S %ZIS("B")="",%ZIS="MNQ",%ZIS("A")="Select LABEL DEVICE: " D ^%ZIS S PSLION=ION K %ZIS("A")
  1. G:$G(POP)&($G(PSPARTXX)) RXSQUIT G:$G(POP)&($G(PSOSONE)) RXSQ D:$G(POP)&($G(PSONOPRT))
  1. .S PSOQFLAG=1
  1. G:$G(PSOQFLAG) RXSQUIT G:POP!(IO=IO(0)) LBL S PSOLAP=ION ;*334
  1. N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
  1. S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10)
  1. D ^%ZISC S PSL=0
  1. Q2 ; Checking FDA Med Guide printer
  1. I ($$GET1^DIQ(59,PSOSITE,134)="")!($G(PSOEXREP)&'$G(PSOMGREP))!'$$FDARX(PPL)!($G(PSOSKIP)&($G(PSOFDAPT)'="")) G QLBL
  1. I $G(PSOEXREP),'$G(PSOMGREP) G QLBL
  1. N FDAPRT S FDAPRT=""
  1. F D Q:FDAPRT'=""!(FDAPRT="^")
  1. . S FDAPRT=$$SELPRT^PSOFDAUT($P($G(PSOFDAPT),"^"))
  1. . I FDAPRT="" W $C(7),!,"You must select a valid FDA Medication Guide printer."
  1. I FDAPRT="^"!(FDAPRT="") G LBL
  1. S PSOFDAPT=FDAPRT
  1. ;
  1. QLBL I $G(PSXSYS),('$G(RXLTOP)),('$G(PSOEXREP)) D RXL^PSOCMOP G:'$G(PPL) D1
  1. ;
  1. ;- Submitting list of Rx to ECME for DUR/79 REJECT check and possible submission to 3rd Pary Payer
  1. D ECME^PSORXL1 I '$G(PPL) W !!,"No Label(s) printed.",!! S PSOQFLAG=1 G RXSQUIT ;*334
  1. ;
  1. ;S PDUZ=DUZ G DQ^PSOLBL
  1. S ZTRTN="DQ^PSOLBL",ZTIO=$S($G(SUSPT):PSLION,1:PSOLAP),ZTDTH=$S($G(PSOTIME):PSOTIME,1:$H),PDUZ=DUZ,OPAIO=ZTIO
  1. S ZTDESC="Outpatient Pharmacy "_$S($G(SUSPT):"SUSPENSE ",$G(DG):"DRUG INTERACTION ",1:"")_"LABELS OUTPUT ROUTINE"
  1. ;PSO 658 - Pass PSOLAP, remove PFION since it isn't used anyplace,
  1. F G="PPL1","PSOSYS","DFN","PSOPAR","PDUZ","PCOMX","PSOLAP","PPL" S:$D(@G) ZTSAVE(G)=""
  1. F G="RXY","PSOSITE","COPIES","SIDE","PSOSUSPR","PSOBARS","PSOBAR1","PSOBAR0","PSODELE" S:$D(@G) ZTSAVE(G)=""
  1. F G="PSOPULL","PSTAT","PSODBQ","PSOEXREP","PSOTREP","PSOFDAPT","PSOMGREP" S:$D(@G) ZTSAVE(G)=""
  1. S ZTSAVE("PSORX(")="",ZTSAVE("RXRP(")="",ZTSAVE("RXPR(")="",ZTSAVE("RXRS(")="",ZTSAVE("RXFL(")="",ZTSAVE("PCOMH(")=""
  1. D ^%ZISC,^%ZTLOAD K:$G(PSOSONE) RXRS
  1. I $D(ZTSK)&('$G(SUSPT))&('$G(PSOEXREP)) D
  1. . W !!,"LABEL(S) QUEUED TO PRINT",!!
  1. . D OPAI
  1. K OPAIO
  1. G:$G(PSPARTXX) RXSQUIT K G,PDUZ K:'$G(SUSPT) ZTSK G:$G(DG) RXSQUIT ;*334
  1. G:'$G(PSNP) QUEUP G:$G(PSOPRFLG) QUEUP S HOLDRPAS=$G(PSOPRPAS),PSOPRPAS=$P(PSOPAR,"^",13)
  1. PLBL S PSOION=ION
  1. 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
  1. QPRF S ZTRTN="DQ^PSOPRF",ZTIO=PSOPROP,ZTDESC="Outpatient Pharmacy "_$S($G(SUSPT):"SUSPENSE ",1:"")_"PATIENT PROFILES",ZTDTH=$S($G(PSOTIME):PSOTIME,1:$H)
  1. F G="PSOPAR","PSODTCUT","PSOPRPAS","DFN","PSOSITE","NEW1","NEW11","PSOBMST","PFIO","PPL" S:$D(@G) ZTSAVE(G)=""
  1. D ^%ZTLOAD W:$D(ZTSK)&('$G(SUSPT))&('$G(PSOEXREP)) !,"PROFILE IS QUEUED TO PRINT",!! K G K:'$G(SUSPT) ZTSK D ^%ZISC
  1. QUEUP D:$G(POP)&($G(PSONOPRT)) G:$G(PSOQFLAG) RXSQUIT S PSNP=0,PSOPRPAS=$G(HOLDRPAS) K:PSOPRPAS']"" PSOPRPAS K HOLDRPAS G D1 ;*334
  1. .S PSOQFLAG=1
  1. Q
  1. ;
  1. S G S^PSORXL1
  1. SUS S X="IBACUS" X ^%ZOSF("TEST") K X I '$T G SUSL1
  1. N TRIDA S TRIDA=DA I '$$TRI^IBACUS() S DA=TRIDA G SUSL1
  1. I $G(RXRP(TRIDA))!($G(RXPR(TRIDA)))!($G(RXRH(TRIDA))) S DA=TRIDA G SUSL1
  1. N PBILL,PSTRD,PSTRDZ,PSTRF,PSTRP,GGG
  1. D DEV^PSOCPTRI
  1. I '$G(DT) S DT=$$DT^XLFDT
  1. S PSTRP=$P($G(^PSRX(+TRIDA,0)),"^",2),PSTRD=+$G(PSOSITE),PSTRDZ=+$G(DUZ)
  1. S PSTRF=0 F GGG=0:0 S GGG=$O(^PSRX(+TRIDA,1,GGG)) Q:'GGG S PSTRF=GGG
  1. S PBILL=$$CHPUS^IBACUS(PSTRP,DT,TRIDA,PSTRF,PSOLAP,PSTRD,PSTRDZ)
  1. I '$G(PBILL) S DA=TRIDA G SUSL1
  1. S FLD(99)="99",FLD(99.1)="Awaiting CHAMPUS billing approval"
  1. N RSDT,ACT,PSUS,RXF,RFN,I,PSDA,NOW,IR,FDA
  1. S DA=TRIDA D H^PSOCPTRH
  1. Q
  1. SUSL1 G SUS^PSORXL1
  1. H1 S PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1))
  1. D:'$D(^TMP($J,"PSOBILL")) NOOR^PSOHLD I $D(DIRUT) K DIRUT G PSORXL
  1. I $D(^TMP($J,"PSOBILL")) S FLD(99)="99",FLD(99.1)="Awaiting CHAMPUS billing approval" G H
  1. G:$G(PPL)']"" D1 D FLD^PSOHLD I $D(DUOUT)!($D(DIRUT)) K DIRUT,DUOUT,FLD,DIR G LBL
  1. H K SPPL G:$D(DTOUT) D1 S SPPL="" F PI=1:1 Q:$P(PPL,",",PI)="" D
  1. .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
  1. .I $P(^PSRX(DA,"STA"),"^")=4 S SPPL=SPPL_DA_"," Q
  1. I $G(SPPL)]"" D
  1. .W !!,$C(7),"Drug Interaction Rx(s) " F I=1:1 Q:$P(SPPL,",",I)="" W $P(^PSRX($P(SPPL,",",I),0),"^")_", "
  1. .S PPL=SPPL,DG=1 D Q K DG,SPPL
  1. 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")
  1. RXS I $D(RXRS),'$G(PSOKLRXS) I $G(SLBL)="H"!($G(SLBL)="S")!($G(SLBL)="^")!($G(SLBL)="") D G:$G(PPL)'="" Q
  1. .K PPL,PSORX("PSOL") S PSOSONE=1 D PPLADD^PSOSUPOE
  1. .Q:$G(PPL)="" W !!,"You have selected the following Rx(s) to be pulled from suspense:",!
  1. .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)),"^")
  1. .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
  1. 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
  1. P S PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$G(PPL)']"" D1
  1. 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
  1. S IOP=PSOLAP D ^%ZIS
  1. N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
  1. P1 S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10),PDUZ=DUZ D DQ1^PSOLBL,^%ZISC
  1. 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
  1. S IOP=PSOPROP D ^%ZIS D DQ^PSOPRF,^%ZISC G D1
  1. Q
  1. RXSQ K RXRS G RXS
  1. Q
  1. FDARX(PPL) ; Check if any Rx to be printed has an FDA Med Guide
  1. N FDARX,FDARXIEN,I S FDARX=0
  1. F I=1:1:$L($G(PPL),",") D Q:FDARX
  1. . S FDARXIEN=+$P(PPL,",",I) I 'FDARXIEN Q
  1. . I $D(RXRP(FDARXIEN)),'$D(RXRP(FDARXIEN,"MG")) Q
  1. . I FDARXIEN,$$MGONFILE^PSOFDAUT(FDARXIEN) S FDARX=1
  1. Q FDARX
  1. ;
  1. RSAVE N PMX
  1. S PMX="" F S PMX=$O(RXRP(PMX)) Q:PMX="" S PSORSAVE(PMX)=RXRP(PMX)
  1. S PMX="" F S PMX=$O(RXPR(PMX)) Q:PMX="" S PSOPSAVE(PMX)=RXPR(PMX)
  1. S PMX="" F S PMX=$O(RXRH(PMX)) Q:PMX="" S PSOHSAVE(PMX)=RXRH(PMX)
  1. Q
  1. RREST N PMXZ
  1. S PMXZ="" F S PMXZ=$O(PSORSAVE(PMXZ)) Q:PMXZ="" S RXRP(PMXZ)=PSORSAVE(PMXZ)
  1. S PMXZ="" F S PMXZ=$O(PSOPSAVE(PMXZ)) Q:PMXZ="" S RXPR(PMXZ)=PSOPSAVE(PMXZ)
  1. S PMXZ="" F S PMXZ=$O(PSOHSAVE(PMXZ)) Q:PMXZ="" S RXRH(PMXZ)=PSOHSAVE(PMXZ)
  1. Q
  1. ;
  1. OPAI ;This section of code will display where an RX is routed.
  1. ;To determine where an RX will be routed, check:
  1. ;1) if the drug for the RX is associated with an ADD device in
  1. ; file #50 and if the printer is in the DISPENSING SYSTEM
  1. ; PRINTER multiple sub-file #59.02008. If it is then the RX
  1. ; will display as being routed to that device.
  1. ;2) Otherwise, the category of the ADD associated with the
  1. ; printer in sub-file #59.20081 will be used to determine
  1. ; where the RX will be routed and the ADD displayed.
  1. ;
  1. N DIC,X,Y,PN,II,RX,DEV,DDEV,ADD,DAT,DAT1,PDAT,DRG,DRG0,OPAI,CSB,RTE,FLG
  1. N ZTIO,MTH,NPPL
  1. I ($G(OPAIO)="")!($G(PPL)="") Q
  1. S DIC=3.5,DIC(0)="",X=OPAIO D ^DIC K DIC,X Q:Y=-1 S ZTIO=+Y
  1. S FLG=1,DEV=0,PN=$O(^PS(59,PSOSITE,"P","B",ZTIO,"")) I PN="" Q
  1. I '$P($G(PSOPAR),"^",30) Q
  1. I $$GET1^DIQ(59,PSOSITE_",",105,"I")'=2.4 Q
  1. ;
  1. ;ADD array built base on category.
  1. ; if category is not "S" then
  1. ; ADD(category)=ADD name^dns^port^inactive date
  1. ; if category is "S" then (Category "S" can be multiple)
  1. ; ADD(category,ADD name)=ADD name^dns^port^inactive date
  1. ;Array OPAI will be used to display the data on the screen.
  1. ; OPAI(ADD name)=ADD name^dns^port^inactive date
  1. ; OPAI(ADD name,RX)=drug
  1. ;
  1. F S DEV=$O(^PS(59,PSOSITE,"P",PN,"OPAI",DEV)) Q:'DEV D
  1. .S DAT=$G(^PS(59,PSOSITE,"P",PN,"OPAI",DEV,0)) I $P(DAT,"^",2)="" Q
  1. .S DAT1=$$ADDCHK^PSOHLDS($P(DAT,"^"))
  1. .I DAT1 D
  1. ..I $P(DAT,"^",2)'="S" S ADD($P(DAT,"^",2))=$P(DAT1,"^",2,99) Q
  1. ..S ADD($P(DAT,"^",2),$P(DAT1,"^",2))=$P(DAT1,"^",2,99)
  1. S NPPL=""
  1. F II=1:1:$L(PPL,",") S RX=$P(PPL,",",II) D:RX'=""
  1. .I $G(RXRP(RX,"RP")) Q
  1. .S PDAT=$G(^PSRX(RX,0)),DRG=$P(PDAT,"^",6),RTE=$$RTE()
  1. .S DRG0=$G(^PSDRUG(+DRG,0)),DDEV=$G(^PSDRUG(+DRG,"OPAI",PSOSITE,0))
  1. .I $S($P(PSOPAR,"^",30)=3:1,$P(PSOPAR,"^",30)=4:1,1:0),'$$GET1^DIQ(50,DRG,28,"I") Q
  1. .S NPPL=NPPL_","_RX,DAT1=$$ADDCHK^PSOHLDS($S(RTE="W":$P(DDEV,"^",2),RTE="M":$P(DDEV,"^",3),1:"")) I DAT1 D Q
  1. ..D SETOP($P(DAT1,"^",2,99),$P(PDAT,"^"),$P(DRG0,"^"))
  1. .I $D(ADD("A")) D SETOP(ADD("A"),$P(PDAT,"^"),$P(DRG0,"^")) Q
  1. .S CSB=+$P(DRG0,"^",3),CSB=$S((CSB>0)&(CSB<6):"CS",1:"NCS")
  1. .I $D(ADD(CSB)) D SETOP(ADD(CSB),$P(PDAT,"^"),$P(DRG0,"^")) Q
  1. .I $D(ADD(RTE_CSB)) D SETOP(ADD(RTE_CSB),$P(PDAT,"^"),$P(DRG0,"^")) Q
  1. .S MTH=$S(RTE="W":"WIND",RTE="M":"MAIL",1:"")
  1. .I MTH'="",$D(ADD(MTH)) D SETOP(ADD(MTH),$P(PDAT,"^"),$P(DRG0,"^"))
  1. .S FLG=0
  1. I FLG Q ;nothing found to print
  1. I ($D(OPAI))!($D(ADD("S"))) W !,"PRESCRIPTIONS SENT TO:" D
  1. .S DEV="" F S DEV=$O(OPAI(DEV)) Q:DEV="" W !?3,DEV D W !
  1. ..S RX=0 F S RX=$O(OPAI(DEV,RX)) Q:'RX W !?5,RX,?20,$P(OPAI(DEV,RX),"^")
  1. I $D(ADD("S")) W !,"STORAGE DEVICES" S II="" D
  1. .F S II=$O(ADD("S",II)) Q:II="" W !?3,II I $D(OPAI) ;W ?20,"The above Prescriptions"
  1. .F II=1:1:$L(NPPL,",") S RX=$P(NPPL,",",II) D:RX'=""
  1. ..Q:$G(RXRP(RX,"RP")) S PDAT=$G(^PSRX(RX,0)),DRG=$P($G(^PSDRUG(+$P(PDAT,"^",6),0)),"^")
  1. ..W !?5,$P(PDAT,"^"),?20,DRG
  1. .W !
  1. Q
  1. ;
  1. SETOP(DINF,DRX,DDRG) ; Set OPAI array
  1. N DNAM
  1. S DNAM=$P(DINF,"^"),OPAI(DNAM)=DINF,OPAI(DNAM,DRX)=DDRG,FLG=0
  1. Q
  1. ;
  1. RTE() ; get route for RX
  1. N FP,FPN,LRF,MW,XX
  1. S FP=$S($G(RXPR(RX)):"P",1:"F")
  1. 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
  1. 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))
  1. S FPN=$S($G(RXPR(RX)):RXPR(RX),1:$G(LRF))
  1. I FP="F"&('FPN) S MW=$P($G(^PSRX(RX,0)),"^",11) ;original
  1. I FP="F"&(FPN) S MW=$P($G(^PSRX(RX,1,FPN,0)),"^",2) ;refill
  1. I FP="P"&(FPN) S MW=$P($G(^PSRX(RX,"P",FPN,0)),"^",2) ;partial
  1. Q $G(MW)
  1. PK1 ;
  1. G:$D(DTOUT) D1
  1. S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) ;441 PAPI
  1. I $D(RXRS) S PI=0 F S PI=$O(RXRS(PI)) Q:'PI D
  1. .I $G(PPL)="" S PPL=PI_"," Q
  1. .Q:PPL[PI
  1. .S PPL=PPL_PI_","
  1. G:$G(PPL)']"" D1
  1. PK ;
  1. D PK^PSORXL1 ;*712
  1. I $G(SPPL)]"" D DRUGINT
  1. G D1
  1. ;
  1. DRUGINT ;441 PAPI
  1. W !!,$C(7),"Drug Interaction Rx(s) " F I=1:1 Q:$P(SPPL,",",I)="" W $P(^PSRX($P(SPPL,",",I),0),"^")_", "
  1. S PPL=SPPL,DG=1 D Q K DG,SPPL
  1. Q