- 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/PSOLBLN.m
r613 r623 1 PSOLBLN 2 ;;7.0;OUTPATIENT PHARMACY;**16,36,71,107,110,117,135,233,208**;DEC 1997;Build 41 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 ST 31 32 33 34 35 36 37 38 39 40 L1 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 L11 59 L12 60 61 62 63 64 65 66 67 68 69 70 71 72 L13 73 74 75 PSOAFPL1 76 77 REP 78 79 80 81 82 83 84 85 86 87 88 89 PSOAFPL2 90 91 92 93 94 PSOAFPL3 95 96 END 97 98 99 100 101 102 103 104 105 PSOAFP 106 107 108 109 110 111 AFFAX 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 AFPTS 129 130 131 132 133 AFPTL 134 135 AFKILL 136 1 PSOLBLN ;BIR/RTR-NEW PRINTS LABEL ; 3/11/07 1:56pm 2 ;;7.0;OUTPATIENT PHARMACY;**16,36,71,107,110,117,135,233,208**;DEC 1997;Build 39 3 ; Modified from FOIA VistA 4 ; Copyright (C) 2007 WorldVistA 5 ; 6 ; This program is free software; you can redistribute it and/or modify 7 ; it under the terms of the GNU General Public License as published by 8 ; the Free Software Foundation; either version 2 of the License, or 9 ; (at your option) any later version. 10 ; 11 ; This program is distributed in the hope that it will be useful, 12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 ; GNU General Public License for more details. 15 ; 16 ; You should have received a copy of the GNU General Public License 17 ; along with this program; if not, write to the Free Software 18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 19 ;External reference to ^PSDRUG supported by DBIA 221 20 ;External reference to ^VA(200 supported by DBIA 224 21 K PSOSTLK,ZTKDRUG I $L($T(PSOSTALK^PSOTALK1)) D PSOSTALK^PSOTALK1 S PSOSTLK=1 ; PRINT SCRIPTALK LABEL IF APPLICABLE 22 I $G(IOS),$G(PSOBARS) I $G(PSOBAR0)=""!($G(PSOBAR1)="") S PSOIOS=IOS D DEVBAR^PSOBMST 23 I $G(DFN) D ADD^VADPT 24 S ADDR(33)=$G(VAPA(4))_", "_$P($G(VAPA(5)),"^",2)_" "_$S($G(VAPA(11))]"":$P($G(VAPA(11)),"^",2),1:$G(VAPA(6))),ADDR(22)="" 25 S:$G(VAPA(2))]"" ADDR(22)=$G(VAPA(2))_" "_$G(VAPA(3)),ADDR(22)=$E(ADDR(22),1,46) S:ADDR(22)="" ADDR(22)=ADDR(33),ADDR(33)="" 26 S ADDR(4)=$S(ADDR(33)="":ADDR(22),1:ADDR(33)) I $G(VAPA(2))="",$G(VAPA(3))="" S ADDR(2)=ADDR(4),ADDR(3)="",ADDR(4)="" G ST 27 I $G(VAPA(2))'="",$G(VAPA(3))="" S ADDR(2)=VAPA(2),ADDR(3)=ADDR(4),ADDR(4)="" G ST 28 I $G(VAPA(2))="",$G(VAPA(3))'="" S ADDR(2)=VAPA(3),ADDR(3)=ADDR(4),ADDR(4)="" G ST 29 S ADDR(2)=$G(VAPA(2)),ADDR(3)=$G(VAPA(3)) 30 ST I $P($G(^PSRX(RX,3)),"^",3) S PSOPROV=+$P(^(0),"^",4) S PSOPROV=$S($G(RXP):+$P($G(RXP),"^",17),$G(RXF):+$P($G(^PSRX(RX,1,RXF,0)),"^",17),1:PSOPROV) S:'$G(PSOPROV) PSOPROV=+$P(^PSRX(RX,0),"^",4) D 31 .I +$P($G(^VA(200,PSOPROV,"PS")),"^",7) S:'$P($G(PHYS),"/",2) PHYS=$G(PHYS)_"/"_+$P($G(^PSRX(RX,3)),"^",3) 32 S COPIES=COPIES-1,$P(ULN,"_",34)="",PSOTRAIL=1 I $G(SIDE) D REP^PSOLBL2 G REP 33 S (Y,X1)=EXPDT X ^DD("DD") S EXPDT=Y,Y=$P(^PSRX(RX,0),"^",13) X ^DD("DD") S ISD=Y,X2=DT D ^%DTC S DIFF=X 34 S Y=DATE X ^DD("DD") S DATE=Y D NOW^%DTC S Y=% X ^DD("DD") S NOW=Y 35 S TECH="("_$S($P($G(^PSRX(+$G(RX),"OR1")),"^",5):$P($G(^PSRX(+$G(RX),"OR1")),"^",5),1:$P(RXY,"^",16))_"/"_$S($G(VRPH)&($P(PSOPAR,"^",32)):VRPH,1:" ")_")" 36 S PSZIP=$P(PS,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:"")) 37 ; 38 I $G(PSOAFYN)="Y" G PSOAFPL1 ;vfah 39 ; 40 L1 W ?3,"VAMC ",$P(PS,"^",7),", ",STATE," ",$G(PSOHZIP),?54,"VAMC ",$P(PS,"^",7),", ",STATE," ",$G(PSOHZIP),?102 W $S($D(REPRINT)&($G(PSOBLALL)):"(GROUP REPRINT)",$D(REPRINT):"(REPRINT)",1:"") W:$G(RXP) "(PARTIAL)" 41 W !?3,$P(PS2,"^",2)," ",$P(PS,"^",3),"-",$P(PS,"^",4)," ",TECH,?54,$P(PS2,"^",2)," ",$P(PS,"^",3),"-",$P(PS,"^",4)," ",TECH,?102,$P(PS2,"^",2)," ",TECH," ",NOW 42 W !,"Rx# ",RXN," ",DATE," Fill ",RXF+1," of ",1+$P(RXY,"^",9),?54,"Rx# ",RXN," ",DATE," Fill ",RXF+1," of ",1+$P(RXY,"^",9),?102,"Rx# ",RXN," ",DATE," Fill ",RXF+1," of ",1+$P(RXY,"^",9) 43 W !,PNM," ",$G(SSNPN),?54,PNM," ",$G(SSNPN),?102,PNM," ",$G(SSNPN) 44 F DR=1:1 Q:$G(SGY(DR))="" D:DR=4!(DR=7)!(DR=10)!(DR=13) W !,$G(SGY(DR)),?54,$G(SGY(DR)),?102,$S($G(OSGY(DR))]"":OSGY(DR),1:$G(SGY(DR))) 45 .F GG=1:1:27 W ! 46 I DR>4 S KK=$S(DR=5!(DR=8)!(DR=11):2,(DR=6)!(DR=9)!(DR=12):1,1:0) I KK F HH=1:1:KK W ! 47 I DR=2 W !! 48 I DR=3 W ! 49 W !,$G(PHYS),?54,$G(PHYS),?102,$G(PHYS) 50 S PSMF=$S($G(NURSE):"Mfg______Exp______",1:""),PSDU=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),660)),"^",8),PSDU=$S(PSDU="":" "_PSMF,1:PSDU_" "_PSMF) 51 W !,"Qty: "_$G(QTY)," ",$G(PSDU),?54,"Qty: "_$G(QTY)," ",$G(PSDU),?102,"Qty: "_$G(QTY)," ",$G(PSDU) 52 S ZTKDRUG="XXXXXX SCRIPTALK RX XXXXXX" 53 I '$G(PSOSTLK) K PSDU,PSMF W !,DRUG,?54,DRUG,?102,DRUG 54 I $G(PSOSTLK) K PSDU,PSMF W !,$S($G(PSOSTALK):ZTKDRUG,1:DRUG),?54,DRUG,?102,DRUG 55 I $P(RXY,"^",9)-RXF'>0 D ^PSOLBLN1 G L13 56 G:DIFF<30 L11 57 W !?54,$P(RXY,"^",9)-RXF," Refills remain prior to ",EXPDT,?102,"Mfg "_$G(MFG)_" Lot# "_$G(LOT) G L12 58 L11 W !?54,"Last fill prior to ",$G(EXPDT),?102,"Mfg "_$G(MFG)_" Lot# "_$G(LOT) 59 L12 W !,$P(PS,"^",2),?54,$S($L($G(COPAYVAR)):$G(COPAYVAR)_" ",1:""),"Days Supply: ",$G(DAYS),?102,"Tech__________RPh_________",!,$P(PS,"^",7),", ",STATE," ",$G(PSOHZIP) 60 ;send a CR for OPTIFIL (P-MT661BC) 61 I $G(PSOBARS),$P(PSOPAR,"^",19)'=1 S X="S",X2=PSOINST_"-"_RX S X1=$X W ?54,@PSOBAR1,X2,@PSOBAR0,$C(13) S $X=0 W:IOST["P-MT661BC" ! 62 E W !!! 63 W !,"FORWARDING SERVICE REQUESTED" W:"C"[$E(MW) !,?21,"CERTIFIED MAIL" W !?54,$G(VAPA(1)) 64 W !,$S($G(PS55)=2:"***DO NOT MAIL***",1:"***CRITICAL MEDICAL SHIPMENT***"),?54,$G(ADDR(2)),?102,"Routing: "_$S("W"[$E(MW):MW,1:MW_" MAIL") 65 W !?54,$G(ADDR(3)),?102,"Days supply: ",$G(DAYS)," Cap: ",$S(PSCAP:"**NON-SFTY**",1:"SAFETY") 66 W !?54,$G(ADDR(4)),?102,"Isd: ",ISD," Exp: ",EXPDT 67 W !,PNM,?54,"*Indicate address change on back of this form",?102,"Last Fill: ",$G(PSOLASTF) 68 W !,$S($D(PSMP(1)):PSMP(1),1:$G(VAPA(1))),?54,"[ ] Permanent",?102,"Pat. Stat ",PATST," Clinic: ",PSCLN 69 W !,$S($D(PSMP(2)):PSMP(2),$D(PSMP(1)):"",1:$G(ADDR(2))),?54,"[ ] Temporary until ",$S($P($G(VAPA(10)),"^",2)]"":$P($G(VAPA(10)),"^",2),1:"__/__/__"),?102,$S($G(WARN)'="":"DRUG WARNING "_$G(WARN),1:"") 70 W !,$S($D(PSMP(3)):PSMP(3),$D(PSMP(1)):"",1:$G(ADDR(3))),!,$S($D(PSMP(4)):PSMP(4),$D(PSMP(1)):"",1:$G(ADDR(4))),?54,"Signature",ULN 71 I $G(PSOBARS) S X="S",X2=PSOINST_"-"_RX S X1=$X W ?102,@PSOBAR1,X2,@PSOBAR0,$C(13) S $X=0 72 L13 I $G(WARN)'="",'$G(PSOBLALL) I '$G(PSDFNFLG),'$G(PSOLAPPL) D WARN^PSOLBL2 73 W @IOF 74 ; 75 PSOAFPL1 I $G(PSOAFYN)="Y" D PSOAFP ;vfah 76 ; 77 REP I COPIES>0 S SIDE=1 G ST 78 D NOW^%DTC S NOW=% K %,%H,%I I $G(RXF)="" S RXF=0 F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I S RXF=I 79 S IR=0 F FDA=0:0 S FDA=$O(^PSRX(RX,"L",FDA)) Q:'FDA S IR=FDA 80 S IR=IR+1,^PSRX(RX,"L",0)="^52.032DA^"_IR_"^"_IR 81 S ^PSRX(RX,"L",IR,0)=NOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_$S($G(PCOMX)]"":$G(PCOMX),$G(PCOMH(RX))]"":PCOMH(RX),1:"From RX number "_$P(^PSRX(RX,0),"^"))_$S($G(RXP):" (Partial)",1:"")_$S($D(REPRINT):" (Reprint)",1:"")_"^"_PDUZ 82 N PSOBADR,PSOTEMP 83 S PSOBADR=$$CHKRX^PSOBAI(RX) 84 I $G(PSOBADR) S PSOTEMP=$P(PSOBADR,"^",2),PSOBADR=$P(PSOBADR,"^") 85 I $G(PSOBADR),'$G(PSOTEMP) D 86 .S IR=IR+1,^PSRX(RX,"L",0)="^52.032DA^"_IR_"^"_IR 87 .S ^PSRX(RX,"L",IR,0)=NOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_"ROUTING="_$G(MW)_" (BAD ADDRESS)"_"^"_PDUZ 88 S ^PSRX(RX,"TYPE")=0 K RXF,IR,FDA,NOW,I,PCOMH(RX) 89 PSOAFPL2 I $G(PSOAFYN)="Y" G PSOAFPL3 ;vfah 90 I $G(WARN)'="" I $G(PSDFNFLG)!($G(PSOLAPPL)) D ALLWARN^PSOLBLN1 91 I $G(WARN)="" I $G(PSDFNFLG)!($G(PSOLAPPL)) D ALL^PSOLBLS 92 I $G(PSOBLALL) D:$G(WARN)="" ALL^PSOLBLS D:$G(WARN)'="" ALLWARN^PSOLBLN1 93 I '$D(PSSPND),$P(PSOPAR,"^",18) I $G(PSDFNFLG)!($G(PSOLAPPL))!($G(PSOBLALL)) D CHCK2^PSOTRLBL 94 PSOAFPL3 ;vfah 95 D:$G(PSOBLALL) TRAIL^PSOLBL2 96 END ; 97 I $D(RXFLX(RX)) S RXFL(RX)=$G(RXFLX(RX)) K RXFLX 98 ; 99 I '$D(REPRINT)&($G(PSOAFYN)="Y") D ^PSODISP ;vfah auto-release 100 ; 101 D KILL^PSOLBL2 Q 102 ; 103 Q ;vfah 104 ; 105 PSOAFP ;Patient prescription print starts here;vfah 106 S PSOAFPRV=$P($G(^PSRX(RX,0)),"^",4) 107 S PSDU=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),660)),"^",8) ;vfah sets dispense units 108 I $G(VFASDD)="Y" S $P(^PSRX(RX,"RXFIN"),"^",1)="Y" ;Sets complex order flag in File#52 109 K VFASDD 110 ; 111 AFFAX ; 112 I $G(REPRINT)'=1 D 113 .S LZ=0,STOP=0 F S LZ=$O(^PSRX(RX,"PRC",LZ)) Q:'LZ!(STOP=1) S LZZ=$P(^PSRX(RX,"PRC",LZ,0),"FAX: ",2) S LZZ=+LZZ I LZZ'=0 D 114 ..I $D(^DIZ(22900)) D 115 ...S DIC="^DIZ(22900,",DIC(0)="MOZ",X=LZZ 116 ...D ^DIC K DIC 117 ...I +Y'=-1 D 118 ....S PSOAFFXP=X 119 ....S PSOAFFXL=$P(Y,"^",2) 120 ....S ^PSRX(RX,"PRC",LZ,0)=$TR(^PSRX(RX,"PRC",LZ,0),":","+") 121 ....S STOP=1 122 ...I +Y=-1 D 123 ....S ^PSRX(RX,"PRC",LZ,0)=$TR(^PSRX(RX,"PRC",LZ,0),":","-") 124 K STOP,LZ,LZZ 125 I $G(REPRINT)=1 S PSOAFFXP=$G(PSOAFFXR) 126 I $G(PSOAFFXP)>1 G AFPTL 127 ; 128 AFPTS I PSOLAP["STAR" D PRNT^PSOAFPTS 129 I PSOLAP["STAR" G AFKILL 130 I PSOLAP["STRL" D PRNT^PSOAFPT1 131 I PSOLAP["STRL" G AFKILL 132 ; 133 AFPTL D BEGLP^PSOAFPTL 134 ; 135 AFKILL K PSOAFPRV 136 I $G(REPRINT)'=1 D ^%ZISC
Note:
See TracChangeset
for help on using the changeset viewer.
