ONCOSCT2 ;WASH ISC/SRR,MLH-CROSS TABS 2 ;8/21/93 11:09
;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
;mda/ssb (originator);nci/ytm (first editor/rewriter)
OUTPUT ;sum & write table
;in: ^TMP($J,"CELL"),COLCUTS,COLDD,NPG,ROWCUTS,ROWDD,TOT,XCRT
;out: COLS,NPG,ROWS
;use: ^TMP
;CWID=Column width,RLWID=Row Width,ROWHEAD=length Row variable
U IO
N C,CWID,COL,LC,LNCOLS,R,RLWID,ROW,ROWHEAD,VAL
S FNAM=$P(@(GBL_"0)"),U),FNAM=$S($P(FNAM," ")="ONCOLOGY":$P(FNAM," ",2))
S HLAB=FNAM_$S(TEMPL:" Template ",1:"")_$P(HEADER,U)
S W=$G(ONCOS("CW")),CWID=$S(W="":9,1:W),W=$G(ONCOS("RW")),RLWID=$S(W="":20,1:W),R="",ROWHEAD=$L($P(ROWDD,U,1))
F ROWS=0:1 S R=$O(^TMP($J,"CELL",R)) Q:R="" D SUMLAB
S:COLDD="" ^TMP($J,"CSUM",1)="" S C=""
F COLS=1:1 S C=$O(^TMP($J,"CSUM",C)) Q:C="" S ^TMP($J,"COL",COLS)=C
S OT=$G(ONCOS("AF"))
S COLS=COLS-1,ROWHEAD=$S(ROWHEAD<8:8,ROWHEAD>RLWID:RLWID,1:ROWHEAD)
S LNCOLS=IOM-ROWHEAD-(2*CWID)\CWID
F COL=1:LNCOLS:COLS Q:ONCOEX S LC=COL+LNCOLS-1 S:LC>COLS LC=COLS D WCHEAD,WROWS
Q:ONCOEX I XCRT,'$D(ONCOS("D")) W *7,!! R "Press Return for next table or '^' to Exit: ",X:DTIME W ! S ONCOEX=$S('$T:1,X="^":1,1:0) Q:ONCOEX
W ! Q:OT'=3
;
GETLAB ;get label
;in: CUTS,UNK,YDD,Y
;out: Y
I Y=UNK S Y="?" Q
I $P(YDD,U,2)["P" S:$D(@("^"_$P(YDD,U,3)_Y_",0)"))#2 Y=$P(^(0),U,1) ; note that the indirect reference sets the naked indicator
S:CUTS]""&(Y=+Y) X="GT "_$P(CUTS,":",Y-1)_" - LE "_$P(CUTS,":",Y),Y=$S(Y=1:$P(X,"- ",2),Y=$L(CUTS,":"):$P(X,"- ",1),1:X)
Q:$P(YDD,U,2)'["S"
S Z=$P(YDD,U,3)
F %=1:1 S X=$P(Z,";",%) Q:X="" I Y=$P(X,":",1) S Y=$P(X,":",2) Q
Q
;
SETCOL ;setup col sum & get label
;in: C,RSUM,VAL,^TMP
;out: RSUM,^TMP
I $D(^TMP($J,"CSUM",C))=0 S ^TMP($J,"CSUM",C)=0,Y=C D GETLAB S ^TMP($J,"CLAB",C)=Y
S ^TMP($J,"CSUM",C)=^TMP($J,"CSUM",C)+VAL,RSUM=RSUM+VAL
Q
;
SUMLAB ;sum marginals & get labels
;in: ^TMP($J,"CELL"),COLCUTS,COLDD,R,ROWCUTS,ROWDD,ROWHEAD,UNK
;out: ROWHEAD,^TMP
;use: C,COL,VAL
N CUTS,RSUM,YDD S YDD=ROWDD,Y=R,CUTS=ROWCUTS D GETLAB
S ^TMP($J,"RLAB",R)=Y Q:COLDD=""
S:$L(Y)>ROWHEAD ROWHEAD=$L(Y) S C="",RSUM=0,CUTS=COLCUTS,YDD=COLDD
F COL=0:1 S C=$O(^TMP($J,"CELL",R,C)) Q:C="" S VAL=^(C) D SETCOL
S ^TMP($J,"RSUM",R)=RSUM
Q
;
TOF ;top of form
;in: NPG,XCRT
;out: NPG
Q
;
WCHEAD ;write column header
;in: COL,LC,LNCOLS,COLDD,ROWDD,ROWHEAD,^TMP
;use: C
Q:ONCOEX
N POS,ROW2 S ROW2=""
D:(COL=1&(NPG=0))!($Y+$S(COLDD="":4,1:4)>IOSL) WPHEAD Q:ONCOEX G WCH1:COLDD=""
S X=$P(COLDD,U,1),POS=ROWHEAD+CWID+$S(COL>COLS:0,1:(LC-COL+1)*CWID\2)-($L(X)\2)
W !!,?POS,X,! S POS=CWID\2+ROWHEAD
I COL'>COLS F C=COL:1:LC D WCLAB S POS=POS+CWID
S X="Total" D WCLAB1
WCH1 W !,$E($P(ROWDD,U,1),1,ROWHEAD),":",! Q:COLDD=""
I ROW2]"" F C=1:1 S X=$P(ROW2,U,C) Q:X="" W ?+X,$P(X,";",2)
Q
;
WCLAB ;write col label
;in: C,POS,^TMP
;out: ROW2
S X=$E(^TMP($J,"CLAB",^TMP($J,"COL",C)),1,CWID-1)
WCLAB1 S Y=$L(X),Z=POS+$S(Y=0:0,Y=1:CWID-2,Y'>CWID:CWID-Y,1:(CWID+1-Y)\2-1)
I Z>$X W ?Z,X
E S ROW2=ROW2_Z_";"_X_U
Q
;
WPHEAD ;write page header
Q:ONCOEX
XX I XCRT&NPG W *7,! R "Press 'Return/Enter' to continue, '^' to Exit: ",X:DTIME W ! S ONCOEX=$S('$T:1,X="^":1,1:0) Q:ONCOEX
YY W:$Y @IOF S NPG=NPG+1
W HLAB
W " Cross Tabs",?IOM-30,$P(HEADER,U,2)," Page ",NPG,!
F X=1:1:IOM-1 W "-"
Q
;
WROWS ;write rows
;in: COL,COLDD,CUTS,LC,LNCOLS,ROWDD,ROWS,TOT,^TMP($J)
;use: C,R,ROW
S R="" F ROW=1:1:ROWS S R=$O(^TMP($J,"CELL",R)) Q:R=""!ONCOEX D WR1
Q:ONCOEX D:$Y+PCT+3>IOSL WPHEAD,WCHEAD Q:ONCOEX W !," Total",?CWID\2+ROWHEAD
I COLDD]"" F C=COL:1:LC W $J(^TMP($J,"CSUM",^TMP($J,"COL",C)),CWID)
W $J(TOT,CWID) Q:'PCT W !," %",?CWID\2+ROWHEAD
I COLDD]"" F C=COL:1:LC W $J(^TMP($J,"CSUM",^TMP($J,"COL",C))*100/TOT,CWID,1)
W $J("100.0",CWID),! F X=1:1:IOM-1 W "-"
Q
WR1 ;write row data lines
D:$Y+PCT+3>IOSL WPHEAD,WCHEAD Q:ONCOEX
S X=$E(^TMP($J,"RLAB",R),1,ROWHEAD)
S:X=+X&($L(X)<5) X=$J(X,5) W !,X,?CWID\2+ROWHEAD
F C=COL:1:LC S Y=^TMP($J,"COL",C),X=+$G(^TMP($J,"CELL",R,Y)) W $J(X,CWID)
I COLDD]""&(COL+LNCOLS>COLS+1) W $J(^TMP($J,"RSUM",R),CWID)
Q:'PCT W !,?CWID\2+ROWHEAD
F C=COL:1:LC S Y=^TMP($J,"COL",C),X=+$G(^TMP($J,"CELL",R,Y))*100/TOT W $J(X,CWID,1)
I COLDD]""&(COL+LNCOLS>COLS+1) W $J(^TMP($J,"RSUM",R)*100/TOT,CWID,1)
W ! F X=1:1:IOM-1 W "-"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCOSCT2 4373 printed Apr 09, 2024@21:26:52 Page 2
ONCOSCT2 ;WASH ISC/SRR,MLH-CROSS TABS 2 ;8/21/93 11:09
+1 ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
+2 ;mda/ssb (originator);nci/ytm (first editor/rewriter)
OUTPUT ;sum & write table
+1 ;in: ^TMP($J,"CELL"),COLCUTS,COLDD,NPG,ROWCUTS,ROWDD,TOT,XCRT
+2 ;out: COLS,NPG,ROWS
+3 ;use: ^TMP
+4 ;CWID=Column width,RLWID=Row Width,ROWHEAD=length Row variable
+5 USE IO
+6 NEW C,CWID,COL,LC,LNCOLS,R,RLWID,ROW,ROWHEAD,VAL
+7 SET FNAM=$PIECE(@(GBL_"0)"),U)
SET FNAM=$SELECT($PIECE(FNAM," ")="ONCOLOGY":$PIECE(FNAM," ",2))
+8 SET HLAB=FNAM_$SELECT(TEMPL:" Template ",1:"")_$PIECE(HEADER,U)
+9 SET W=$GET(ONCOS("CW"))
SET CWID=$SELECT(W="":9,1:W)
SET W=$GET(ONCOS("RW"))
SET RLWID=$SELECT(W="":20,1:W)
SET R=""
SET ROWHEAD=$LENGTH($PIECE(ROWDD,U,1))
+10 FOR ROWS=0:1
SET R=$ORDER(^TMP($JOB,"CELL",R))
if R=""
QUIT
DO SUMLAB
+11 if COLDD=""
SET ^TMP($JOB,"CSUM",1)=""
SET C=""
+12 FOR COLS=1:1
SET C=$ORDER(^TMP($JOB,"CSUM",C))
if C=""
QUIT
SET ^TMP($JOB,"COL",COLS)=C
+13 SET OT=$GET(ONCOS("AF"))
+14 SET COLS=COLS-1
SET ROWHEAD=$SELECT(ROWHEAD<8:8,ROWHEAD>RLWID:RLWID,1:ROWHEAD)
+15 SET LNCOLS=IOM-ROWHEAD-(2*CWID)\CWID
+16 FOR COL=1:LNCOLS:COLS
if ONCOEX
QUIT
SET LC=COL+LNCOLS-1
if LC>COLS
SET LC=COLS
DO WCHEAD
DO WROWS
+17 if ONCOEX
QUIT
IF XCRT
IF '$DATA(ONCOS("D"))
WRITE *7,!!
READ "Press Return for next table or '^' to Exit: ",X:DTIME
WRITE !
SET ONCOEX=$SELECT('$TEST:1,X="^":1,1:0)
if ONCOEX
QUIT
+18 WRITE !
if OT'=3
QUIT
+19 ;
GETLAB ;get label
+1 ;in: CUTS,UNK,YDD,Y
+2 ;out: Y
+3 IF Y=UNK
SET Y="?"
QUIT
+4 ; note that the indirect reference sets the naked indicator
IF $PIECE(YDD,U,2)["P"
if $DATA(@("^"_$PIECE(YDD,U,3)_Y_",0)"))#2
SET Y=$PIECE(^(0),U,1)
+5 if CUTS]""&(Y=+Y)
SET X="GT "_$PIECE(CUTS,":",Y-1)_" - LE "_$PIECE(CUTS,":",Y)
SET Y=$SELECT(Y=1:$PIECE(X,"- ",2),Y=$LENGTH(CUTS,":"):$PIECE(X,"- ",1),1:X)
+6 if $PIECE(YDD,U,2)'["S"
QUIT
+7 SET Z=$PIECE(YDD,U,3)
+8 FOR %=1:1
SET X=$PIECE(Z,";",%)
if X=""
QUIT
IF Y=$PIECE(X,":",1)
SET Y=$PIECE(X,":",2)
QUIT
+9 QUIT
+10 ;
SETCOL ;setup col sum & get label
+1 ;in: C,RSUM,VAL,^TMP
+2 ;out: RSUM,^TMP
+3 IF $DATA(^TMP($JOB,"CSUM",C))=0
SET ^TMP($JOB,"CSUM",C)=0
SET Y=C
DO GETLAB
SET ^TMP($JOB,"CLAB",C)=Y
+4 SET ^TMP($JOB,"CSUM",C)=^TMP($JOB,"CSUM",C)+VAL
SET RSUM=RSUM+VAL
+5 QUIT
+6 ;
SUMLAB ;sum marginals & get labels
+1 ;in: ^TMP($J,"CELL"),COLCUTS,COLDD,R,ROWCUTS,ROWDD,ROWHEAD,UNK
+2 ;out: ROWHEAD,^TMP
+3 ;use: C,COL,VAL
+4 NEW CUTS,RSUM,YDD
SET YDD=ROWDD
SET Y=R
SET CUTS=ROWCUTS
DO GETLAB
+5 SET ^TMP($JOB,"RLAB",R)=Y
if COLDD=""
QUIT
+6 if $LENGTH(Y)>ROWHEAD
SET ROWHEAD=$LENGTH(Y)
SET C=""
SET RSUM=0
SET CUTS=COLCUTS
SET YDD=COLDD
+7 FOR COL=0:1
SET C=$ORDER(^TMP($JOB,"CELL",R,C))
if C=""
QUIT
SET VAL=^(C)
DO SETCOL
+8 SET ^TMP($JOB,"RSUM",R)=RSUM
+9 QUIT
+10 ;
TOF ;top of form
+1 ;in: NPG,XCRT
+2 ;out: NPG
+3 QUIT
+4 ;
WCHEAD ;write column header
+1 ;in: COL,LC,LNCOLS,COLDD,ROWDD,ROWHEAD,^TMP
+2 ;use: C
+3 if ONCOEX
QUIT
+4 NEW POS,ROW2
SET ROW2=""
+5 if (COL=1&(NPG=0))!($Y+$SELECT(COLDD=""
DO WPHEAD
if ONCOEX
QUIT
if COLDD=""
GOTO WCH1
+6 SET X=$PIECE(COLDD,U,1)
SET POS=ROWHEAD+CWID+$SELECT(COL>COLS:0,1:(LC-COL+1)*CWID\2)-($LENGTH(X)\2)
+7 WRITE !!,?POS,X,!
SET POS=CWID\2+ROWHEAD
+8 IF COL'>COLS
FOR C=COL:1:LC
DO WCLAB
SET POS=POS+CWID
+9 SET X="Total"
DO WCLAB1
WCH1 WRITE !,$EXTRACT($PIECE(ROWDD,U,1),1,ROWHEAD),":",!
if COLDD=""
QUIT
+1 IF ROW2]""
FOR C=1:1
SET X=$PIECE(ROW2,U,C)
if X=""
QUIT
WRITE ?+X,$PIECE(X,";",2)
+2 QUIT
+3 ;
WCLAB ;write col label
+1 ;in: C,POS,^TMP
+2 ;out: ROW2
+3 SET X=$EXTRACT(^TMP($JOB,"CLAB",^TMP($JOB,"COL",C)),1,CWID-1)
WCLAB1 SET Y=$LENGTH(X)
SET Z=POS+$SELECT(Y=0:0,Y=1:CWID-2,Y'>CWID:CWID-Y,1:(CWID+1-Y)\2-1)
+1 IF Z>$X
WRITE ?Z,X
+2 IF '$TEST
SET ROW2=ROW2_Z_";"_X_U
+3 QUIT
+4 ;
WPHEAD ;write page header
+1 if ONCOEX
QUIT
XX IF XCRT&NPG
WRITE *7,!
READ "Press 'Return/Enter' to continue, '^' to Exit: ",X:DTIME
WRITE !
SET ONCOEX=$SELECT('$TEST:1,X="^":1,1:0)
if ONCOEX
QUIT
YY if $Y
WRITE @IOF
SET NPG=NPG+1
+1 WRITE HLAB
+2 WRITE " Cross Tabs",?IOM-30,$PIECE(HEADER,U,2)," Page ",NPG,!
+3 FOR X=1:1:IOM-1
WRITE "-"
+4 QUIT
+5 ;
WROWS ;write rows
+1 ;in: COL,COLDD,CUTS,LC,LNCOLS,ROWDD,ROWS,TOT,^TMP($J)
+2 ;use: C,R,ROW
+3 SET R=""
FOR ROW=1:1:ROWS
SET R=$ORDER(^TMP($JOB,"CELL",R))
if R=""!ONCOEX
QUIT
DO WR1
+4 if ONCOEX
QUIT
if $Y+PCT+3>IOSL
DO WPHEAD
DO WCHEAD
if ONCOEX
QUIT
WRITE !," Total",?CWID\2+ROWHEAD
+5 IF COLDD]""
FOR C=COL:1:LC
WRITE $JUSTIFY(^TMP($JOB,"CSUM",^TMP($JOB,"COL",C)),CWID)
+6 WRITE $JUSTIFY(TOT,CWID)
if 'PCT
QUIT
WRITE !," %",?CWID\2+ROWHEAD
+7 IF COLDD]""
FOR C=COL:1:LC
WRITE $JUSTIFY(^TMP($JOB,"CSUM",^TMP($JOB,"COL",C))*100/TOT,CWID,1)
+8 WRITE $JUSTIFY("100.0",CWID),!
FOR X=1:1:IOM-1
WRITE "-"
+9 QUIT
WR1 ;write row data lines
+1 if $Y+PCT+3>IOSL
DO WPHEAD
DO WCHEAD
if ONCOEX
QUIT
+2 SET X=$EXTRACT(^TMP($JOB,"RLAB",R),1,ROWHEAD)
+3 if X=+X&($LENGTH(X)<5)
SET X=$JUSTIFY(X,5)
WRITE !,X,?CWID\2+ROWHEAD
+4 FOR C=COL:1:LC
SET Y=^TMP($JOB,"COL",C)
SET X=+$GET(^TMP($JOB,"CELL",R,Y))
WRITE $JUSTIFY(X,CWID)
+5 IF COLDD]""&(COL+LNCOLS>COLS+1)
WRITE $JUSTIFY(^TMP($JOB,"RSUM",R),CWID)
+6 if 'PCT
QUIT
WRITE !,?CWID\2+ROWHEAD
+7 FOR C=COL:1:LC
SET Y=^TMP($JOB,"COL",C)
SET X=+$GET(^TMP($JOB,"CELL",R,Y))*100/TOT
WRITE $JUSTIFY(X,CWID,1)
+8 IF COLDD]""&(COL+LNCOLS>COLS+1)
WRITE $JUSTIFY(^TMP($JOB,"RSUM",R)*100/TOT,CWID,1)
+9 WRITE !
FOR X=1:1:IOM-1
WRITE "-"
+10 QUIT
