ONCOSCT ;Hines OIFO/GWB,RTK - CROSS TABULATE ;9/3/93
;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
IN ;DIRECT CALL set ONCOS("D")=1
;in: ^DIBT,^DIPT
;ONCOS - used to force responses to setup prompts
;("F") = file number
;("T") = search template
;("R") = row field name^cutpoints, e.g., "AGE^10:20:30:40"
;("C") = column field name^cutpoints
;("P") = 1 to print total per cents, 0 to skip prompt
;("Y") = yes prompts
;("I") = IOP variable for %ZIS
;("H") = HEADER (if defined, not asked for in ONCOSCINP)
;("D") = Direct Program call, not entered at Print
;do: ^ONCOSINP,^ONCOSCT*,WAIT^DICD,^%DT,^%ZIS
S ONCOS("D")=1 W !,"ONCOLOGY Version 2 - Cross-tabs",! ;S:'$D(DTIME) DTIME=1000
PRINT ;entry point for queued report (%ZTLOAD)
S:$D(ONCOION) ION=ONCOION S:$D(ONCOIOM) IOM=ONCOIOM
W !! S (ROWDEF,TEMPL)=-1,UNK="~",XCRT=$S($G(IOST)?1"C".E:1,1:0),%=0 D GETFILE^ONCOSINP:'$D(ONCOS("FI"))
S FNUM=+ONCOS("FI") I '$D(ONCOS("T")) D GETTEMPL^ONCOSINP G EX:'Y S ONCOS("T")=Y G EN
I ONCOS("T")'["^" D GETTEMPL^ONCOSINP G EX:Y<0 S ONCOS("T")=Y
EN S ONCOEX=0,TEMPL=ONCOS("T"),TEMPL=$S(TEMPL="ALL":TEMPL,1:+TEMPL),HEAD=$G(ONCOS("H")),HEADER=$S(HEAD="":$P(ONCOS("T"),U,2),1:HEAD)
S FNUM=+ONCOS("FI"),GLO="^"_$P(ONCOS("FI"),U,3) D SETUP^ONCOSCT1 G EX:ROWDD=""!(ONCOEX)
G CON:$D(ONCOS("TK")) I '$D(ONCOS("AF")) S ONCOS("AF")=1
K IO("Q") S %ZIS="Q",%ZIS("A")=" Select device to Print Cross Tabs: " D ^%ZIS I POP S ONCOUT="" G EX
I '$D(IO("Q")) D TSK^ONCOSCT G EX
S ZTRTN="TSK^ONCOSCT",ZTDESC=HEADER
S ZTSAVE("ONCOS*")=""
S ZTSAVE("TEMPL")="",ZTSAVE("XCRT")="",ZTSAVE("UNK")=""
S ZTSAVE("COLCUTS")="",ZTSAVE("ROWCUTS")=""
S ZTSAVE("COLDD")="",ZTSAVE("ROWDD")=""
S ZTSAVE("PCT")="",ZTSAVE("HEADER")=""
D ^%ZTLOAD G EX
;
TSK ;Task for internal direct calling of ONCOSCT, not from another task.
K ^TMP($J) S ONCOEX=0 S:'$D(ONCOS("AF")) ONCOS("AF")=1
S XCRT=$S($G(IOST)?1"C".E:1,1:0)
D WAIT^DICD:XCRT
CON W ! S %DT="T",X="NOW" D ^%DT X ^DD("DD") S GBL="^"_$P(ONCOS("FI"),U,3)
S HEADER=HEADER_U_$P(Y,"@",1)_" "_$P(Y,"@",2),(D0,NPG,TOT)=0
TEM I TEMPL'="ALL" S D0=0 F N=1:1 S D0=$O(^DIBT(TEMPL,1,D0)) G OUT:D0'>0 D CTCASE
F N=1:1 S D0=$O(@(GBL_"D0)")) Q:D0'>0 D CTCASE
OUT ;OUTPUT
S ONCOEX=0 D OUTPUT^ONCOSCT2 G EX:ONCOEX G EX:'$D(ONCOS("TK"))
KIL ;Entry point to kill all variables at EXCEPT 'ONCOS' ARRAY
K ^TMP($J)
K COLCUTS,COLDD,COLPIECE,COLS,COLSUB,D0,FNUM
K GLB,GLO,HEAD,HEADER,N,NPG,PCT,POP,B,C,F,XX,Y,Z
K ROWCUTS,ROWS,ROWDD,ROWPIECE,ROWSUB,TEMPL,TOT,UNK,X,XCRT
K %,%DT,%K,%T,%ZISOS,HEAD,OF
Q
;
EX ;Complete Exit
D KIL K ONCOS K:$D(ONCOS("D")) ONCOEX D ^%ZISC Q
CTCASE ;count case
;in: COLCUTS,COLDD,COLPIECE,COLSUB,D0,GBL,N,ONCOS,TOT
; ROWCUTS,ROWDD,ROWPIECE,ROWSUB,UNK,XCRT
;out: ^TMP($J,"CELL"),TOT
N R,C
S:COLDD]"" X=$P(COLDD,U,4),COLPIECE=$P(X,";",2),COLSUB=+X
S X=$P(ROWDD,U,4),ROWPIECE=$P(X,";",2),ROWSUB=+X
W:XCRT&(N#100=1) "." Q:'$D(@(GBL_"D0)")) S TOT=TOT+1,(R,C)=UNK
I $P(ROWDD,U,2)'["C" S:$D(@(GBL_"D0,ROWSUB)"))#10=1 R=$P(@(GBL_"D0,ROWSUB)"),U,ROWPIECE)
E X $P(ROWDD,U,5,99) S Y=X D:$P(ROWDD,U,2)["D" DD^%DT S X=Y S R=X
I COLDD="" S C=1 G CT1
I $P(COLDD,U,2)'["C" S:$D(@(GBL_"D0,COLSUB)"))#10=1 C=$P(@(GBL_"D0,COLSUB)"),U,COLPIECE)
E X $P(COLDD,U,5,99) S Y=X D:$P(COLDD,U,2)["D" DD^%DT S X=Y S C=X
CT1 I C="" S C=UNK
E I COLCUTS]"" S X=C F C=1:1:$L(COLCUTS,":") I X'>$P(COLCUTS,":",C) Q
I R="" S R=UNK
E I ROWCUTS]"" S X=R F R=1:1:$L(ROWCUTS,":") I X'>$P(ROWCUTS,":",R) Q
TT I '$D(^TMP($J,"CELL",R,C)) S ^TMP($J,"CELL",R,C)=1 Q
S ^(C)=^TMP($J,"CELL",R,C)+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCOSCT 3602 printed Sep 23, 2025@20:01:41 Page 2
ONCOSCT ;Hines OIFO/GWB,RTK - CROSS TABULATE ;9/3/93
+1 ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
IN ;DIRECT CALL set ONCOS("D")=1
+1 ;in: ^DIBT,^DIPT
+2 ;ONCOS - used to force responses to setup prompts
+3 ;("F") = file number
+4 ;("T") = search template
+5 ;("R") = row field name^cutpoints, e.g., "AGE^10:20:30:40"
+6 ;("C") = column field name^cutpoints
+7 ;("P") = 1 to print total per cents, 0 to skip prompt
+8 ;("Y") = yes prompts
+9 ;("I") = IOP variable for %ZIS
+10 ;("H") = HEADER (if defined, not asked for in ONCOSCINP)
+11 ;("D") = Direct Program call, not entered at Print
+12 ;do: ^ONCOSINP,^ONCOSCT*,WAIT^DICD,^%DT,^%ZIS
+13 ;S:'$D(DTIME) DTIME=1000
SET ONCOS("D")=1
WRITE !,"ONCOLOGY Version 2 - Cross-tabs",!
PRINT ;entry point for queued report (%ZTLOAD)
+1 if $DATA(ONCOION)
SET ION=ONCOION
if $DATA(ONCOIOM)
SET IOM=ONCOIOM
+2 WRITE !!
SET (ROWDEF,TEMPL)=-1
SET UNK="~"
SET XCRT=$SELECT($GET(IOST)?1"C".E:1,1:0)
SET %=0
if '$DATA(ONCOS("FI"))
DO GETFILE^ONCOSINP
+3 SET FNUM=+ONCOS("FI")
IF '$DATA(ONCOS("T"))
DO GETTEMPL^ONCOSINP
if 'Y
GOTO EX
SET ONCOS("T")=Y
GOTO EN
+4 IF ONCOS("T")'["^"
DO GETTEMPL^ONCOSINP
if Y<0
GOTO EX
SET ONCOS("T")=Y
EN SET ONCOEX=0
SET TEMPL=ONCOS("T")
SET TEMPL=$SELECT(TEMPL="ALL":TEMPL,1:+TEMPL)
SET HEAD=$GET(ONCOS("H"))
SET HEADER=$SELECT(HEAD="":$PIECE(ONCOS("T"),U,2),1:HEAD)
+1 SET FNUM=+ONCOS("FI")
SET GLO="^"_$PIECE(ONCOS("FI"),U,3)
DO SETUP^ONCOSCT1
if ROWDD=""!(ONCOEX)
GOTO EX
+2 if $DATA(ONCOS("TK"))
GOTO CON
IF '$DATA(ONCOS("AF"))
SET ONCOS("AF")=1
+3 KILL IO("Q")
SET %ZIS="Q"
SET %ZIS("A")=" Select device to Print Cross Tabs: "
DO ^%ZIS
IF POP
SET ONCOUT=""
GOTO EX
+4 IF '$DATA(IO("Q"))
DO TSK^ONCOSCT
GOTO EX
+5 SET ZTRTN="TSK^ONCOSCT"
SET ZTDESC=HEADER
+6 SET ZTSAVE("ONCOS*")=""
+7 SET ZTSAVE("TEMPL")=""
SET ZTSAVE("XCRT")=""
SET ZTSAVE("UNK")=""
+8 SET ZTSAVE("COLCUTS")=""
SET ZTSAVE("ROWCUTS")=""
+9 SET ZTSAVE("COLDD")=""
SET ZTSAVE("ROWDD")=""
+10 SET ZTSAVE("PCT")=""
SET ZTSAVE("HEADER")=""
+11 DO ^%ZTLOAD
GOTO EX
+12 ;
TSK ;Task for internal direct calling of ONCOSCT, not from another task.
+1 KILL ^TMP($JOB)
SET ONCOEX=0
if '$DATA(ONCOS("AF"))
SET ONCOS("AF")=1
+2 SET XCRT=$SELECT($GET(IOST)?1"C".E:1,1:0)
+3 if XCRT
DO WAIT^DICD
CON WRITE !
SET %DT="T"
SET X="NOW"
DO ^%DT
XECUTE ^DD("DD")
SET GBL="^"_$PIECE(ONCOS("FI"),U,3)
+1 SET HEADER=HEADER_U_$PIECE(Y,"@",1)_" "_$PIECE(Y,"@",2)
SET (D0,NPG,TOT)=0
TEM IF TEMPL'="ALL"
SET D0=0
FOR N=1:1
SET D0=$ORDER(^DIBT(TEMPL,1,D0))
if D0'>0
GOTO OUT
DO CTCASE
+1 FOR N=1:1
SET D0=$ORDER(@(GBL_"D0)"))
if D0'>0
QUIT
DO CTCASE
OUT ;OUTPUT
+1 SET ONCOEX=0
DO OUTPUT^ONCOSCT2
if ONCOEX
GOTO EX
if '$DATA(ONCOS("TK"))
GOTO EX
KIL ;Entry point to kill all variables at EXCEPT 'ONCOS' ARRAY
+1 KILL ^TMP($JOB)
+2 KILL COLCUTS,COLDD,COLPIECE,COLS,COLSUB,D0,FNUM
+3 KILL GLB,GLO,HEAD,HEADER,N,NPG,PCT,POP,B,C,F,XX,Y,Z
+4 KILL ROWCUTS,ROWS,ROWDD,ROWPIECE,ROWSUB,TEMPL,TOT,UNK,X,XCRT
+5 KILL %,%DT,%K,%T,%ZISOS,HEAD,OF
+6 QUIT
+7 ;
EX ;Complete Exit
+1 DO KIL
KILL ONCOS
if $DATA(ONCOS("D"))
KILL ONCOEX
DO ^%ZISC
QUIT
CTCASE ;count case
+1 ;in: COLCUTS,COLDD,COLPIECE,COLSUB,D0,GBL,N,ONCOS,TOT
+2 ; ROWCUTS,ROWDD,ROWPIECE,ROWSUB,UNK,XCRT
+3 ;out: ^TMP($J,"CELL"),TOT
+4 NEW R,C
+5 if COLDD]""
SET X=$PIECE(COLDD,U,4)
SET COLPIECE=$PIECE(X,";",2)
SET COLSUB=+X
+6 SET X=$PIECE(ROWDD,U,4)
SET ROWPIECE=$PIECE(X,";",2)
SET ROWSUB=+X
+7 if XCRT&(N#100=1)
WRITE "."
if '$DATA(@(GBL_"D0)"))
QUIT
SET TOT=TOT+1
SET (R,C)=UNK
+8 IF $PIECE(ROWDD,U,2)'["C"
if $DATA(@(GBL_"D0,ROWSUB)"))#10=1
SET R=$PIECE(@(GBL_"D0,ROWSUB)"),U,ROWPIECE)
+9 IF '$TEST
XECUTE $PIECE(ROWDD,U,5,99)
SET Y=X
if $PIECE(ROWDD,U,2)["D"
DO DD^%DT
SET X=Y
SET R=X
+10 IF COLDD=""
SET C=1
GOTO CT1
+11 IF $PIECE(COLDD,U,2)'["C"
if $DATA(@(GBL_"D0,COLSUB)"))#10=1
SET C=$PIECE(@(GBL_"D0,COLSUB)"),U,COLPIECE)
+12 IF '$TEST
XECUTE $PIECE(COLDD,U,5,99)
SET Y=X
if $PIECE(COLDD,U,2)["D"
DO DD^%DT
SET X=Y
SET C=X
CT1 IF C=""
SET C=UNK
+1 IF '$TEST
IF COLCUTS]""
SET X=C
FOR C=1:1:$LENGTH(COLCUTS,":")
IF X'>$PIECE(COLCUTS,":",C)
QUIT
+2 IF R=""
SET R=UNK
+3 IF '$TEST
IF ROWCUTS]""
SET X=R
FOR R=1:1:$LENGTH(ROWCUTS,":")
IF X'>$PIECE(ROWCUTS,":",R)
QUIT
TT IF '$DATA(^TMP($JOB,"CELL",R,C))
SET ^TMP($JOB,"CELL",R,C)=1
QUIT
+1 SET ^(C)=^TMP($JOB,"CELL",R,C)+1
+2 QUIT
