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

PSORLLLH.m

Go to the documentation of this file.
  1. PSORLLLH ;AITC/BWF - HIPAA/NCPDP LASER LABELS ;7/20/06 10:21am
  1. ;;7.0;OUTPATIENT PHARMACY;**454**;DEC 1997;Build 349
  1. ;
  1. ; BWF - OneVA Pharmacy: modified copy of PSOLLLH
  1. ;
  1. ;Reference to DUR1^BPSNCPD3 supported by DBIA 4560
  1. ;
  1. ;*244 ignore Rx status > 11
  1. ;
  1. SIGLOG N PSOSEQ,J,RXF,RXY,RXN,RX,FIRST,DATE,BLNKLIN,RX2,FDT,BLNKLN2,LAST,CNT
  1. D DEM^VADPT
  1. S FIRST=1,LAST=0
  1. K NOWIN
  1. S $P(BLNKLN2," ",32)=" "
  1. S $P(BLNKLIN,"_",32)="_"
  1. F PSOSEQ=1:1:$L(RPPL,",") S RX=$P(RPPL,",",PSOSEQ) D
  1. .I RX="" Q ;*244
  1. .Q:$G(RXSTA)>11
  1. .S RXY=$G(RX0) I RXY="" Q
  1. .S CNT=$G(CNT)+1
  1. .S RX2=$G(RX2),FDT=$P(RX2,"^",2)
  1. .I FIRST!(CNT#4=1) D HDR,BARC S FIRST=0
  1. .S RXF=$G(RFIEN)
  1. .I +$G(RREF0)'<FDT S FDT=+$G(RREF0)
  1. .S DATE=$E(FDT,1,7),Y=DATE X ^DD("DD") S DATE=Y
  1. .S RXN=$P(RXY,"^")
  1. .S T=RXN_" ("_(RXF)_") "
  1. .N PSODRNM
  1. .S PSODRNM=$$ZZ^PSORLLLI($G(LOCDRUG))
  1. .S T=T_$E(FDT,4,5)_"/"_$E(FDT,6,7)_"/"_$E(FDT,2,3)_" "_$E(PSODRNM,1,(27-$L(RXN))) D PRINT(T)
  1. S LAST=1 D SIGN
  1. I $D(ZTQUEUED) S ZTREQ="@"
  1. Q
  1. ;
  1. SIGN ;
  1. I '$G(CNT) Q
  1. N II
  1. S II=CNT#4
  1. I LAST,II>0 F J=1:1:(4-II) S T=" " D PRINT(T)
  1. S PSOY=PSOY+10
  1. S T="Pt. Sig."_BLNKLIN D PRINT(T)
  1. S PSOY=PSOY+5
  1. D PRINT("")
  1. S PSOY=PSOY+15
  1. S T="Relation_____ Counseling Refused__ Accepted__" D PRINT(T)
  1. S PSOY=PSOY+10
  1. S T=PNM_" "_$G(SSNP) D PRINT(T,1)
  1. Q
  1. ;
  1. HDR ;
  1. N HINFOZIP
  1. S HINFOZIP=$P($P($P(HINFO,"^",2),"~",5),"&")
  1. S PSOHZIP=$S(HINFOZIP["-":HINFOZIP,1:$E(HINFOZIP,1,5)_$S($E(HINFOZIP,6,9)]"":"-"_$E(HINFOZIP,6,9),1:""))
  1. I 'FIRST D SIGN W @IOF
  1. I $G(PSOIO("BLH"))]"" X PSOIO("BLH")
  1. S T="VAMC "_$P(HINFO,"^")_", "_STATE_" "_$G(PSOHZIP) D PRINT(T)
  1. ; change based on incoming HL7 data
  1. ;S T=$P(PS2,"^",2)_" Ph: "_$P(PS,"^",3)_"-"_$P(PS,"^",4)_" "_$G(PSONOW) D PRINT(T)
  1. S T=$P(HINFO,"^",4)_" Ph: "_$P(HINFO,"^",3)_" "_$G(PSONOW) D PRINT(T)
  1. I $G(PSOIO("BLB"))]"" X PSOIO("BLB")
  1. S XFONT=$E(PSOFONT,2,99)
  1. N REPMSG
  1. S REPMSG=BLNKLN2_"(REPRINT)"
  1. S T="By signing below"_$S($G(REPRINT):REPMSG,1:"") D PRINT(T,1)
  1. S T="you acknowledge receipt of the following Rx's" D PRINT(T,1)
  1. S T=" " D PRINT(T)
  1. S PSOY=PSOY-20
  1. Q
  1. ;
  1. PRINT(T,B) ;
  1. S BOLD=$G(B)
  1. I 'BOLD,$G(PSOIO(PSOFONT))]"" X PSOIO(PSOFONT)
  1. I BOLD,$G(PSOIO(PSOFONT_"B"))]"" X PSOIO(PSOFONT_"B")
  1. I $G(PSOIO("ST"))]"" X PSOIO("ST")
  1. W T,!
  1. I $G(PSOIO("ET"))]"" X PSOIO("ET")
  1. I BOLD,$G(PSOIO(PSOFONT))]"" X PSOIO(PSOFONT) ;TURN OFF BOLDING
  1. Q
  1. BARC I '$G(FIRST) G BARCE ; PRINT BARCODE FOR 1 RX ON 1ST SIGLOG LABEL ONLY
  1. I $G(PSOIO("BLBC"))]"" X PSOIO("BLBC") I $G(NOBARC) G BARCE
  1. S X2=$P($G(HINFO),"^",4)_"-"_RX W X2
  1. I $G(PSOIO("EBLBC"))]"" X PSOIO("EBLBC")
  1. BARCE Q
  1. ;
  1. KILL ; CLEAN UP VARIABLES
  1. K DIC,DFN,PNM,PPL,PSZIP,RX,SSNP,VA,VADDR1,VADM,VAEL,VAPA,VASTREET
  1. Q