- 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 Mar 13, 2025@21:35:28 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
