PSOLLLH ;BIR/EJW - HIPAA/NCPDP LASER LABELS ;7/20/06 10:21am
;;7.0;OUTPATIENT PHARMACY;**161,148,244,200,326,321,350**;DEC 1997;Build 4
;
;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
I '$G(REPRINT) D NOWINDOW I NOWIN Q
K NOWIN
S $P(BLNKLN2," ",32)=" "
S $P(BLNKLIN,"_",32)="_"
F PSOSEQ=1:1:$L(PPL,",") S RX=$P(PPL,",",PSOSEQ) D
.I RX="" Q
.Q:$G(^PSRX(RX,"STA"))>11 ;*244
.S RXY=$G(^PSRX(RX,0)) I RXY="" Q
.I $P(RXY,"^",2)'=$G(DFN) Q ;*321
.S CNT=$G(CNT)+1
.S RX2=$G(^PSRX(RX,2)),FDT=$P(RX2,"^",2)
.I FIRST!(CNT#4=1) D HDR,BARC S FIRST=0
.S RXF=+$O(^PSRX(RX,1,"A"),-1)
.I RXF>0 I +^PSRX(RX,1,RXF,0)'<FDT S FDT=+^(0)
.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^PSOSUTL(RX)
.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($$PLANNM())
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 ;
I 'FIRST D SIGN W @IOF
I $G(PSOIO("BLH"))]"" X PSOIO("BLH")
S T="VAMC "_$P(PS,"^",7)_", "_STATE_" "_$G(PSOHZIP) D PRINT(T)
S T=$P(PS2,"^",2)_" Ph: "_$P(PS,"^",3)_"-"_$P(PS,"^",4)_" "_$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
;
QUEUE ; ENTRY POINT TO REPRINT SIGNATURE LOG
I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) Q
N REPRINT,PS,STATE,PS2,PSOHZIP
S PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:"")
S PS2=$P(PS,"^")_"^"_$P(PS,"^",6)
I $P(PSOSYS,"^",4),$D(^PS(59,+$P($G(PSOSYS),"^",4),0)) S PS=^PS(59,$P($G(PSOSYS),"^",4),0)
S VAADDR1=$P(PS,"^"),VASTREET=$P(PS,"^",2),STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UNKNOWN")
S PSZIP=$P(PS,"^",5),PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
S REPRINT=1
LRP W !! S DIC("S")="I $P($G(^(0)),""^"",2),$D(^(""STA"")),$P($G(^(""STA"")),""^"")<10",DIC="^PSRX(",DIC("A")="Reprint Signature Log for Prescription: ",DIC(0)="QEAZ" D ^DIC K P,DIC("A") I Y<0!("^"[X) D KILL Q
W !
S (PPL,RX)=+Y
N RXY
S RXY=$G(^PSRX(RX,0)) I RXY="" Q
S DFN=$P(RXY,"^",2)
GETPT2 D DEM^VADPT S PNM=VADM(1)
I $P(VADM(6),"^",2)]"" D G LRP
.W $C(7),!!,PNM_" Died "_$P(VADM(6),"^",2)_".",!
D 6^VADPT,PID^VADPT6 S SSNP=""
Q1 W ! K POP,ZTSK S %ZIS("B")="",%ZIS="MNQ",%ZIS("A")="Select LABEL DEVICE: " D ^%ZIS S PSLION=ION K %ZIS("A")
I $G(POP) Q
I $G(IOST(0)),'$D(^%ZIS(2,IOST(0),55,"B","LL")) W !,"Must specify a laser labels printer for Signature Log Reprint" G Q1
I '$G(IOST(0)) W !,"Nothing queued to print." H 1 Q
D NOW^%DTC S Y=$P(%,"."),PSOFNOW=% X ^DD("DD") S PSONOW=Y
F G="PPL","REPRINT","PNM","STATE","PS2","PSOHZIP","PSOPAR","PSOSITE","PS","PSONOW","PSOSYS","SSNP","DFN" S:$D(@G) ZTSAVE(G)=""
S ZTRTN="DQ^PSOLLLH",ZTIO=PSLION,ZTDESC="Outpatient Pharmacy Signature Log Reprint",ZTDTH=$H,PDUZ=DUZ
D ^%ZISC,^%ZTLOAD W:$D(ZTSK) !!,"Signature Log Reprint queued",!! H 1 K G
G QUEUE
Q
DQ N PSOBIO S (I,PSOIO)=0 F S I=$O(^%ZIS(2,IOST(0),55,I)) Q:'I S X0=$G(^(I,0)) I X0]"" S PSOIO($P(X0,"^"))=^(1),PSOIO=1
I $G(PSOIO("LLI"))]"" X PSOIO("LLI")
G SIGLOG
;
PLANNM() ; Returns Insurance Name (3rd Party)
S PLANNM=""
N I,DUR,RX
F I=1:1:$L(PPL,",") S RX=+$P(PPL,",",I) D I PLANNM'="" Q
.I 'RX Q
.D DUR1^BPSNCPD3(RX,$$LSTRFL^PSOBPSU1(RX),.DUR) S PLANNM=$G(DUR(1,"INSURANCE NAME"))
Q PLANNM
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
I '$D(PSOINST) D INST
S X2=PSOINST_"-"_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
INST ;
K ^UTILITY("DIQ1",$J) S DA=$P($$SITE^VASITE(),"^")
I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I"))
K ^UTILITY("DIQ1",$J),DA,DR,DIC
Q
;
NOWINDOW ; ON ORIGINAL PRINT - DON'T PRINT IF ALL ARE MAIL
N I,RX,RXF,MW,RXP,RXY
S NOWIN=1
F I=1:1:$L(PPL,",") S RX=$P(PPL,",",I) D I 'NOWIN Q
.I RX="" Q
.I $G(^PSRX(RX,"STA"))>11 Q
.S RXY=$G(^PSRX(RX,0)) I RXY="" Q
.I '$D(^PSRX(RX,1)) S MW=$P(RXY,"^",11) I MW="W" S NOWIN=0 Q
.S RXF=$O(^PSRX(RX,1,99),-1) I RXF>0 S MW=$P($G(^PSRX(RX,1,RXF,0)),"^",2) I MW="W" S NOWIN=0
.S RXP=$O(^PSRX(RX,"P",99),-1) I RXP>0 S MW=$P($G(^PSRX(RX,"P",RXP,0)),"^",2) I MW="W" S NOWIN=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOLLLH 5371 printed Sep 23, 2025@20:07:04 Page 2
PSOLLLH ;BIR/EJW - HIPAA/NCPDP LASER LABELS ;7/20/06 10:21am
+1 ;;7.0;OUTPATIENT PHARMACY;**161,148,244,200,326,321,350**;DEC 1997;Build 4
+2 ;
+3 ;Reference to DUR1^BPSNCPD3 supported by DBIA 4560
+4 ;
+5 ;*244 ignore Rx status > 11
+6 ;
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 IF '$GET(REPRINT)
DO NOWINDOW
IF NOWIN
QUIT
+4 KILL NOWIN
+5 SET $PIECE(BLNKLN2," ",32)=" "
+6 SET $PIECE(BLNKLIN,"_",32)="_"
+7 FOR PSOSEQ=1:1:$LENGTH(PPL,",")
SET RX=$PIECE(PPL,",",PSOSEQ)
Begin DoDot:1
+8 IF RX=""
QUIT
+9 ;*244
if $GET(^PSRX(RX,"STA"))>11
QUIT
+10 SET RXY=$GET(^PSRX(RX,0))
IF RXY=""
QUIT
+11 ;*321
IF $PIECE(RXY,"^",2)'=$GET(DFN)
QUIT
+12 SET CNT=$GET(CNT)+1
+13 SET RX2=$GET(^PSRX(RX,2))
SET FDT=$PIECE(RX2,"^",2)
+14 IF FIRST!(CNT#4=1)
DO HDR
DO BARC
SET FIRST=0
+15 SET RXF=+$ORDER(^PSRX(RX,1,"A"),-1)
+16 IF RXF>0
IF +^PSRX(RX,1,RXF,0)'<FDT
SET FDT=+^(0)
+17 SET DATE=$EXTRACT(FDT,1,7)
SET Y=DATE
XECUTE ^DD("DD")
SET DATE=Y
+18 SET RXN=$PIECE(RXY,"^")
+19 SET T=RXN_" ("_(RXF)_") "
+20 NEW PSODRNM
+21 SET PSODRNM=$$ZZ^PSOSUTL(RX)
+22 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
+23 SET LAST=1
DO SIGN
+24 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+25 QUIT
+26 ;
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($$PLANNM())
+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 IF 'FIRST
DO SIGN
WRITE @IOF
+2 IF $GET(PSOIO("BLH"))]""
XECUTE PSOIO("BLH")
+3 SET T="VAMC "_$PIECE(PS,"^",7)_", "_STATE_" "_$GET(PSOHZIP)
DO PRINT(T)
+4 SET T=$PIECE(PS2,"^",2)_" Ph: "_$PIECE(PS,"^",3)_"-"_$PIECE(PS,"^",4)_" "_$GET(PSONOW)
DO PRINT(T)
+5 IF $GET(PSOIO("BLB"))]""
XECUTE PSOIO("BLB")
+6 SET XFONT=$EXTRACT(PSOFONT,2,99)
+7 NEW REPMSG
+8 SET REPMSG=BLNKLN2_"(REPRINT)"
+9 SET T="By signing below"_$SELECT($GET(REPRINT):REPMSG,1:"")
DO PRINT(T,1)
+10 SET T="you acknowledge receipt of the following Rx's"
DO PRINT(T,1)
+11 SET T=" "
DO PRINT(T)
+12 SET PSOY=PSOY-20
+13 QUIT
+14 ;
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
+9 ;
QUEUE ; ENTRY POINT TO REPRINT SIGNATURE LOG
+1 IF '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
QUIT
+2 NEW REPRINT,PS,STATE,PS2,PSOHZIP
+3 SET PS=$SELECT($DATA(^PS(59,PSOSITE,0)):^(0),1:"")
+4 SET PS2=$PIECE(PS,"^")_"^"_$PIECE(PS,"^",6)
+5 IF $PIECE(PSOSYS,"^",4)
IF $DATA(^PS(59,+$PIECE($GET(PSOSYS),"^",4),0))
SET PS=^PS(59,$PIECE($GET(PSOSYS),"^",4),0)
+6 SET VAADDR1=$PIECE(PS,"^")
SET VASTREET=$PIECE(PS,"^",2)
SET STATE=$SELECT($DATA(^DIC(5,+$PIECE(PS,"^",8),0)):$PIECE(^(0),"^",2),1:"UNKNOWN")
+7 SET PSZIP=$PIECE(PS,"^",5)
SET PSOHZIP=$SELECT(PSZIP["-":PSZIP,1:$EXTRACT(PSZIP,1,5)_$SELECT($EXTRACT(PSZIP,6,9)]"":"-"_$EXTRACT(PSZIP,6,9),1:""))
+8 SET REPRINT=1
LRP WRITE !!
SET DIC("S")="I $P($G(^(0)),""^"",2),$D(^(""STA"")),$P($G(^(""STA"")),""^"")<10"
SET DIC="^PSRX("
SET DIC("A")="Reprint Signature Log for Prescription: "
SET DIC(0)="QEAZ"
DO ^DIC
KILL P,DIC("A")
IF Y<0!("^"[X)
DO KILL
QUIT
+1 WRITE !
+2 SET (PPL,RX)=+Y
+3 NEW RXY
+4 SET RXY=$GET(^PSRX(RX,0))
IF RXY=""
QUIT
+5 SET DFN=$PIECE(RXY,"^",2)
GETPT2 DO DEM^VADPT
SET PNM=VADM(1)
+1 IF $PIECE(VADM(6),"^",2)]""
Begin DoDot:1
+2 WRITE $CHAR(7),!!,PNM_" Died "_$PIECE(VADM(6),"^",2)_".",!
End DoDot:1
GOTO LRP
+3 DO 6^VADPT
DO PID^VADPT6
SET SSNP=""
Q1 WRITE !
KILL POP,ZTSK
SET %ZIS("B")=""
SET %ZIS="MNQ"
SET %ZIS("A")="Select LABEL DEVICE: "
DO ^%ZIS
SET PSLION=ION
KILL %ZIS("A")
+1 IF $GET(POP)
QUIT
+2 IF $GET(IOST(0))
IF '$DATA(^%ZIS(2,IOST(0),55,"B","LL"))
WRITE !,"Must specify a laser labels printer for Signature Log Reprint"
GOTO Q1
+3 IF '$GET(IOST(0))
WRITE !,"Nothing queued to print."
HANG 1
QUIT
+4 DO NOW^%DTC
SET Y=$PIECE(%,".")
SET PSOFNOW=%
XECUTE ^DD("DD")
SET PSONOW=Y
+5 FOR G="PPL","REPRINT","PNM","STATE","PS2","PSOHZIP","PSOPAR","PSOSITE","PS","PSONOW","PSOSYS","SSNP","DFN"
if $DATA(@G)
SET ZTSAVE(G)=""
+6 SET ZTRTN="DQ^PSOLLLH"
SET ZTIO=PSLION
SET ZTDESC="Outpatient Pharmacy Signature Log Reprint"
SET ZTDTH=$HOROLOG
SET PDUZ=DUZ
+7 DO ^%ZISC
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !!,"Signature Log Reprint queued",!!
HANG 1
KILL G
+8 GOTO QUEUE
+9 QUIT
DQ NEW PSOBIO
SET (I,PSOIO)=0
FOR
SET I=$ORDER(^%ZIS(2,IOST(0),55,I))
if 'I
QUIT
SET X0=$GET(^(I,0))
IF X0]""
SET PSOIO($PIECE(X0,"^"))=^(1)
SET PSOIO=1
+1 IF $GET(PSOIO("LLI"))]""
XECUTE PSOIO("LLI")
+2 GOTO SIGLOG
+3 ;
PLANNM() ; Returns Insurance Name (3rd Party)
+1 SET PLANNM=""
+2 NEW I,DUR,RX
+3 FOR I=1:1:$LENGTH(PPL,",")
SET RX=+$PIECE(PPL,",",I)
Begin DoDot:1
+4 IF 'RX
QUIT
+5 DO DUR1^BPSNCPD3(RX,$$LSTRFL^PSOBPSU1(RX),.DUR)
SET PLANNM=$GET(DUR(1,"INSURANCE NAME"))
End DoDot:1
IF PLANNM'=""
QUIT
+6 QUIT PLANNM
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 IF '$DATA(PSOINST)
DO INST
+3 SET X2=PSOINST_"-"_RX
WRITE X2
+4 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
INST ;
+1 KILL ^UTILITY("DIQ1",$JOB)
SET DA=$PIECE($$SITE^VASITE(),"^")
+2 IF $GET(DA)
SET DIC=4
SET DIQ(0)="I"
SET DR="99"
DO EN^DIQ1
SET PSOINST=$GET(^UTILITY("DIQ1",$JOB,4,DA,99,"I"))
+3 KILL ^UTILITY("DIQ1",$JOB),DA,DR,DIC
+4 QUIT
+5 ;
NOWINDOW ; ON ORIGINAL PRINT - DON'T PRINT IF ALL ARE MAIL
+1 NEW I,RX,RXF,MW,RXP,RXY
+2 SET NOWIN=1
+3 FOR I=1:1:$LENGTH(PPL,",")
SET RX=$PIECE(PPL,",",I)
Begin DoDot:1
+4 IF RX=""
QUIT
+5 IF $GET(^PSRX(RX,"STA"))>11
QUIT
+6 SET RXY=$GET(^PSRX(RX,0))
IF RXY=""
QUIT
+7 IF '$DATA(^PSRX(RX,1))
SET MW=$PIECE(RXY,"^",11)
IF MW="W"
SET NOWIN=0
QUIT
+8 SET RXF=$ORDER(^PSRX(RX,1,99),-1)
IF RXF>0
SET MW=$PIECE($GET(^PSRX(RX,1,RXF,0)),"^",2)
IF MW="W"
SET NOWIN=0
+9 SET RXP=$ORDER(^PSRX(RX,"P",99),-1)
IF RXP>0
SET MW=$PIECE($GET(^PSRX(RX,"P",RXP,0)),"^",2)
IF MW="W"
SET NOWIN=0
End DoDot:1
IF 'NOWIN
QUIT
+10 QUIT
