- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL.m
r613 r623 1 PSORXL 2 ;;7.0;OUTPATIENT PHARMACY;**8,21,24,32,47,135,148,208**;DEC 1997;Build 41 3 4 5 6 7 8 9 10 11 LBL 12 13 14 15 16 17 TRI 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 SETP 36 37 38 39 40 41 PASS 42 43 44 45 46 47 48 49 50 51 52 53 54 EX 55 Q 56 57 58 59 Q1 60 61 62 63 64 QLBL 65 66 67 68 69 70 71 72 73 74 75 PLBL 76 77 QPRF 78 79 80 QUEUP 81 82 83 84 S 85 SUS 86 87 88 89 90 91 92 93 94 95 96 97 98 99 SUSL1 100 H1 101 102 103 104 H 105 106 107 108 109 110 D1 111 RXS 112 113 114 115 116 117 P 118 119 120 121 P1 122 123 124 125 RXSQ 126 127 RSAVE 128 129 130 131 132 RREST 133 134 135 136 1 PSORXL ;BHAM ISC/SAB - action to be taken on prescriptions ;3/13/07 19:21 2 ;;7.0;OUTPATIENT PHARMACY;**8,21,24,32,47,135,148,208**;DEC 1997;Build 39 3 ; Modified from FOIA VistA 4 ; Copyright (C) GNU GPL 2007 WorldVistA 5 ; 6 ;Ext ref to File #50 supported by DBIA 221 7 ;Ext refs CHPUS^IBACUS and TRI^IBACUS supported by DBIA 203 8 I $G(PSOTRVV),$G(PPL) S PSORX("PSOL",1)=PPL K PPL 9 N SLBL,PSOSONE,PSOKLRXS 10 S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$P(PSOPAR,"^",26) P 11 LBL I $G(PSOAFYN)'="Y" W !! S DIR("A",1)="Label Printer: "_$S($G(SUSPT):PSLION,1:$G(PSOLAP)) 12 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 " 13 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" 14 S DIR("?",2)="Enter 'H' to hold label until Rx can be filled",DIR("?",3)="Enter 'P' for Rx profile" 15 S DIR("?",5)="Enter 'C' to select another label printer" 16 S:$P(PSOPAR,"^",26) DIR("?",5)="Enter 'L' to print labels without queuing" 17 TRI ; 18 S X="IBACUS" X ^%ZOSF("TEST") K X I '$T G PASS 19 I '$$TRI^IBACUS() G PASS 20 I '$D(PSORX("PSOL",1))!($G(PSOSUREP))!($G(PSOEXREP)) G PASS 21 N GGG,PBILL,PSTRD,PSTRDZ,PSTRF,PSTRP,TRXI,TRIRX,PSTRIVAR,VV,VVV,VVCT 22 D DEV^PSOCPTRI 23 K ^TMP($J,"PSONOB"),^TMP($J,"PSOBILL") 24 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 25 .I '$G(DT) S DT=$$DT^XLFDT 26 .I $P($G(^PSRX(+TRXI,"STA")),"^")=3 Q 27 .S PSTRP=$P($G(^PSRX(+TRXI,0)),"^",2),PSTRD=+$G(PSOSITE),PSTRDZ=+$G(DUZ) 28 .S PSTRF=0 F GGG=0:0 S GGG=$O(^PSRX(+TRXI,1,GGG)) Q:'GGG S PSTRF=GGG 29 .S VVCT=VVCT+1 30 .I $G(RXRP(TRXI))!($G(RXPR(TRXI)))!($G(RXRH(TRXI))) S ^TMP($J,"PSONOB",VVCT)=TRXI Q 31 .S PBILL=$$CHPUS^IBACUS(PSTRP,DT,TRXI,PSTRF,PSOLAP,PSTRD,PSTRDZ) S ^TMP($J,$S($G(PBILL):"PSOBILL",1:"PSONOB"),VVCT)=TRXI 32 I '$D(^TMP($J,"PSOBILL")) K ^TMP($J,"PSONOB") G PASS 33 I '$D(^TMP($J,"PSONOB")),$D(^TMP($J,"PSOBILL")) S (Y,LBL)="H" G H1 34 ; 35 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 36 .I $G(PSORX("PSOL",1))="" S PSORX("PSOL",1)=TRIRX_"," Q 37 .I $L(PSORX("PSOL",VVCT))+$L(TRIRX)<220 S PSORX("PSOL",VVCT)=PSORX("PSOL",VVCT)_TRIRX_"," Q 38 .S VVCT=VVCT+1 S PSORX("PSOL",VVCT)=TRIRX_"," 39 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 40 K ^TMP($J,"PSONOB") S PPL=$G(PSORX("PSOL",1)) 41 PASS ; 42 I $G(PSOAFYN)'="Y" I $E($G(DIR("A")),1,6)'="LABEL:" D RESDIR^PSOCPTRI 43 I $G(PSOAFYN)'="Y" 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 44 .I $G(PSOAFYN)'="Y" I $D(DIRUT)!($D(DUOUT)) D AL^PSOLBL("UT") I $G(PSOEXREP) S PSOEXREX=1 45 .I $G(PSOAFYN)'="Y" I $G(PSOPULL) I $D(DIRUT)!($D(DUOUT)) S PSOQFLAG=1 46 I $G(PSOAFYN)="Y" S PSOLAP=$G(^SC(+ORL,"AFRXCLINPRNT")) 47 I $G(PSOAFYN)="Y" I PSOLAP="" S DIRUT="^" G:$D(DIRUT)!($D(DUOUT)) EX 48 I $G(PSOAFYN)="Y" S PSOLAP=$P(^%ZIS(1,PSOLAP,0),"^",1) 49 S:$G(PSOBEDT) NOPP=Y 50 I $G(Y)="C" K PSOCLBL,%ZIS("B") S PSOCLBL=1 D @$S('$D(PSOPAR):"^PSOLSET",1:"PLBL^PSOLSET") K PSOCLBL G LBL 51 I $G(Y)="Q",$D(RXRS),'$G(PSOPULL) D PPLADD^PSOSUPOE 52 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 53 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 54 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 55 Q S PPL1=1 G:$G(PPL)']"" D1 S PSNP=0,PSL=1 D I $G(PSOFROM)="NEW",$P(PSOPAR,"^",8) S PSNP=1 56 .Q:'$P(PSOPAR,"^",8)!($G(PSONOPRT)) 57 .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 58 I $G(PSOLAP)]"",$G(PSOLAP)'=ION G QLBL 59 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 60 .S PSOQFLAG=1 61 N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST 62 S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10) 63 D ^%ZISC S PSL=0 64 QLBL I $G(PSXSYS),('$G(RXLTOP)),('$G(PSOEXREP)) D RXL^PSOCMOP G:'$G(PPL) D1 65 ;- Submitting list of Rx to ECME for DUR/79 REJECT check and possible submission to 3rd Pary Payer 66 I $G(PSOAFYN)'="Y" D ECME^PSORXL1 ;vfah 67 ; 68 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 69 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)="" 70 S ZTSAVE("PSOAFDFN")="",ZTSAVE("PSOAFDUZ")="",ZTSAVE("PSOAFYN")="",ZTSAVE("PSOAFPAT")="",ZTSAVE("PSOAFPNM")="",ZTSAVE("VFASDD")="",ZTSAVE("ORL")="" ;vfah 71 S ZTSAVE("PSORX(")="",ZTSAVE("RXRP(")="",ZTSAVE("RXPR(")="",ZTSAVE("RXRS(")="",ZTSAVE("RXFL(")="",ZTSAVE("PCOMH(")="" 72 D ^%ZISC,^%ZTLOAD K:$G(PSOSONE) RXRS W:$D(ZTSK)&('$G(SUSPT))&('$G(PSOEXREP)) !!,"LABEL(S) QUEUED TO PRINT",!! 73 Q:$G(PSPARTXX) K G,PDUZ K:'$G(SUSPT) ZTSK Q:$G(DG) 74 G:'$G(PSNP) QUEUP G:$G(PSOPRFLG) QUEUP S HOLDRPAS=$G(PSOPRPAS),PSOPRPAS=$P(PSOPAR,"^",13) 75 PLBL S PSOION=ION 76 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 77 QPRF S ZTRTN="DQ^PSOPRF",ZTIO=PSOPROP,ZTDESC="Outpatient Pharmacy "_$S($G(SUSPT):"SUSPENSE ",1:"")_"PATIENT PROFILES",ZTDTH=$S($G(PSOTIME):PSOTIME,1:$H) 78 F G="PSOPAR","PSODTCUT","PSOPRPAS","DFN","PSOSITE","NEW1","NEW11","PSOBMST","PFIO","PPL" S:$D(@G) ZTSAVE(G)="" 79 D ^%ZTLOAD W:$D(ZTSK)&('$G(SUSPT))&('$G(PSOEXREP)) !,"PROFILE IS QUEUED TO PRINT",!! K G K:'$G(SUSPT) ZTSK D ^%ZISC 80 QUEUP D:$G(POP)&($G(PSONOPRT)) Q:$G(PSOQFLAG) S PSNP=0,PSOPRPAS=$G(HOLDRPAS) K:PSOPRPAS']"" PSOPRPAS K HOLDRPAS G D1 81 .S PSOQFLAG=1 82 Q 83 ; 84 S G S^PSORXL1 85 SUS S X="IBACUS" X ^%ZOSF("TEST") K X I '$T G SUSL1 86 N TRIDA S TRIDA=DA I '$$TRI^IBACUS() S DA=TRIDA G SUSL1 87 I $G(RXRP(TRIDA))!($G(RXPR(TRIDA)))!($G(RXRH(TRIDA))) S DA=TRIDA G SUSL1 88 N PBILL,PSTRD,PSTRDZ,PSTRF,PSTRP,GGG 89 D DEV^PSOCPTRI 90 I '$G(DT) S DT=$$DT^XLFDT 91 S PSTRP=$P($G(^PSRX(+TRIDA,0)),"^",2),PSTRD=+$G(PSOSITE),PSTRDZ=+$G(DUZ) 92 S PSTRF=0 F GGG=0:0 S GGG=$O(^PSRX(+TRIDA,1,GGG)) Q:'GGG S PSTRF=GGG 93 S PBILL=$$CHPUS^IBACUS(PSTRP,DT,TRIDA,PSTRF,PSOLAP,PSTRD,PSTRDZ) 94 I '$G(PBILL) S DA=TRIDA G SUSL1 95 S FLD(99)="99",FLD(99.1)="Awaiting CHAMPUS billing approval" 96 N RSDT,ACT,PSUS,RXF,RFN,I,PSDA,NOW,IR,FDA 97 S DA=TRIDA D H^PSOCPTRH 98 Q 99 SUSL1 G SUS^PSORXL1 100 H1 S PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1)) 101 D:'$D(^TMP($J,"PSOBILL")) NOOR^PSOHLD I $D(DIRUT) K DIRUT G PSORXL 102 I $D(^TMP($J,"PSOBILL")) S FLD(99)="99",FLD(99.1)="Awaiting CHAMPUS billing approval" G H 103 G:$G(PPL)']"" D1 D FLD^PSOHLD I $D(DUOUT)!($D(DIRUT)) K DIRUT,DUOUT,FLD,DIR G LBL 104 H K SPPL G:$D(DTOUT) D1 S SPPL="" F PI=1:1 Q:$P(PPL,",",PI)="" D 105 .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 106 .I $P(^PSRX(DA,"STA"),"^")=4 S SPPL=SPPL_DA_"," Q 107 I $G(SPPL)]"" D 108 .W !!,$C(7),"Drug Interaction Rx(s) " F I=1:1 Q:$P(SPPL,",",I)="" W $P(^PSRX($P(SPPL,",",I),0),"^")_", " 109 .S PPL=SPPL,DG=1 D Q K DG,SPPL 110 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") 111 RXS I $D(RXRS),'$G(PSOKLRXS) I $G(SLBL)="H"!($G(SLBL)="S")!($G(SLBL)="^")!($G(SLBL)="") D G:$G(PPL)'="" Q 112 .K PPL,PSORX("PSOL") S PSOSONE=1 D PPLADD^PSOSUPOE 113 .Q:$G(PPL)="" W !!,"You have selected the following Rx(s) to be pulled from suspense:",! 114 .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)),"^") 115 .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 116 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 117 P S PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$G(PPL)']"" D1 118 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 119 S IOP=PSOLAP D ^%ZIS 120 N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST 121 P1 S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10),PDUZ=DUZ D DQ1^PSOLBL,^%ZISC 122 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 123 S IOP=PSOPROP D ^%ZIS D DQ^PSOPRF,^%ZISC G D1 124 Q 125 RXSQ K RXRS G RXS 126 Q 127 RSAVE N PMX 128 S PMX="" F S PMX=$O(RXRP(PMX)) Q:PMX="" S PSORSAVE(PMX)=RXRP(PMX) 129 S PMX="" F S PMX=$O(RXPR(PMX)) Q:PMX="" S PSOPSAVE(PMX)=RXPR(PMX) 130 S PMX="" F S PMX=$O(RXRH(PMX)) Q:PMX="" S PSOHSAVE(PMX)=RXRH(PMX) 131 Q 132 RREST N PMXZ 133 S PMXZ="" F S PMXZ=$O(PSORSAVE(PMXZ)) Q:PMXZ="" S RXRP(PMXZ)=PSORSAVE(PMXZ) 134 S PMXZ="" F S PMXZ=$O(PSOPSAVE(PMXZ)) Q:PMXZ="" S RXPR(PMXZ)=PSOPSAVE(PMXZ) 135 S PSMX="" F S PMXZ=$O(PSOHSAVE(PMXZ)) Q:PMXZ="" S RXRH(PMXZ)=PSOHSAVE(PMXZ) 136 Q
Note:
See TracChangeset
for help on using the changeset viewer.
