- %ZTP1 ;SF/RWF - Prints 1ST lines in Name, Date, Patch or Size order ;08/18/09 16:25
- ;;7.3;TOOLKIT;**20,70,91,105,122**;Apr 25, 1995;Build 4
- ;Per VHA Directive 2004-038, this routine should not be modified.
- A W !!,"PRINTS FIRST LINES",!!
- K ^UTILITY($J) S DTIME=$G(DTIME,300)
- X ^%ZOSF("RSEL") G KIL:$O(^UTILITY($J,0))=""
- A1 ;
- N ZTP1,ZTP2,X
- A2 R !,"(A)lpha, (D)ate ,(P)atched, OR (S)ize ORDER: A//",ZTP1:DTIME
- S:ZTP1="" ZTP1="A" S ZTP1=$E(ZTP1,1) G KIL:ZTP1="^",A2:"ADPS"'[ZTP1
- S ZTP2=$S(ZTP1="P":"2",1:"None")
- A3 W !,"Include line (2), Include lines 2&(3), (N)one: ",ZTP2,"//" R X:DTIME
- S X=$TR(X,"n","N")
- G KIL:X["^"!('$T) S:X="" X=ZTP2 G A3:"23N"'[$E(X) S ZTP2=+X
- S %ZIS="QM" D ^%ZIS G KIL:POP
- I $D(IO("Q")) D D ^%ZISC Q
- . K IO("Q") S ZTRTN="DQ^%ZTP1",ZTSAVE("ZTP1")="",ZTSAVE("^UTILITY($J,")="",ZTSAVE("ZTP2")="",ZTDESC="FIRST LINES PRINT"
- . D ^%ZTLOAD K ZTSK Q
- ;Set RN for all loops
- DQ ;Taskman entry point
- N %L,%R,%ZN,A,B,C,HED,JR,S,X,Y,ZTP,ZP,RN,CCNT
- S RN=2 G DATE:ZTP1="D",SIZE:ZTP1="S",PATCH:ZTP1="P"
- ;
- ALPHA ;By name
- F JP=1:1 S RN=$O(^UTILITY($J,RN)) Q:RN="" S ^UTILITY($J,1,JP,RN)=0
- S HED=" FIRST LINE LIST "
- G LIST
- ;
- SIZE ;Sort by routine size
- F S RN=$O(^UTILITY($J,RN)) Q:RN="" D
- . D LOAD(RN)
- . S Y=$$SIZE2(.CCNT) I '$D(ZTQUEUED) W RN," ",Y,?$X\19+1*19 W:$X>66 !
- . D KEEP(Y,RN,CCNT)
- S HED=" SIZE RANKING "
- G LIST
- ;
- LOAD(X,R) ;Load routine
- N DIF,XCNP K ^TMP($J)
- S DIF="^TMP($J,",XCNP=0 X ^%ZOSF("LOAD")
- I $D(R) S R(1)=$G(^TMP($J,1,0)),R(2)=$G(^TMP($J,2,0)),R(3)=$G(^TMP($J,3,0))
- Q
- ;
- KEEP(IX1,IX2,IX4) ;
- S ^UTILITY($J,1,IX1,IX2)=2
- S ^UTILITY($J,1,IX1,IX2,1)=^TMP($J,1,0),^UTILITY($J,1,IX1,IX2,2)=^TMP($J,2,0),^UTILITY($J,1,IX1,IX2,3)=$G(^TMP($J,3,0))
- S:$D(IX4) ^UTILITY($J,1,IX1,IX2,4)=IX4
- Q
- ;
- LIST ;All 3 sorts come here to print the list.
- N %X,QUIT,L,L1,L2,S,PL,X
- S PL=IOSL-3-ZTP2,X=$H X ^%ZOSF("ZD")
- X ^%ZOSF("UCI") S HED=HED_" UCI: "_Y,X=$H X ^%ZOSF("ZD")
- S HED=HED_" "_Y,HED(1)="Total/Comments"
- U IO D HED
- S ZP=0,X=0,QUIT=0,S=0
- F S S=$O(^UTILITY($J,1,S)),RN="" Q:(S'>0)!(QUIT) D
- . F S RN=$O(^UTILITY($J,1,S,RN)) Q:'$L(RN)!QUIT D
- . . D:$Y>PL WAIT I X["^" S RN="zz",QUIT=1,S=" " Q
- . . S ZP=ZP+1 D L2
- I 'QUIT W !!?14,ZP," ROUTINES",!
- KIL D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
- K ^UTILITY($J)
- Q
- ;
- L2 ;Write one
- N LI
- I ^UTILITY($J,1,S,RN) M LI=^(RN) ;S LI(1)=^(RN,1),LI(2)=^(2),LI(3)=^(3)
- I '$T S LI=0 D LOAD(RN,.LI) S LI(1)=$P(LI(1)," ",2,999)
- W RN,?10 W:ZTP1="S" $J(S,5),"/",LI(4),?20," - " S %X=$X-1 D WR(LI(1))
- I ZTP2 W ?%X D WR(LI(2)) I ZTP2>2 W ?%X D WR(LI(3))
- Q
- ;
- WR(STR) ;Write line w/ wrap
- N %1,%2
- S %1=$X+1,%2=IOM-1-%1
- F W $E(STR,1,%2) S STR=$E(STR,%2+1,9999) Q:'$L(STR) W !,?%1
- W:$X>0 !
- Q
- ;
- WAIT ;Wait at end of page
- I IOST["C-" R !,"Enter Return to continue ",X:DTIME Q:X["^"
- HED W @IOF,!?12,HED,! W:ZTP1="S" ?10,HED(1),! Q
- ;
- DATE ;Sort by date
- F S RN=$O(^UTILITY($J,RN)) Q:RN="" D
- . N L S L=0 D LOAD(RN,.L)
- . S X=$$DTF(L(1)) D KEEP(9999999-X,RN)
- . W RN," ",X,?$X\19+1*19 W:$X>66 !
- . Q
- S HED=" REVERSE DATE ORDER "
- G LIST
- DTF(L) ;Find the date
- N %,PC,%DT,B,S,Y,X
- S Y=-1
- F PC=2:1:$L(L,";") S B=1,X=$P(L,";",PC) D Q:Y>0
- . S %DT="T"
- . S:X?.E1"["1.2N1"/"1.2N1"/"2.4N.E1"]".E X=$P($P(X,"[",2),"]",1) ;Look for [10/23/2008 14:23]
- . I X?1.2N1P1.2N1P2.4N.E D ^%DT Q:Y>0
- . F %=1:1:$L(X) D Q:Y>0
- . . S S=$E(X,%)?1P S:B&S X=$E(X,1,%-1)_$E(X,%+1,999),%=%-1
- . . S:'S B=0 S:$E(X,%+1,999)?1N.N1":".E X=$E(X,1,%-1)_"@"_$E(X,%+1,999),%=999
- . . I %>$L(X) N % D ^%DT
- . . Q
- . Q
- Q Y
- ;,X=$P(ZTP,"" ;"",3) X A(1) S B=1,X=$P(ZTP,"";"",4) X:Y<0 A(1)
- ;
- PATCH ;Sort by first patch number
- N S2
- F S2=0:0 S RN=$O(^UTILITY($J,RN)) Q:RN="" D
- . N L S L=0 D LOAD(RN,.L)
- . S X=$P(L(2),";",5) I X]"" S S=+$P(X,"**",2) D KEEP(S,RN)
- S HED=" PATCHED ROUTINES "
- G LIST
- ;
- SIZE2(CCNT) ; Return size in bytes of routine in ^TMP($J)
- N NUM,LINE,SIZE,R4,I ; line number, line text, size
- S (SIZE,CCNT)=0
- F NUM=1:1 S LINE=$G(^TMP($J,NUM,0)) Q:LINE="" S SIZE=SIZE+$L(LINE)+2,R4=$P(LINE," ",2,999) D
- . S 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) ;Comment size
- Q SIZE
- ;
- BUILD ;
- N Y,BLDA,%N,S2
- I '$D(^XPD(9.6,0)) W !,"No BUILD file to work from." Q
- S Y=$$BUILD^XTRUTL1 G KIL:Y'>0 S BLDA=+Y
- D RTN^XTRUTL1(BLDA)
- I '$D(^UTILITY($J)) W !,"No routines in this build." G KIL
- G A1
- ;
- POST ;POST-INIT
- N %D,%S,I,SCR,ZTOS,ZTMODE
- S ZTMODE=2,ZTOS=$$OS^ZTMGRSET()
- S %S="ZTP1^ZTPP",%D="%ZTP1^%ZTPP",SCR="I 1" D MOVE^ZTMGRSET
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HZTP1 4630 printed Dec 13, 2024@02:16:33 Page 2
- %ZTP1 ;SF/RWF - Prints 1ST lines in Name, Date, Patch or Size order ;08/18/09 16:25
- +1 ;;7.3;TOOLKIT;**20,70,91,105,122**;Apr 25, 1995;Build 4
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- A WRITE !!,"PRINTS FIRST LINES",!!
- +1 KILL ^UTILITY($JOB)
- SET DTIME=$GET(DTIME,300)
- +2 XECUTE ^%ZOSF("RSEL")
- if $ORDER(^UTILITY($JOB,0))=""
- GOTO KIL
- A1 ;
- +1 NEW ZTP1,ZTP2,X
- A2 READ !,"(A)lpha, (D)ate ,(P)atched, OR (S)ize ORDER: A//",ZTP1:DTIME
- +1 if ZTP1=""
- SET ZTP1="A"
- SET ZTP1=$EXTRACT(ZTP1,1)
- if ZTP1="^"
- GOTO KIL
- if "ADPS"'[ZTP1
- GOTO A2
- +2 SET ZTP2=$SELECT(ZTP1="P":"2",1:"None")
- A3 WRITE !,"Include line (2), Include lines 2&(3), (N)one: ",ZTP2,"//"
- READ X:DTIME
- +1 SET X=$TRANSLATE(X,"n","N")
- +2 if X["^"!('$TEST)
- GOTO KIL
- if X=""
- SET X=ZTP2
- if "23N"'[$EXTRACT(X)
- GOTO A3
- SET ZTP2=+X
- +3 SET %ZIS="QM"
- DO ^%ZIS
- if POP
- GOTO KIL
- +4 IF $DATA(IO("Q"))
- Begin DoDot:1
- +5 KILL IO("Q")
- SET ZTRTN="DQ^%ZTP1"
- SET ZTSAVE("ZTP1")=""
- SET ZTSAVE("^UTILITY($J,")=""
- SET ZTSAVE("ZTP2")=""
- SET ZTDESC="FIRST LINES PRINT"
- +6 DO ^%ZTLOAD
- KILL ZTSK
- QUIT
- End DoDot:1
- DO ^%ZISC
- QUIT
- +7 ;Set RN for all loops
- DQ ;Taskman entry point
- +1 NEW %L,%R,%ZN,A,B,C,HED,JR,S,X,Y,ZTP,ZP,RN,CCNT
- +2 SET RN=2
- if ZTP1="D"
- GOTO DATE
- if ZTP1="S"
- GOTO SIZE
- if ZTP1="P"
- GOTO PATCH
- +3 ;
- ALPHA ;By name
- +1 FOR JP=1:1
- SET RN=$ORDER(^UTILITY($JOB,RN))
- if RN=""
- QUIT
- SET ^UTILITY($JOB,1,JP,RN)=0
- +2 SET HED=" FIRST LINE LIST "
- +3 GOTO LIST
- +4 ;
- SIZE ;Sort by routine size
- +1 FOR
- SET RN=$ORDER(^UTILITY($JOB,RN))
- if RN=""
- QUIT
- Begin DoDot:1
- +2 DO LOAD(RN)
- +3 SET Y=$$SIZE2(.CCNT)
- IF '$DATA(ZTQUEUED)
- WRITE RN," ",Y,?$X\19+1*19
- if $X>66
- WRITE !
- +4 DO KEEP(Y,RN,CCNT)
- End DoDot:1
- +5 SET HED=" SIZE RANKING "
- +6 GOTO LIST
- +7 ;
- LOAD(X,R) ;Load routine
- +1 NEW DIF,XCNP
- KILL ^TMP($JOB)
- +2 SET DIF="^TMP($J,"
- SET XCNP=0
- XECUTE ^%ZOSF("LOAD")
- +3 IF $DATA(R)
- SET R(1)=$GET(^TMP($JOB,1,0))
- SET R(2)=$GET(^TMP($JOB,2,0))
- SET R(3)=$GET(^TMP($JOB,3,0))
- +4 QUIT
- +5 ;
- KEEP(IX1,IX2,IX4) ;
- +1 SET ^UTILITY($JOB,1,IX1,IX2)=2
- +2 SET ^UTILITY($JOB,1,IX1,IX2,1)=^TMP($JOB,1,0)
- SET ^UTILITY($JOB,1,IX1,IX2,2)=^TMP($JOB,2,0)
- SET ^UTILITY($JOB,1,IX1,IX2,3)=$GET(^TMP($JOB,3,0))
- +3 if $DATA(IX4)
- SET ^UTILITY($JOB,1,IX1,IX2,4)=IX4
- +4 QUIT
- +5 ;
- LIST ;All 3 sorts come here to print the list.
- +1 NEW %X,QUIT,L,L1,L2,S,PL,X
- +2 SET PL=IOSL-3-ZTP2
- SET X=$HOROLOG
- XECUTE ^%ZOSF("ZD")
- +3 XECUTE ^%ZOSF("UCI")
- SET HED=HED_" UCI: "_Y
- SET X=$HOROLOG
- XECUTE ^%ZOSF("ZD")
- +4 SET HED=HED_" "_Y
- SET HED(1)="Total/Comments"
- +5 USE IO
- DO HED
- +6 SET ZP=0
- SET X=0
- SET QUIT=0
- SET S=0
- +7 FOR
- SET S=$ORDER(^UTILITY($JOB,1,S))
- SET RN=""
- if (S'>0)!(QUIT)
- QUIT
- Begin DoDot:1
- +8 FOR
- SET RN=$ORDER(^UTILITY($JOB,1,S,RN))
- if '$LENGTH(RN)!QUIT
- QUIT
- Begin DoDot:2
- +9 if $Y>PL
- DO WAIT
- IF X["^"
- SET RN="zz"
- SET QUIT=1
- SET S=" "
- QUIT
- +10 SET ZP=ZP+1
- DO L2
- End DoDot:2
- End DoDot:1
- +11 IF 'QUIT
- WRITE !!?14,ZP," ROUTINES",!
- KIL DO ^%ZISC
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +1 KILL ^UTILITY($JOB)
- +2 QUIT
- +3 ;
- L2 ;Write one
- +1 NEW LI
- +2 ;S LI(1)=^(RN,1),LI(2)=^(2),LI(3)=^(3)
- IF ^UTILITY($JOB,1,S,RN)
- MERGE LI=^(RN)
- +3 IF '$TEST
- SET LI=0
- DO LOAD(RN,.LI)
- SET LI(1)=$PIECE(LI(1)," ",2,999)
- +4 WRITE RN,?10
- if ZTP1="S"
- WRITE $JUSTIFY(S,5),"/",LI(4),?20," - "
- SET %X=$X-1
- DO WR(LI(1))
- +5 IF ZTP2
- WRITE ?%X
- DO WR(LI(2))
- IF ZTP2>2
- WRITE ?%X
- DO WR(LI(3))
- +6 QUIT
- +7 ;
- WR(STR) ;Write line w/ wrap
- +1 NEW %1,%2
- +2 SET %1=$X+1
- SET %2=IOM-1-%1
- +3 FOR
- WRITE $EXTRACT(STR,1,%2)
- SET STR=$EXTRACT(STR,%2+1,9999)
- if '$LENGTH(STR)
- QUIT
- WRITE !,?%1
- +4 if $X>0
- WRITE !
- +5 QUIT
- +6 ;
- WAIT ;Wait at end of page
- +1 IF IOST["C-"
- READ !,"Enter Return to continue ",X:DTIME
- if X["^"
- QUIT
- HED WRITE @IOF,!?12,HED,!
- if ZTP1="S"
- WRITE ?10,HED(1),!
- QUIT
- +1 ;
- DATE ;Sort by date
- +1 FOR
- SET RN=$ORDER(^UTILITY($JOB,RN))
- if RN=""
- QUIT
- Begin DoDot:1
- +2 NEW L
- SET L=0
- DO LOAD(RN,.L)
- +3 SET X=$$DTF(L(1))
- DO KEEP(9999999-X,RN)
- +4 WRITE RN," ",X,?$X\19+1*19
- if $X>66
- WRITE !
- +5 QUIT
- End DoDot:1
- +6 SET HED=" REVERSE DATE ORDER "
- +7 GOTO LIST
- DTF(L) ;Find the date
- +1 NEW %,PC,%DT,B,S,Y,X
- +2 SET Y=-1
- +3 FOR PC=2:1:$LENGTH(L,";")
- SET B=1
- SET X=$PIECE(L,";",PC)
- Begin DoDot:1
- +4 SET %DT="T"
- +5 ;Look for [10/23/2008 14:23]
- if X?.E1"["1.2N1"/"1.2N1"/"2.4N.E1"]".E
- SET X=$PIECE($PIECE(X,"[",2),"]",1)
- +6 IF X?1.2N1P1.2N1P2.4N.E
- DO ^%DT
- if Y>0
- QUIT
- +7 FOR %=1:1:$LENGTH(X)
- Begin DoDot:2
- +8 SET S=$EXTRACT(X,%)?1P
- if B&S
- SET X=$EXTRACT(X,1,%-1)_$EXTRACT(X,%+1,999)
- SET %=%-1
- +9 if 'S
- SET B=0
- if $EXTRACT(X,%+1,999)?1N.N1"
- SET X=$EXTRACT(X,1,%-1)_"@"_$EXTRACT(X,%+1,999)
- SET %=999
- +10 IF %>$LENGTH(X)
- NEW %
- DO ^%DT
- +11 QUIT
- End DoDot:2
- if Y>0
- QUIT
- +12 QUIT
- End DoDot:1
- if Y>0
- QUIT
- +13 QUIT Y
- +14 ;,X=$P(ZTP,"" ;"",3) X A(1) S B=1,X=$P(ZTP,"";"",4) X:Y<0 A(1)
- +15 ;
- PATCH ;Sort by first patch number
- +1 NEW S2
- +2 FOR S2=0:0
- SET RN=$ORDER(^UTILITY($JOB,RN))
- if RN=""
- QUIT
- Begin DoDot:1
- +3 NEW L
- SET L=0
- DO LOAD(RN,.L)
- +4 SET X=$PIECE(L(2),";",5)
- IF X]""
- SET S=+$PIECE(X,"**",2)
- DO KEEP(S,RN)
- End DoDot:1
- +5 SET HED=" PATCHED ROUTINES "
- +6 GOTO LIST
- +7 ;
- SIZE2(CCNT) ; Return size in bytes of routine in ^TMP($J)
- +1 ; line number, line text, size
- NEW NUM,LINE,SIZE,R4,I
- +2 SET (SIZE,CCNT)=0
- +3 FOR NUM=1:1
- SET LINE=$GET(^TMP($JOB,NUM,0))
- if LINE=""
- QUIT
- SET SIZE=SIZE+$LENGTH(LINE)+2
- SET R4=$PIECE(LINE," ",2,999)
- Begin DoDot:1
- +4 SET I=0
- IF " ."[$EXTRACT(R4)
- FOR I=1:1:$LENGTH(R4)
- if " ."'[$EXTRACT(R4,I)
- QUIT
- +5 IF I
- SET R4=$EXTRACT(R4,I,$LENGTH(R4))
- +6 ;Comment size
- IF $EXTRACT(R4)=";"
- IF $EXTRACT(R4,2)'=";"
- SET CCNT=CCNT+$LENGTH(R4)
- End DoDot:1
- +7 QUIT SIZE
- +8 ;
- BUILD ;
- +1 NEW Y,BLDA,%N,S2
- +2 IF '$DATA(^XPD(9.6,0))
- WRITE !,"No BUILD file to work from."
- QUIT
- +3 SET Y=$$BUILD^XTRUTL1
- if Y'>0
- GOTO KIL
- SET BLDA=+Y
- +4 DO RTN^XTRUTL1(BLDA)
- +5 IF '$DATA(^UTILITY($JOB))
- WRITE !,"No routines in this build."
- GOTO KIL
- +6 GOTO A1
- +7 ;
- POST ;POST-INIT
- +1 NEW %D,%S,I,SCR,ZTOS,ZTMODE
- +2 SET ZTMODE=2
- SET ZTOS=$$OS^ZTMGRSET()
- +3 SET %S="ZTP1^ZTPP"
- SET %D="%ZTP1^%ZTPP"
- SET SCR="I 1"
- DO MOVE^ZTMGRSET
- +4 QUIT