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