PSOLBLN2 ;BHAM ISC/RTR - NEW LABEL TRAILER ;06/06/94
;;7.0;OUTPATIENT PHARMACY;**92,107,110,305,326**;DEC 1997;Build 11
Q:'+$G(RXN)!('$G(PSOTRAIL))!('+$G(DFN))
I $G(PSOBLALL),$P(PPL,",",PI+1)'="" Q
K ^TMP($J,"PSOMAIL"),^TMP($J,"PSONARR"),^TMP($J,"PSOSUSP") S PRCOPAY=$S('$D(PSOCPN):0,1:1)
START ;RETURN MAIL
S PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:"") 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) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
S ^TMP($J,"PSOMAIL",$S(PRCOPAY:1,1:3))="Pharmacy Service (119)",^($S(PRCOPAY:2,1:4))=$G(VAADDR1),^($S(PRCOPAY:3,1:5))=$G(VASTREET),^($S(PRCOPAY:4,1:6))=$P(PS,"^",7)_", "_$G(STATE)_" "_$G(PSOHZIP)
I PRCOPAY F ZZZ=5:1:15 S ^TMP($J,"PSOMAIL",ZZZ)=""
I 'PRCOPAY F ZZZ=7:1:17 S ^TMP($J,"PSOMAIL",ZZZ)=""
S ^TMP($J,"PSOMAIL",$S(PRCOPAY:16,1:18))="Use the label above to mail the computer",^($S(PRCOPAY:17,1:19))="copies back to us. Apply enough postage",^($S(PRCOPAY:18,1:20))="to your envelope to ensure delivery."
NARR ;SET TMP GLOBAL FOR NARRATIVES
K ^UTILITY($J,"W") S (DIWL,PSNACNT)=1,DIWR=45,DIWF="",(PSSIXFL,PSSEVFL)=0 F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,6,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP
F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL S ^TMP($J,"PSONARR",PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1,PSSIXFL=1
I PSSIXFL S ^TMP($J,"PSONARR",PSNACNT)="" S PSNACNT=PSNACNT+1
S DIWL=1,DIWR=45,DIWF="" K ^UTILITY($J,"W") F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,7,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP
F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL S ^TMP($J,"PSONARR",PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1,PSSEVFL=1
I $G(PSOCHAMP),$G(PSOTRAMT) D:PSSEVFL S ^TMP($J,"PSONARR",PSNACNT)="REMIT $"_PSOTRAMT_" TO AGENT CASHIER." G SUSP
.S ^TMP($J,"PSONARR",PSNACNT)="" S PSNACNT=PSNACNT+1
I 'PRCOPAY G SUSP
I PSSEVFL S ^TMP($J,"PSONARR",PSNACNT)="" S PSNACNT=PSNACNT+1
S DIWL=1,DIWR=45,DIWF="" K ^UTILITY($J,"W") F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,4,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP
F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL S ^TMP($J,"PSONARR",PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1
SUSP ;SUSPENSE DOCUMENT
S (PSSUFLG,PSSPCNT)=0 S:'$D(DFN) DFN=+$P($G(^PSRX(RX,0)),"^",2) S PSODFN=DFN,(SPPL,RXX,STA)=""
I $G(PSODTCUT)']"" S X1=DT,X2=-120 D C^%DTC S PSODTCUT=X
D ^PSOBUILD S (STA,RXX)="" F S STA=$O(PSOSD(STA)) Q:STA="" F S RXX=$O(PSOSD(STA,RXX)) Q:RXX="" I $P(PSOSD(STA,RXX),"^",2)=5 S SPPL=$P(PSOSD(STA,RXX),"^")_","_SPPL
D 6^VADPT,PID^VADPT I SPPL="" S PSSUFLG=1 G PRINT
S ^TMP($J,"PSOSUSP",1)="",^(2)=VADM(1),^(3)=$G(VAPA(1)),^(4)=$G(ADDR(2)) I $G(ADDR(3))="",$G(ADDR(4))="" S ^TMP($J,"PSOSUSP",5)="" G ADD
I $G(ADDR(3))'="",$G(ADDR(4))="" S ^TMP($J,"PSOSUSP",5)=$G(ADDR(3)) S ^TMP($J,"PSOSUSP",6)="" G ADD
S ^TMP($J,"PSOSUSP",5)=$G(ADDR(3)),^(6)=$G(ADDR(4)),^(7)=""
ADD F ZZ=0:0 S ZZ=$O(^TMP($J,"PSOSUSP",ZZ)) Q:'ZZ S PSSPCNT=ZZ
S PSSPCNT=PSSPCNT+1 S ^TMP($J,"PSOSUSP",PSSPCNT)=" The following prescriptions will be" S PSSPCNT=PSSPCNT+1 S ^TMP($J,"PSOSUSP",PSSPCNT)="mailed to you on or after the date indicated." S PSSPCNT=PSSPCNT+1
S ^TMP($J,"PSOSUSP",PSSPCNT)="",PSSPCNT=PSSPCNT+1,^(PSSPCNT)="Rx# Date",PSSPCNT=PSSPCNT+1,^(PSSPCNT)="============================================",PSSPCNT=PSSPCNT+1,^(PSSPCNT)="",PSSPCNT=PSSPCNT+1
F XX=1:1 Q:$P(SPPL,",",XX)="" S PSSSRX=$P(SPPL,",",XX) D
.S SPNUM=$O(^PS(52.5,"B",PSSSRX,0)) I SPNUM S SPDATE=$P($G(^PS(52.5,SPNUM,0)),"^",2) S Y=SPDATE D DD^%DT S SPDATE=Y
.S $P(PSOLGTH," ",(20-($L($P(^PSRX(PSSSRX,0),"^")))))="" S ^TMP($J,"PSOSUSP",PSSPCNT)=$P(^PSRX(PSSSRX,0),"^")_PSOLGTH_$G(SPDATE) S PSSPCNT=PSSPCNT+1
.S ^TMP($J,"PSOSUSP",PSSPCNT)=" "_$$ZZ^PSOSUTL(PSSSRX) S PSSPCNT=PSSPCNT+1 K SPNUM,SPDATE,Y
PRINT S PSOTRDFN=$P(VADM(2),"^"),PSOTRDFN=$S(PSOTRDFN]"":PSOTRDFN,1:"Unavailable") S Y=DT X ^DD("DD") S EDT=Y
W ?54,VADM(1)_" "_EDT
W ! I PRCOPAY,$G(PSOBARS) S X="S",X2=PSOTRDFN,X1=$X W ?54,@PSOBAR1,PSOTRDFN,@PSOBAR0,$C(13) S $X=0
I PRCOPAY,'$G(PSOBARS) W !!!
I 'PRCOPAY W !
I 'PSSUFLG D PRSUS,NPP1 G END
S (PSNONARR,PSNOADDR,PSNOBOTH)=0 F TTT=1:1 Q:$G(PSNOBOTH) D
.W $G(^TMP($J,"PSOMAIL",TTT)) S:'$O(^(TTT)) PSNOADDR=1
.W ?54,$G(^TMP($J,"PSONARR",TTT)),! S:'$O(^(TTT)) PSNONARR=1
.I PSNOADDR,PSNONARR S PSNOBOTH=1
D NPP1
END K ^TMP($J,"PSONARR"),^TMP($J,"PSOMAIL"),^TMP($J,"PSOSUSP"),^UTILITY($J,"W")
K DIWF,DIWL,DIWR,EDT,LLL,PRCOPAY,PS,PSNACNT,PSNOADDR,PSNOBOTH,PSNONARR,PSNOSUSP,PSNTHREE,PSOLGTH,PSOSD,PSOTRAIL,PSOTRDFN,PSSEVFL,PSSIXFL,PSSPCNT,PSSSRX,PSSUFLG,RXX,SPDATE,SPNUM,SPPL,STATE,TTT,VAADDR1,VADM,VAEL,VAPA,VASTREET,ZZ,ZZZ W @IOF
I $P(PSOPAR,"^",31) D BLANK^PSOLBLD W @IOF
Q
NPP1 ;
N PSOLAN S PSOLAN=$P($G(^PS(55,DFN,"LAN")),"^",2) S:'PSOLAN PSOLAN=1
I $G(PSOLAN)=1 D
. W !,"The VA Notice of Privacy Practices, IB 10-163, which outlines your privacy",!
. W "rights, is available online at http://www1.domain.ext/Health/ or you may obtain",!
. W "a copy by writing the VHA Privacy Office (19F2), 810 Vermont Avenue NW,",!
. W "Washington, DC 20420.",!
I $G(PSOLAN)=2 D
. W !,"La Notificacion relacionada con las Politicas de Privacidad del Departamento",!
. W "de Asuntos del Veterano, IB 10-163, contiene los detalles acerca de sus",!
. W "derechos de privacidad y esta disponible electronicamente en la siguiente",!
. W "direccion: http://www1.domain.ext/Health/. Usted tambien puede conseguir una",!
. W "copia escribiendo a la Oficina de Privacidad del Departamento de Asuntos de",!
. W "Salud del Veterano, (19F2), 810 Vermont Avenue NW, Washington, DC 20420.",!
Q
;
PRSUS S (PSNONARR,PSNOADDR,PSNOSUSP,PSNTHREE)=0 F TTT=1:1 Q:$G(PSNTHREE) D
.W $G(^TMP($J,"PSOMAIL",TTT)) S:'$O(^(TTT)) PSNOADDR=1
.W ?54,$G(^TMP($J,"PSONARR",TTT)) S:'$O(^(TTT)) PSNONARR=1
.W ?102,$G(^TMP($J,"PSOSUSP",TTT)),! S:'$O(^(TTT)) PSNOSUSP=1
.I PSNOADDR,PSNONARR,PSNOSUSP S PSNTHREE=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOLBLN2 6140 printed Oct 16, 2024@18:31:07 Page 2
PSOLBLN2 ;BHAM ISC/RTR - NEW LABEL TRAILER ;06/06/94
+1 ;;7.0;OUTPATIENT PHARMACY;**92,107,110,305,326**;DEC 1997;Build 11
+2 if '+$GET(RXN)!('$GET(PSOTRAIL))!('+$GET(DFN))
QUIT
+3 IF $GET(PSOBLALL)
IF $PIECE(PPL,",",PI+1)'=""
QUIT
+4 KILL ^TMP($JOB,"PSOMAIL"),^TMP($JOB,"PSONARR"),^TMP($JOB,"PSOSUSP")
SET PRCOPAY=$SELECT('$DATA(PSOCPN):0,1:1)
START ;RETURN MAIL
+1 SET PS=$SELECT($DATA(^PS(59,PSOSITE,0)):^(0),1:"")
IF $PIECE(PSOSYS,"^",4)
IF $DATA(^PS(59,+$PIECE($GET(PSOSYS),"^",4),0))
SET PS=^PS(59,$PIECE($GET(PSOSYS),"^",4),0)
+2 SET VAADDR1=$PIECE(PS,"^")
SET VASTREET=$PIECE(PS,"^",2)
SET STATE=$SELECT($DATA(^DIC(5,+$PIECE(PS,"^",8),0)):$PIECE(^(0),"^",2),1:"UNKNOWN")
+3 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:""))
+4 SET ^TMP($JOB,"PSOMAIL",$SELECT(PRCOPAY:1,1:3))="Pharmacy Service (119)"
SET ^($SELECT(PRCOPAY:2,1:4))=$GET(VAADDR1)
SET ^($SELECT(PRCOPAY:3,1:5))=$GET(VASTREET)
SET ^($SELECT(PRCOPAY:4,1:6))=$PIECE(PS,"^",7)_", "_$GET(STATE)_" "_$GET(PSOHZIP)
+5 IF PRCOPAY
FOR ZZZ=5:1:15
SET ^TMP($JOB,"PSOMAIL",ZZZ)=""
+6 IF 'PRCOPAY
FOR ZZZ=7:1:17
SET ^TMP($JOB,"PSOMAIL",ZZZ)=""
+7 SET ^TMP($JOB,"PSOMAIL",$SELECT(PRCOPAY:16,1:18))="Use the label above to mail the computer"
SET ^($SELECT(PRCOPAY:17,1:19))="copies back to us. Apply enough postage"
SET ^($SELECT(PRCOPAY:18,1:20))="to your envelope to ensure delivery."
NARR ;SET TMP GLOBAL FOR NARRATIVES
+1 KILL ^UTILITY($JOB,"W")
SET (DIWL,PSNACNT)=1
SET DIWR=45
SET DIWF=""
SET (PSSIXFL,PSSEVFL)=0
FOR ZZ=0:0
SET ZZ=$ORDER(^PS(59,PSOSITE,6,ZZ))
if 'ZZ
QUIT
IF $DATA(^(ZZ,0))
SET X=^(0)
DO ^DIWP
+2 FOR LLL=0:0
SET LLL=$ORDER(^UTILITY($JOB,"W",DIWL,LLL))
if 'LLL
QUIT
SET ^TMP($JOB,"PSONARR",PSNACNT)=^UTILITY($JOB,"W",DIWL,LLL,0)
SET PSNACNT=PSNACNT+1
SET PSSIXFL=1
+3 IF PSSIXFL
SET ^TMP($JOB,"PSONARR",PSNACNT)=""
SET PSNACNT=PSNACNT+1
+4 SET DIWL=1
SET DIWR=45
SET DIWF=""
KILL ^UTILITY($JOB,"W")
FOR ZZ=0:0
SET ZZ=$ORDER(^PS(59,PSOSITE,7,ZZ))
if 'ZZ
QUIT
IF $DATA(^(ZZ,0))
SET X=^(0)
DO ^DIWP
+5 FOR LLL=0:0
SET LLL=$ORDER(^UTILITY($JOB,"W",DIWL,LLL))
if 'LLL
QUIT
SET ^TMP($JOB,"PSONARR",PSNACNT)=^UTILITY($JOB,"W",DIWL,LLL,0)
SET PSNACNT=PSNACNT+1
SET PSSEVFL=1
+6 IF $GET(PSOCHAMP)
IF $GET(PSOTRAMT)
if PSSEVFL
Begin DoDot:1
+7 SET ^TMP($JOB,"PSONARR",PSNACNT)=""
SET PSNACNT=PSNACNT+1
End DoDot:1
SET ^TMP($JOB,"PSONARR",PSNACNT)="REMIT $"_PSOTRAMT_" TO AGENT CASHIER."
GOTO SUSP
+8 IF 'PRCOPAY
GOTO SUSP
+9 IF PSSEVFL
SET ^TMP($JOB,"PSONARR",PSNACNT)=""
SET PSNACNT=PSNACNT+1
+10 SET DIWL=1
SET DIWR=45
SET DIWF=""
KILL ^UTILITY($JOB,"W")
FOR ZZ=0:0
SET ZZ=$ORDER(^PS(59,PSOSITE,4,ZZ))
if 'ZZ
QUIT
IF $DATA(^(ZZ,0))
SET X=^(0)
DO ^DIWP
+11 FOR LLL=0:0
SET LLL=$ORDER(^UTILITY($JOB,"W",DIWL,LLL))
if 'LLL
QUIT
SET ^TMP($JOB,"PSONARR",PSNACNT)=^UTILITY($JOB,"W",DIWL,LLL,0)
SET PSNACNT=PSNACNT+1
SUSP ;SUSPENSE DOCUMENT
+1 SET (PSSUFLG,PSSPCNT)=0
if '$DATA(DFN)
SET DFN=+$PIECE($GET(^PSRX(RX,0)),"^",2)
SET PSODFN=DFN
SET (SPPL,RXX,STA)=""
+2 IF $GET(PSODTCUT)']""
SET X1=DT
SET X2=-120
DO C^%DTC
SET PSODTCUT=X
+3 DO ^PSOBUILD
SET (STA,RXX)=""
FOR
SET STA=$ORDER(PSOSD(STA))
if STA=""
QUIT
FOR
SET RXX=$ORDER(PSOSD(STA,RXX))
if RXX=""
QUIT
IF $PIECE(PSOSD(STA,RXX),"^",2)=5
SET SPPL=$PIECE(PSOSD(STA,RXX),"^")_","_SPPL
+4 DO 6^VADPT
DO PID^VADPT
IF SPPL=""
SET PSSUFLG=1
GOTO PRINT
+5 SET ^TMP($JOB,"PSOSUSP",1)=""
SET ^(2)=VADM(1)
SET ^(3)=$GET(VAPA(1))
SET ^(4)=$GET(ADDR(2))
IF $GET(ADDR(3))=""
IF $GET(ADDR(4))=""
SET ^TMP($JOB,"PSOSUSP",5)=""
GOTO ADD
+6 IF $GET(ADDR(3))'=""
IF $GET(ADDR(4))=""
SET ^TMP($JOB,"PSOSUSP",5)=$GET(ADDR(3))
SET ^TMP($JOB,"PSOSUSP",6)=""
GOTO ADD
+7 SET ^TMP($JOB,"PSOSUSP",5)=$GET(ADDR(3))
SET ^(6)=$GET(ADDR(4))
SET ^(7)=""
ADD FOR ZZ=0:0
SET ZZ=$ORDER(^TMP($JOB,"PSOSUSP",ZZ))
if 'ZZ
QUIT
SET PSSPCNT=ZZ
+1 SET PSSPCNT=PSSPCNT+1
SET ^TMP($JOB,"PSOSUSP",PSSPCNT)=" The following prescriptions will be"
SET PSSPCNT=PSSPCNT+1
SET ^TMP($JOB,"PSOSUSP",PSSPCNT)="mailed to you on or after the date indicated."
SET PSSPCNT=PSSPCNT+1
+2 SET ^TMP($JOB,"PSOSUSP",PSSPCNT)=""
SET PSSPCNT=PSSPCNT+1
SET ^(PSSPCNT)="Rx# Date"
SET PSSPCNT=PSSPCNT+1
SET ^(PSSPCNT)="============================================"
SET PSSPCNT=PSSPCNT+1
SET ^(PSSPCNT)=""
SET PSSPCNT=PSSPCNT+1
+3 FOR XX=1:1
if $PIECE(SPPL,",",XX)=""
QUIT
SET PSSSRX=$PIECE(SPPL,",",XX)
Begin DoDot:1
+4 SET SPNUM=$ORDER(^PS(52.5,"B",PSSSRX,0))
IF SPNUM
SET SPDATE=$PIECE($GET(^PS(52.5,SPNUM,0)),"^",2)
SET Y=SPDATE
DO DD^%DT
SET SPDATE=Y
+5 SET $PIECE(PSOLGTH," ",(20-($LENGTH($PIECE(^PSRX(PSSSRX,0),"^")))))=""
SET ^TMP($JOB,"PSOSUSP",PSSPCNT)=$PIECE(^PSRX(PSSSRX,0),"^")_PSOLGTH_$GET(SPDATE)
SET PSSPCNT=PSSPCNT+1
+6 SET ^TMP($JOB,"PSOSUSP",PSSPCNT)=" "_$$ZZ^PSOSUTL(PSSSRX)
SET PSSPCNT=PSSPCNT+1
KILL SPNUM,SPDATE,Y
End DoDot:1
PRINT SET PSOTRDFN=$PIECE(VADM(2),"^")
SET PSOTRDFN=$SELECT(PSOTRDFN]"":PSOTRDFN,1:"Unavailable")
SET Y=DT
XECUTE ^DD("DD")
SET EDT=Y
+1 WRITE ?54,VADM(1)_" "_EDT
+2 WRITE !
IF PRCOPAY
IF $GET(PSOBARS)
SET X="S"
SET X2=PSOTRDFN
SET X1=$X
WRITE ?54,@PSOBAR1,PSOTRDFN,@PSOBAR0,$CHAR(13)
SET $X=0
+3 IF PRCOPAY
IF '$GET(PSOBARS)
WRITE !!!
+4 IF 'PRCOPAY
WRITE !
+5 IF 'PSSUFLG
DO PRSUS
DO NPP1
GOTO END
+6 SET (PSNONARR,PSNOADDR,PSNOBOTH)=0
FOR TTT=1:1
if $GET(PSNOBOTH)
QUIT
Begin DoDot:1
+7 WRITE $GET(^TMP($JOB,"PSOMAIL",TTT))
if '$ORDER(^(TTT))
SET PSNOADDR=1
+8 WRITE ?54,$GET(^TMP($JOB,"PSONARR",TTT)),!
if '$ORDER(^(TTT))
SET PSNONARR=1
+9 IF PSNOADDR
IF PSNONARR
SET PSNOBOTH=1
End DoDot:1
+10 DO NPP1
END KILL ^TMP($JOB,"PSONARR"),^TMP($JOB,"PSOMAIL"),^TMP($JOB,"PSOSUSP"),^UTILITY($JOB,"W")
+1 KILL DIWF,DIWL,DIWR,EDT,LLL,PRCOPAY,PS,PSNACNT,PSNOADDR,PSNOBOTH,PSNONARR,PSNOSUSP,PSNTHREE,PSOLGTH,PSOSD,PSOTRAIL,PSOTRDFN,PSSEVFL,PSSIXFL,PSSPCNT,PSSSRX,PSSUFLG,RXX,SPDATE,SPNUM,SPPL,STATE,TTT,VAADDR1,VADM,VAEL,VAPA,VASTREET,ZZ,ZZZ
WRITE @IOF
+2 IF $PIECE(PSOPAR,"^",31)
DO BLANK^PSOLBLD
WRITE @IOF
+3 QUIT
NPP1 ;
+1 NEW PSOLAN
SET PSOLAN=$PIECE($GET(^PS(55,DFN,"LAN")),"^",2)
if 'PSOLAN
SET PSOLAN=1
+2 IF $GET(PSOLAN)=1
Begin DoDot:1
+3 WRITE !,"The VA Notice of Privacy Practices, IB 10-163, which outlines your privacy",!
+4 WRITE "rights, is available online at http://www1.domain.ext/Health/ or you may obtain",!
+5 WRITE "a copy by writing the VHA Privacy Office (19F2), 810 Vermont Avenue NW,",!
+6 WRITE "Washington, DC 20420.",!
End DoDot:1
+7 IF $GET(PSOLAN)=2
Begin DoDot:1
+8 WRITE !,"La Notificacion relacionada con las Politicas de Privacidad del Departamento",!
+9 WRITE "de Asuntos del Veterano, IB 10-163, contiene los detalles acerca de sus",!
+10 WRITE "derechos de privacidad y esta disponible electronicamente en la siguiente",!
+11 WRITE "direccion: http://www1.domain.ext/Health/. Usted tambien puede conseguir una",!
+12 WRITE "copia escribiendo a la Oficina de Privacidad del Departamento de Asuntos de",!
+13 WRITE "Salud del Veterano, (19F2), 810 Vermont Avenue NW, Washington, DC 20420.",!
End DoDot:1
+14 QUIT
+15 ;
PRSUS SET (PSNONARR,PSNOADDR,PSNOSUSP,PSNTHREE)=0
FOR TTT=1:1
if $GET(PSNTHREE)
QUIT
Begin DoDot:1
+1 WRITE $GET(^TMP($JOB,"PSOMAIL",TTT))
if '$ORDER(^(TTT))
SET PSNOADDR=1
+2 WRITE ?54,$GET(^TMP($JOB,"PSONARR",TTT))
if '$ORDER(^(TTT))
SET PSNONARR=1
+3 WRITE ?102,$GET(^TMP($JOB,"PSOSUSP",TTT)),!
if '$ORDER(^(TTT))
SET PSNOSUSP=1
+4 IF PSNOADDR
IF PSNONARR
IF PSNOSUSP
SET PSNTHREE=1
End DoDot:1
+5 QUIT
