%ZTPP ;SF/RWF - ROUTINE PRETTY PRINT OUTPUT ;10/19/09 14:56
;;7.3;TOOLKIT;**4,11,20,70,122**;Apr 25, 1995;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
;This program can produce routine listings in a paper-saving format
A W !,"Routine Print:"
N FF,LN,ZTSK I $G(DTIME)'>0 N DTIME S DTIME=360
A2 R !,"Want to start each routine on a new page: Yes// ",FF:DTIME,! G EXIT:FF["^" I FF["?" W !,"Enter Yes to start each routine on a new page.",!?5,"No for the old way." G A2
A3 R !,"Want line numbers: No//",LN:DTIME,!
G EXIT:LN["^" I LN["?" W !,"Enter Yes to have line numbers, O for offset numbers, No for no line numbers." G A3
S FF=$TR($E(FF_"Y"),"YyNn","1100"),LN=$TR($E(LN_"N"),"YyNnOo","110022")
K ^UTILITY($J) X ^%ZOSF("RSEL") I $O(^UTILITY($J," "))="" W !!,"NO routines selected." G EXIT
K %ZIS,IOP,ZTIO S %ZIS="MQ" D ^%ZIS G:POP EXIT
I $D(IO("Q")) S ZTRTN="DQ^%ZTPP",ZTDTH="",ZTDESC="ROUTINE LIST" F I="FF","LN","^UTILITY($J," S ZTSAVE(I)=""
I $D(IO("Q")) K IO("Q") D ^%ZTLOAD W !,"REQUEST QUEUED" G EXIT
DQ ;FF start each routine on a new page, LN line numbers
N RN,ST,HDR,LC,PG,BYTECNT,CCNT,X,RSUM,RSUM2,DIF,IOC,IOC2,LI,OF,XCNP
S U="^" D NOW^%DTC S Y=% D DD S HDR(2)=Y
X ^%ZOSF("UCI") S HDR(1)="UCI: "_Y_" Site: "_$G(^DD("SITE"),"VAMC")
S IOC=(IO=IO(0)),IOC2=$E(IOST,1,2)["C-"
U IO W:IOC2 @IOF I 'IOC U IO(0) W !!
S RN=" ",%Y=IOSL-(255\IOM+1) K %D,%T,%TIM
F S RN=$O(^UTILITY($J,RN)) Q:RN="" D I 'ST D %Z5:IOC2&IOC
. S X=RN,XCNP=0,DIF="RTN(" K RTN X ^%ZOSF("LOAD") S LC=XCNP-1
. IF 'IOC U IO(0) W $J(RN,10) W:$X>70 !
. U IO S (CCNT,BYTECNT,PG,OF)=0
. D RSUM,%Z3
. F LI=1:1:LC S X=RTN(LI,0) D:%Y'>$Y %Z3 Q:ST S Y=$P(X," ",1),X=$P(X," ",2,999) D ;
. . I 'LN F J=1:1 W !,Y,?J>1+6," " W:$X>8 "--",!,?8 W $E(X,1,IOM-(J>1+8)) S X=$E(X,IOM-(J>1+7),999),Y="" Q:X=""
. . I LN S OF=$S(LN=1:LI,$L(Y):0,1:OF+1),J1=$S(LN=1:$J(LI,3),$L(Y):"",1:"+"_OF)
. . I LN F J=1:1 W !,J1,?4,Y,?J>1+10," " W:$X>12 "--",!,?12 W $E(X,1,IOM-(J>1+12)) S X=$E(X,IOM-(J>1+11),999),Y="",J1="" Q:X=""
. . Q
. W:$Y<IOSL !
. Q
U IO W !
EXIT K %,%Y,RTN,ST,I,J,J1,%Z33,S,X,Y
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
;
DD S:Y Y=$S($E(Y,4,5):$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$E(Y,4,5))_" ",1:"")_$S($E(Y,6,7):+$E(Y,6,7)_",",1:"")_($E(Y,1,3)+1700)_$P("@"_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),"^",Y[".")
Q
EXEC ;
RSUM ;Checksum and byte counts ;p122
N Y,Y2,R,R1,R2,R3,R4,I S (Y,Y2,BYTECNT,CCNT)=0
F R=1:1:LC S R1=RTN(R,0) D
. I R'=2 S R3=$F(R1," "),R3=$S($E(R1,R3)'=";":$L(R1),$E(R1,R3+1)=";":$L(R1),1:R3-2) F R2=1:1:R3 S Y=$A(R1,R2)*R2+Y,Y2=$A(R1,R2)*(R2+R)+Y2
. S BYTECNT=BYTECNT+$L(R1)+2,R4=$P(R1," ",2,999),I=0
. I " ."[$E(R4) F I=1:1:$L(R4) Q:" ."'[$E(R4,I)
. I I S R4=$E(R4,I,$L(R4))
. I $E(R4)=";",$E(R4,2)'=";" S CCNT=CCNT+$L(R4)
. Q
S RSUM=Y,RSUM2=Y2
Q
%Z3 S PG=PG+1,ST=0 D:(PG>1)&IOC2&IOC %Z5 Q:ST
W:((LC+9+$Y'<IOSL)!FF)&($Y>3)!(PG>1) @IOF
W RN," * * ",$S(PG>1:"(cont.)",1:LC_" LINES, (total "_BYTECNT_", comments "_CCNT_") BYTES"),?60,"Page ",PG
W:PG=1 !?8,"RSUM: old "_RSUM_", new "_RSUM2
W !,?8,HDR(1),?49,HDR(2),!
Q
%Z5 R !,"Press RETURN to continue or '^' to exit: ",ST:600 S ST=$S(ST["^":1,1:0) S:ST LI=9999,LC=0,RN="zzzz",X=""
Q
;
POST ;POST-INIT
N %D,%S,I,SCR,ZTOS,ZTMODE
S ZTMODE=2,ZTOS=$$OS^ZTMGRSET()
S %S="ZTPP",%D="%ZTPP",SCR="I 1" D MOVE^ZTMGRSET
Q
%ZTPP ;SF/RWF - ROUTINE PRETTY PRINT OUTPUT ;10/19/09 14:56
+1 ;;7.3;TOOLKIT;**4,11,20,70,122**;Apr 25, 1995;Build 5
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;This program can produce routine listings in a paper-saving format
A WRITE !,"Routine Print:"
+1 NEW FF,LN,ZTSK
IF $GET(DTIME)'>0
NEW DTIME
SET DTIME=360
A2 READ !,"Want to start each routine on a new page: Yes// ",FF:DTIME,!
IF FF["^"
GOTO EXIT
IF FF["?"
WRITE !,"Enter Yes to start each routine on a new page.",!?5,"No for the old way."
GOTO A2
A3 READ !,"Want line numbers: No//",LN:DTIME,!
+1 IF LN["^"
GOTO EXIT
IF LN["?"
WRITE !,"Enter Yes to have line numbers, O for offset numbers, No for no line numbers."
GOTO A3
+2 SET FF=$TRANSLATE($EXTRACT(FF_"Y"),"YyNn","1100")
SET LN=$TRANSLATE($EXTRACT(LN_"N"),"YyNnOo","110022")
+3 KILL ^UTILITY($JOB)
XECUTE ^%ZOSF("RSEL")
IF $ORDER(^UTILITY($JOB," "))=""
WRITE !!,"NO routines selected."
GOTO EXIT
+4 KILL %ZIS,IOP,ZTIO
SET %ZIS="MQ"
DO ^%ZIS
IF POP
GOTO EXIT
+5 IF $DATA(IO("Q"))
SET ZTRTN="DQ^%ZTPP"
SET ZTDTH=""
SET ZTDESC="ROUTINE LIST"
FOR I="FF","LN","^UTILITY($J,"
SET ZTSAVE(I)=""
+6 IF $DATA(IO("Q"))
KILL IO("Q")
DO ^%ZTLOAD
WRITE !,"REQUEST QUEUED"
GOTO EXIT
DQ ;FF start each routine on a new page, LN line numbers
+1 NEW RN,ST,HDR,LC,PG,BYTECNT,CCNT,X,RSUM,RSUM2,DIF,IOC,IOC2,LI,OF,XCNP
+2 SET U="^"
DO NOW^%DTC
SET Y=%
DO DD
SET HDR(2)=Y
+3 XECUTE ^%ZOSF("UCI")
SET HDR(1)="UCI: "_Y_" Site: "_$GET(^DD("SITE"),"VAMC")
+4 SET IOC=(IO=IO(0))
SET IOC2=$EXTRACT(IOST,1,2)["C-"
+5 USE IO
IF IOC2
WRITE @IOF
IF 'IOC
USE IO(0)
WRITE !!
+6 SET RN=" "
SET %Y=IOSL-(255\IOM+1)
KILL %D,%T,%TIM
+7 FOR
SET RN=$ORDER(^UTILITY($JOB,RN))
IF RN=""
QUIT
Begin DoDot:1
+8 SET X=RN
SET XCNP=0
SET DIF="RTN("
KILL RTN
XECUTE ^%ZOSF("LOAD")
SET LC=XCNP-1
+9 IF 'IOC
USE IO(0)
WRITE $JUSTIFY(RN,10)
IF $X>70
WRITE !
+10 USE IO
SET (CCNT,BYTECNT,PG,OF)=0
+11 DO RSUM
DO %Z3
+12 ;
FOR LI=1:1:LC
SET X=RTN(LI,0)
IF %Y'>$Y
DO %Z3
IF ST
QUIT
SET Y=$PIECE(X," ",1)
SET X=$PIECE(X," ",2,999)
Begin DoDot:2
+13 IF 'LN
FOR J=1:1
WRITE !,Y,?J>1+6," "
IF $X>8
WRITE "--",!,?8
WRITE $EXTRACT(X,1,IOM-(J>1+8))
SET X=$EXTRACT(X,IOM-(J>1+7),999)
SET Y=""
IF X=""
QUIT
+14 IF LN
SET OF=$SELECT(LN=1:LI,$LENGTH(Y):0,1:OF+1)
SET J1=$SELECT(LN=1:$JUSTIFY(LI,3),$LENGTH(Y):"",1:"+"_OF)
+15 IF LN
FOR J=1:1
WRITE !,J1,?4,Y,?J>1+10," "
IF $X>12
WRITE "--",!,?12
WRITE $EXTRACT(X,1,IOM-(J>1+12))
SET X=$EXTRACT(X,IOM-(J>1+11),999)
SET Y=""
SET J1=""
IF X=""
QUIT
+16 QUIT
End DoDot:2
+17 IF $Y<IOSL
WRITE !
+18 QUIT
End DoDot:1
IF 'ST
IF IOC2&IOC
DO %Z5
+19 USE IO
WRITE !
EXIT KILL %,%Y,RTN,ST,I,J,J1,%Z33,S,X,Y
+1 DO ^%ZISC
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 QUIT
+3 ;
DD IF Y
SET Y=$SELECT($EXTRACT(Y,4,5):$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$EXTRACT(Y,4,5))_" ",1:"")_$SELECT($EXTRACT(Y,6,7):+$EXTRACT(Y,6,7)_",",1:"")_($EXTRACT(Y,1,3)+1700)_$PIECE("@"_$EXTRACT(Y_0,9,10)_":"_...
... $EXTRACT(Y_"000",11,12),"^",Y[".")
+1 QUIT
EXEC ;
RSUM ;Checksum and byte counts ;p122
+1 NEW Y,Y2,R,R1,R2,R3,R4,I
SET (Y,Y2,BYTECNT,CCNT)=0
+2 FOR R=1:1:LC
SET R1=RTN(R,0)
Begin DoDot:1
+3 IF R'=2
SET R3=$FIND(R1," ")
SET R3=$SELECT($EXTRACT(R1,R3)'=";":$LENGTH(R1),$EXTRACT(R1,R3+1)=";":$LENGTH(R1),1:R3-2)
FOR R2=1:1:R3
SET Y=$ASCII(R1,R2)*R2+Y
SET Y2=$ASCII(R1,R2)*(R2+R)+Y2
+4 SET BYTECNT=BYTECNT+$LENGTH(R1)+2
SET R4=$PIECE(R1," ",2,999)
SET I=0
+5 IF " ."[$EXTRACT(R4)
FOR I=1:1:$LENGTH(R4)
IF " ."'[$EXTRACT(R4,I)
QUIT
+6 IF I
SET R4=$EXTRACT(R4,I,$LENGTH(R4))
+7 IF $EXTRACT(R4)=";"
IF $EXTRACT(R4,2)'=";"
SET CCNT=CCNT+$LENGTH(R4)
+8 QUIT
End DoDot:1
+9 SET RSUM=Y
SET RSUM2=Y2
+10 QUIT
%Z3 SET PG=PG+1
SET ST=0
IF (PG>1)&IOC2&IOC
DO %Z5
IF ST
QUIT
+1 IF ((LC+9+$Y'<IOSL)!FF)&($Y>3)!(PG>1)
WRITE @IOF
+2 WRITE RN," * * ",$SELECT(PG>1:"(cont.)",1:LC_" LINES, (total "_BYTECNT_", comments "_CCNT_") BYTES"),?60,"Page ",PG
+3 IF PG=1
WRITE !?8,"RSUM: old "_RSUM_", new "_RSUM2
+4 WRITE !,?8,HDR(1),?49,HDR(2),!
+5 QUIT
%Z5 READ !,"Press RETURN to continue or '^' to exit: ",ST:600
SET ST=$SELECT(ST["^":1,1:0)
IF ST
SET LI=9999
SET LC=0
SET RN="zzzz"
SET X=""
+1 QUIT
+2 ;
POST ;POST-INIT
+1 NEW %D,%S,I,SCR,ZTOS,ZTMODE
+2 SET ZTMODE=2
SET ZTOS=$$OS^ZTMGRSET()
+3 SET %S="ZTPP"
SET %D="%ZTPP"
SET SCR="I 1"
DO MOVE^ZTMGRSET
+4 QUIT
