- 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 Feb 19, 2025@00:00:24 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