PSOLLL6 ;BHAM/BHW - LABEL TRAILER ;12/02/2002
;;7.0;OUTPATIENT PHARMACY;**120,141,135,162,161,305**;DEC 1997;Build 8
;
I $G(PSOBLALL),$P(PPL,",",PI+1)'="" Q
S PRCOPAY=$S('$D(PSOCPN):0,1:1)
NARR ;NARRATIVES
N LC S (PSSIXFL,PSSEVFL,LENGTH,OUT)=0,PTEXT="" F I=4,6,7 S LC(I)=0
I $G(PSOIO("RNI"))]"" X PSOIO("RNI")
S XFONT=$E(PSOFONT,2,99)
I $D(^PS(59,PSOSITE,6))!($D(^PS(59,PSOSITE,7))) S T=PNM_" "_SSNP_" "_$G(PSONOW) D PRINT(T) S PSOY=PSOY+PSOYI
F JJ=6,7 S TEXT="" D P(JJ) S PSOY=PSOY+PSOYI Q:OUT
I $G(PSOIO("CNI"))]"" X PSOIO("CNI")
I $G(PSOCHAMP),$G(PSOTRAMT) S T="REMIT $"_PSOTRAMT_" TO AGENT CASHIER." D PRINT(T) G END
I 'PRCOPAY G END
S OUT=0,TEXT=""
I $D(^PS(59,PSOSITE,4)) S T=PNM_" "_SSNP_" "_$G(PSONOW) D PRINT(T) S PSOY=PSOY+PSOYI D P(4)
END ;
D NPP
K DIWF,DIWL,DIWR,EDT,LLL,PRCOPAY,PSNACNT,PSNOADDR,PSNOBOTH,PSNONARR,PSNOSUSP,PSNTHREE,PSOLGTH,PSOSD,PSOTRAIL,PSOTRDFN,PSSEVFL,PSSIXFL,PSSPCNT,PSSSRX,PSSUFLG,RXX,SPDATE,SPNUM,SPPL,TTT,VAADDR1,VADM,VAEL,VAPA,VASTREET,ZZ,ZZZ W @IOF
Q
P(JJ) ;NARRATIVE PRINT CONTROL
N TEXTLEN,PSOCNT
S TEXTLEN=0,PSOCNT=0
S ZZ=0 F S ZZ=$O(^PS(59,PSOSITE,JJ,ZZ)) Q:'ZZ S PSOCNT=PSOCNT+1 Q:PSOCNT>7 I $D(^(ZZ,0)) S TEXT=^(0),TEXTLEN=TEXTLEN+$L(TEXT) S:TEXTLEN>560 TEXTLEN=TEXTLEN-$L(TEXT),TEXT=$E(TEXT,1,560-TEXTLEN) Q:TEXT="" D Q:OUT
. N IC
. D STRT^PSOLLU1("SEC2",TEXT,.L)
. I L(XFONT)>4.1 D Q
.. S IC=0 F J=1:1:$L(TEXT," ") D STRT^PSOLLU1("SEC2",$P(TEXT," ",J)_" ",.L) I L(XFONT)>4.1 S IC=1
.. I IC D Q:OUT
... F J=$L(TEXT):-1:1 S PTEXT=$E(TEXT,1,J) D STRT^PSOLLU1("SEC2",PTEXT,.L) D Q:OUT
.... I L(XFONT)<4.1 D PRINT(PTEXT) S LC(JJ)=LC(JJ)+1,TEXT=$E(TEXT,J+1,512),J=$L(TEXT)+1,PTEXT="" I PSOY>PSOYM S OUT=1
.... Q
... Q
.. I IC D:PTEXT]"" PRINT(PTEXT) S:PTEXT]"" LC(JJ)=LC(JJ)+1 S:PSOY>PSOYM OUT=1 Q
.. F J=$L(TEXT," "):-1 S PTEXT=$P(TEXT," ",1,J) Q:OUT Q:'$L(PTEXT) D STRT^PSOLLU1("SEC2",PTEXT,.L) I L(XFONT)<4.1 D
... D PRINT(PTEXT) S LC(JJ)=LC(JJ)+1,TEXT=$P(TEXT," ",J+1,99) I PSOY>PSOYM S OUT=1
... ;Reset $L of TEXT +1 so J loop continues properly
... S J=$L(TEXT," ")+1
... Q
.. Q
. D PRINT(TEXT) S LC(JJ)=LC(JJ)+1,TEXT=""
. I PSOY>PSOYM S OUT=1
. Q
I 'OUT I TEXT]"" D PRINT(TEXT) S LC(JJ)=LC(JJ)+1
Q
PRINT(T) ;
I $G(PSOIO(PSOFONT))]"" X PSOIO(PSOFONT)
I $G(PSOIO("ST"))]"" X PSOIO("ST")
W T,!
I $G(PSOIO("ET"))]"" X PSOIO("ET")
Q
;
NPP ; Notice of Privacy Practices
N SKP S SKP=LC(6)+LC(7)
S PSOX=0 F I=SKP:-1:LC(4) D PRINT("")
I SKP,'LC(4) D PRINT(""),PRINT("")
D:SKP<16 PRINT("")
S SKP=PSOYI*$S(PSOLAN=2:4,1:2)+PSOY I SKP>PSOYM Q
I $G(PSOLAN)=2 D Q
. S T="La Notificacion relacionada con las Politicas de Privacidad del Departamento de Asuntos del Veterano, IB 10-163, contiene los" D PRINT(T)
. S T="detalles acerca de sus derechos de privacidad y esta disponsible electronicamente en la siguiente direccion:" D PRINT(T)
. S T="http://www1.domain.ext/Health/. Usted tambien puede conseguir una copia escribiendo a la Oficina de Privacidad del" D PRINT(T)
. S T="Departamento de Asuntos de Salud del Veterano, (19F2), 810 Vermont Avenue NW, Washington, DC 20420." D PRINT(T)
S T="The VA Notice of Privacy Practices, IB 10-163, which outlines your privacy rights, is available online at http://www1.domain.ext/Health/" D PRINT(T)
S T="or you may obtain a copy by writing the VHA Privacy Office (19F2), 810 Vermont Avenue NW, Washington, DC 20420." D PRINT(T)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOLLL6 3448 printed Sep 23, 2025@20:07 Page 2
PSOLLL6 ;BHAM/BHW - LABEL TRAILER ;12/02/2002
+1 ;;7.0;OUTPATIENT PHARMACY;**120,141,135,162,161,305**;DEC 1997;Build 8
+2 ;
+3 IF $GET(PSOBLALL)
IF $PIECE(PPL,",",PI+1)'=""
QUIT
+4 SET PRCOPAY=$SELECT('$DATA(PSOCPN):0,1:1)
NARR ;NARRATIVES
+1 NEW LC
SET (PSSIXFL,PSSEVFL,LENGTH,OUT)=0
SET PTEXT=""
FOR I=4,6,7
SET LC(I)=0
+2 IF $GET(PSOIO("RNI"))]""
XECUTE PSOIO("RNI")
+3 SET XFONT=$EXTRACT(PSOFONT,2,99)
+4 IF $DATA(^PS(59,PSOSITE,6))!($DATA(^PS(59,PSOSITE,7)))
SET T=PNM_" "_SSNP_" "_$GET(PSONOW)
DO PRINT(T)
SET PSOY=PSOY+PSOYI
+5 FOR JJ=6,7
SET TEXT=""
DO P(JJ)
SET PSOY=PSOY+PSOYI
if OUT
QUIT
+6 IF $GET(PSOIO("CNI"))]""
XECUTE PSOIO("CNI")
+7 IF $GET(PSOCHAMP)
IF $GET(PSOTRAMT)
SET T="REMIT $"_PSOTRAMT_" TO AGENT CASHIER."
DO PRINT(T)
GOTO END
+8 IF 'PRCOPAY
GOTO END
+9 SET OUT=0
SET TEXT=""
+10 IF $DATA(^PS(59,PSOSITE,4))
SET T=PNM_" "_SSNP_" "_$GET(PSONOW)
DO PRINT(T)
SET PSOY=PSOY+PSOYI
DO P(4)
END ;
+1 DO NPP
+2 KILL DIWF,DIWL,DIWR,EDT,LLL,PRCOPAY,PSNACNT,PSNOADDR,PSNOBOTH,PSNONARR,PSNOSUSP,PSNTHREE,PSOLGTH,PSOSD,PSOTRAIL,PSOTRDFN,PSSEVFL,PSSIXFL,PSSPCNT,PSSSRX,PSSUFLG,RXX,SPDATE,SPNUM,SPPL,TTT,VAADDR1,VADM,VAEL,VAPA,VASTREET,ZZ,ZZZ
WRITE @IOF
+3 QUIT
P(JJ) ;NARRATIVE PRINT CONTROL
+1 NEW TEXTLEN,PSOCNT
+2 SET TEXTLEN=0
SET PSOCNT=0
+3 SET ZZ=0
FOR
SET ZZ=$ORDER(^PS(59,PSOSITE,JJ,ZZ))
if 'ZZ
QUIT
SET PSOCNT=PSOCNT+1
if PSOCNT>7
QUIT
IF $DATA(^(ZZ,0))
SET TEXT=^(0)
SET TEXTLEN=TEXTLEN+$LENGTH(TEXT)
if TEXTLEN>560
SET TEXTLEN=TEXTLEN-$LENGTH(TEXT)
SET TEXT=$EXTRACT(TEXT,1,560-TEXTLEN)
if TEXT=""
QUIT
Begin DoDot:1
+4 NEW IC
+5 DO STRT^PSOLLU1("SEC2",TEXT,.L)
+6 IF L(XFONT)>4.1
Begin DoDot:2
+7 SET IC=0
FOR J=1:1:$LENGTH(TEXT," ")
DO STRT^PSOLLU1("SEC2",$PIECE(TEXT," ",J)_" ",.L)
IF L(XFONT)>4.1
SET IC=1
+8 IF IC
Begin DoDot:3
+9 FOR J=$LENGTH(TEXT):-1:1
SET PTEXT=$EXTRACT(TEXT,1,J)
DO STRT^PSOLLU1("SEC2",PTEXT,.L)
Begin DoDot:4
+10 IF L(XFONT)<4.1
DO PRINT(PTEXT)
SET LC(JJ)=LC(JJ)+1
SET TEXT=$EXTRACT(TEXT,J+1,512)
SET J=$LENGTH(TEXT)+1
SET PTEXT=""
IF PSOY>PSOYM
SET OUT=1
+11 QUIT
End DoDot:4
if OUT
QUIT
+12 QUIT
End DoDot:3
if OUT
QUIT
+13 IF IC
if PTEXT]""
DO PRINT(PTEXT)
if PTEXT]""
SET LC(JJ)=LC(JJ)+1
if PSOY>PSOYM
SET OUT=1
QUIT
+14 FOR J=$LENGTH(TEXT," "):-1
SET PTEXT=$PIECE(TEXT," ",1,J)
if OUT
QUIT
if '$LENGTH(PTEXT)
QUIT
DO STRT^PSOLLU1("SEC2",PTEXT,.L)
IF L(XFONT)<4.1
Begin DoDot:3
+15 DO PRINT(PTEXT)
SET LC(JJ)=LC(JJ)+1
SET TEXT=$PIECE(TEXT," ",J+1,99)
IF PSOY>PSOYM
SET OUT=1
+16 ;Reset $L of TEXT +1 so J loop continues properly
+17 SET J=$LENGTH(TEXT," ")+1
+18 QUIT
End DoDot:3
+19 QUIT
End DoDot:2
QUIT
+20 DO PRINT(TEXT)
SET LC(JJ)=LC(JJ)+1
SET TEXT=""
+21 IF PSOY>PSOYM
SET OUT=1
+22 QUIT
End DoDot:1
if OUT
QUIT
+23 IF 'OUT
IF TEXT]""
DO PRINT(TEXT)
SET LC(JJ)=LC(JJ)+1
+24 QUIT
PRINT(T) ;
+1 IF $GET(PSOIO(PSOFONT))]""
XECUTE PSOIO(PSOFONT)
+2 IF $GET(PSOIO("ST"))]""
XECUTE PSOIO("ST")
+3 WRITE T,!
+4 IF $GET(PSOIO("ET"))]""
XECUTE PSOIO("ET")
+5 QUIT
+6 ;
NPP ; Notice of Privacy Practices
+1 NEW SKP
SET SKP=LC(6)+LC(7)
+2 SET PSOX=0
FOR I=SKP:-1:LC(4)
DO PRINT("")
+3 IF SKP
IF 'LC(4)
DO PRINT("")
DO PRINT("")
+4 if SKP<16
DO PRINT("")
+5 SET SKP=PSOYI*$SELECT(PSOLAN=2:4,1:2)+PSOY
IF SKP>PSOYM
QUIT
+6 IF $GET(PSOLAN)=2
Begin DoDot:1
+7 SET T="La Notificacion relacionada con las Politicas de Privacidad del Departamento de Asuntos del Veterano, IB 10-163, contiene los"
DO PRINT(T)
+8 SET T="detalles acerca de sus derechos de privacidad y esta disponsible electronicamente en la siguiente direccion:"
DO PRINT(T)
+9 SET T="http://www1.domain.ext/Health/. Usted tambien puede conseguir una copia escribiendo a la Oficina de Privacidad del"
DO PRINT(T)
+10 SET T="Departamento de Asuntos de Salud del Veterano, (19F2), 810 Vermont Avenue NW, Washington, DC 20420."
DO PRINT(T)
End DoDot:1
QUIT
+11 SET T="The VA Notice of Privacy Practices, IB 10-163, which outlines your privacy rights, is available online at http://www1.domain.ext/Health/"
DO PRINT(T)
+12 SET T="or you may obtain a copy by writing the VHA Privacy Office (19F2), 810 Vermont Avenue NW, Washington, DC 20420."
DO PRINT(T)
+13 QUIT
