ONCOU ;Hines OIFO/GWB ONCOTRAX utilities ;06/06/00
;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
;
ASKNUM(TXT,RNG,DFLT) ;ask for a number - expects RNG as NNN:NNN
N DIR,Y S DIR(0)="N^"_RNG,DIR("A")=TXT S:$D(DFLT) DIR("B")=DFLT D ^DIR Q Y
ASKY(TXT) ;ask a Y/N question, default YES, returns 1 for Y, 0 for N
N DIR,Y S DIR("A")=TXT,DIR(0)="Y",DIR("B")="Yes" D ^DIR S:Y=U Y=-1 Q Y
LOOKUP(FL,NTR,UIO,Y) ;look up entry NTR in File FL with user options UIO, return Y array if parameter passed
N DIC,Y S DIC=FL,DIC(0)=$G(UIO),X=NTR D ^DIC Q +Y
GETVAL(FN,DA,DR,SE,SF) ;get value of field DR in entry DA in file FN - if DR is a multiple then get subfield SF in subentry SE
N DI,DIC,DIQ,OQ,OX,D0 S DIC=FN,DIQ="OQ",OX=+$P(^DD(FN,DR,0),U,2) S:OX DA(OX)=SE,DR(OX)=SF D EN^DIQ1 Q $S(OX:OQ(OX,SE,SF),1:OQ(FN,DA,DR))
VERSION(PKG) ;get version # for pkg
N PNU,Y S PNU=+$O(^DIC(9.4,"B",PKG,"")),Y=$G(^DIC(9.4,PNU,"VERSION")) Q Y
VERCHK(PKG,VER,PATNO) ;verify version for a patch
N INST,OK S OK=0 ; assume the worst
W !!,"This routine will install ",PKG," Version ",VER," Patch ",PATNO,".",!!
S INST=$$VERSION(PKG)
I INST="" W *7,"But the ",PKG," package doesn't seem to be installed on this system!"
E I INST'=VER W *7,"But Version ",VER," of the ",PKG," package doesn't seem to be installed!" W:INST !,"(Current installed version: ",INST,")"
E S OK=1
Q OK
SITEPAR(MSG) ;Are ONCOCOLOGY SITE PARAMETERS defined?
N OK
S OK=$O(^ONCO(160.1,"C",DUZ(2),0))
I OK="" S OK=$O(^ONCO(160.1,0))
I 'OK,$G(MSG)="ERRMSG" W !!,"The ONCOLOGY SITE PARAMETERS have not been set up.",!,"Use the ""Define Tumor Registry Parameters"" Option.",!!
Q OK
LTS(DA,NOTTHIS) ;Invoked by AC cross-reference of TUMOR STATUS CODE sub-field (#.02) of TUMOR STATUS field (#73) of ONCOLOGY PRIMARY file (#165.5), sets value into LAST TUMOR STATUS field (#95)
;NOTTHIS is defined in the KILL logic - we want to skip the current TUMOR STATUS
N OX,DIE,DR,NTS,OTS
S NTS="" ; new tumor status defaults to null
S OX=$O(^ONCO(165.5,DA,"TS","AA","")) I OX,$D(NOTTHIS),$D(^ONCO(165.5,DA,"TS","AA",OX,NOTTHIS)) S OX=$O(^ONCO(165.5,DA,"TS","AA","")) ; get IEN of last status - skip the current node on the kill
S:OX OX=$O(^(OX,"")) S:OX NTS=$P($G(^ONCO(165.5,DA,"TS",OX,0)),U,2) S OTS=$P($G(^ONCO(165.5,DA,7)),U,6),$P(^(7),U,6)=NTS ;get old data, set new data
K:$L(OTS) ^ONCO(165.5,"ACS",OTS,DA) S:$L(NTS) ^ONCO(165.5,"ACS",NTS,DA)="" ;kill old xref, set new xref
Q
;
KILLNAT(FILE,SWS) ;Kill national fields only for a file
;Valid switches in SWS:/DOTS prints a dot every 10
N DOTS,DA,DIK,KT
S DOTS=(SWS["/DOTS") ;print dots?
S DA(1)=FILE
I $D(^DD(FILE)) S DIK="^DD("_FILE_",",DA=0 F KT=1:1 S DA=$O(^DD(FILE,DA)) Q:'DA!(DA'<10000) D ^DIK I DOTS W:KT#10=0 "." ;if file exists, kill national fields only
Q +$G(KT)
;
CLNNOSUS ;Delete ONCOLOGY PATIENT (160) entries with no primaries/no suspense
N TOTKT,CLNKT
W @IOF
W !
W !," This option will delete ONCOTRAX PATIENT records"
W !," with no suspense records and no primaries."
W !
L +^ONCO(160):5
I D
.K ^TMP($J,"NOSUS")
.D COUNT
.I CLNKT=0 W " No records to delete" W ! K DIR S DIR(0)="E" D ^DIR
.I CLNKT>0,$$CLNOK D PURGE
.L -^ONCO(160)
E W !!,"The ONCOTRAX PATIENT file is in use... try again later!",*7,!!
Q
;
COUNT ;Count the number of entries to delete
N OI S OI=0
S (TOTKT,CLNKT)=0
F S OI=$O(^ONCO(160,OI)) Q:OI'=+OI D CHK
W !," Total ONCOTRAX PATIENT records: ",TOTKT
W !," Total records marked for deletion: ",CLNKT,!
I CLNKT>0 W !," Patients to be deleted:" S IEN=0 F S IEN=$O(^TMP($J,"NOSUS",IEN)) Q:IEN'>0 D
.W !,?3,$$GET1^DIQ(160,IEN,60,"E")," ",$$GET1^DIQ(160,IEN,.01,"E")
W !
Q
;
CHK S TOTKT=TOTKT+1
S SUSDT=$O(^ONCO(160,OI,"SUS","B","")) I SUSDT'="" Q
Q:$D(^ONCO(165.5,"C",OI))
Q:$O(^ONCO(160,OI,"SUSNR",0))
I '$D(^ONCO(160,OI,0)) K ^ONCO(160,OI) Q
S CLNKT=CLNKT+1
S ^TMP($J,"NOSUS",OI)=""
Q
;
CLNOK() ;Confirm deletion
N DIR
S DIR("A")=" Proceed with deletion",DIR("B")="No",DIR(0)="Y"
D ^DIR
Q Y
;
PURGE ;Delete entries
N DIK S DIK="^ONCO(160,"
N DA S DA=0
F S DA=$O(^TMP($J,"NOSUS",DA)) Q:DA'=+DA D ^DIK W "."
W " DONE"
W ! K DIR S DIR(0)="E" D ^DIR
Q
;
LCASE(ONCOSTR) ;Convert string to upper/lowercase
N ONCO F ONCO=2:1:$L(ONCOSTR) I $E(ONCOSTR,ONCO)?1U,$E(ONCOSTR,ONCO-1)?1A S ONCOSTR=$E(ONCOSTR,0,ONCO-1)_$C($A(ONCOSTR,ONCO)+32)_$E(ONCOSTR,ONCO+1,999)
Q ONCOSTR
UCASE ;Convert string to uppercase
S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCOU 4594 printed Apr 09, 2024@21:26:38 Page 2
ONCOU ;Hines OIFO/GWB ONCOTRAX utilities ;06/06/00
+1 ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
+2 ;
ASKNUM(TXT,RNG,DFLT) ;ask for a number - expects RNG as NNN:NNN
+1 NEW DIR,Y
SET DIR(0)="N^"_RNG
SET DIR("A")=TXT
if $DATA(DFLT)
SET DIR("B")=DFLT
DO ^DIR
QUIT Y
ASKY(TXT) ;ask a Y/N question, default YES, returns 1 for Y, 0 for N
+1 NEW DIR,Y
SET DIR("A")=TXT
SET DIR(0)="Y"
SET DIR("B")="Yes"
DO ^DIR
if Y=U
SET Y=-1
QUIT Y
LOOKUP(FL,NTR,UIO,Y) ;look up entry NTR in File FL with user options UIO, return Y array if parameter passed
+1 NEW DIC,Y
SET DIC=FL
SET DIC(0)=$GET(UIO)
SET X=NTR
DO ^DIC
QUIT +Y
GETVAL(FN,DA,DR,SE,SF) ;get value of field DR in entry DA in file FN - if DR is a multiple then get subfield SF in subentry SE
+1 NEW DI,DIC,DIQ,OQ,OX,D0
SET DIC=FN
SET DIQ="OQ"
SET OX=+$PIECE(^DD(FN,DR,0),U,2)
if OX
SET DA(OX)=SE
SET DR(OX)=SF
DO EN^DIQ1
QUIT $SELECT(OX:OQ(OX,SE,SF),1:OQ(FN,DA,DR))
VERSION(PKG) ;get version # for pkg
+1 NEW PNU,Y
SET PNU=+$ORDER(^DIC(9.4,"B",PKG,""))
SET Y=$GET(^DIC(9.4,PNU,"VERSION"))
QUIT Y
VERCHK(PKG,VER,PATNO) ;verify version for a patch
+1 ; assume the worst
NEW INST,OK
SET OK=0
+2 WRITE !!,"This routine will install ",PKG," Version ",VER," Patch ",PATNO,".",!!
+3 SET INST=$$VERSION(PKG)
+4 IF INST=""
WRITE *7,"But the ",PKG," package doesn't seem to be installed on this system!"
+5 IF '$TEST
IF INST'=VER
WRITE *7,"But Version ",VER," of the ",PKG," package doesn't seem to be installed!"
if INST
WRITE !,"(Current installed version: ",INST,")"
+6 IF '$TEST
SET OK=1
+7 QUIT OK
SITEPAR(MSG) ;Are ONCOCOLOGY SITE PARAMETERS defined?
+1 NEW OK
+2 SET OK=$ORDER(^ONCO(160.1,"C",DUZ(2),0))
+3 IF OK=""
SET OK=$ORDER(^ONCO(160.1,0))
+4 IF 'OK
IF $GET(MSG)="ERRMSG"
WRITE !!,"The ONCOLOGY SITE PARAMETERS have not been set up.",!,"Use the ""Define Tumor Registry Parameters"" Option.",!!
+5 QUIT OK
LTS(DA,NOTTHIS) ;Invoked by AC cross-reference of TUMOR STATUS CODE sub-field (#.02) of TUMOR STATUS field (#73) of ONCOLOGY PRIMARY file (#165.5), sets value into LAST TUMOR STATUS field (#95)
+1 ;NOTTHIS is defined in the KILL logic - we want to skip the current TUMOR STATUS
+2 NEW OX,DIE,DR,NTS,OTS
+3 ; new tumor status defaults to null
SET NTS=""
+4 ; get IEN of last status - skip the current node on the kill
SET OX=$ORDER(^ONCO(165.5,DA,"TS","AA",""))
IF OX
IF $DATA(NOTTHIS)
IF $DATA(^ONCO(165.5,DA,"TS","AA",OX,NOTTHIS))
SET OX=$ORDER(^ONCO(165.5,DA,"TS","AA",""))
+5 ;get old data, set new data
if OX
SET OX=$ORDER(^(OX,""))
if OX
SET NTS=$PIECE($GET(^ONCO(165.5,DA,"TS",OX,0)),U,2)
SET OTS=$PIECE($GET(^ONCO(165.5,DA,7)),U,6)
SET $PIECE(^(7),U,6)=NTS
+6 ;kill old xref, set new xref
if $LENGTH(OTS)
KILL ^ONCO(165.5,"ACS",OTS,DA)
if $LENGTH(NTS)
SET ^ONCO(165.5,"ACS",NTS,DA)=""
+7 QUIT
+8 ;
KILLNAT(FILE,SWS) ;Kill national fields only for a file
+1 ;Valid switches in SWS:/DOTS prints a dot every 10
+2 NEW DOTS,DA,DIK,KT
+3 ;print dots?
SET DOTS=(SWS["/DOTS")
+4 SET DA(1)=FILE
+5 ;if file exists, kill national fields only
IF $DATA(^DD(FILE))
SET DIK="^DD("_FILE_","
SET DA=0
FOR KT=1:1
SET DA=$ORDER(^DD(FILE,DA))
if 'DA!(DA'<10000)
QUIT
DO ^DIK
IF DOTS
if KT#10=0
WRITE "."
+6 QUIT +$GET(KT)
+7 ;
CLNNOSUS ;Delete ONCOLOGY PATIENT (160) entries with no primaries/no suspense
+1 NEW TOTKT,CLNKT
+2 WRITE @IOF
+3 WRITE !
+4 WRITE !," This option will delete ONCOTRAX PATIENT records"
+5 WRITE !," with no suspense records and no primaries."
+6 WRITE !
+7 LOCK +^ONCO(160):5
+8 IF $TEST
Begin DoDot:1
+9 KILL ^TMP($JOB,"NOSUS")
+10 DO COUNT
+11 IF CLNKT=0
WRITE " No records to delete"
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
+12 IF CLNKT>0
IF $$CLNOK
DO PURGE
+13 LOCK -^ONCO(160)
End DoDot:1
+14 IF '$TEST
WRITE !!,"The ONCOTRAX PATIENT file is in use... try again later!",*7,!!
+15 QUIT
+16 ;
COUNT ;Count the number of entries to delete
+1 NEW OI
SET OI=0
+2 SET (TOTKT,CLNKT)=0
+3 FOR
SET OI=$ORDER(^ONCO(160,OI))
if OI'=+OI
QUIT
DO CHK
+4 WRITE !," Total ONCOTRAX PATIENT records: ",TOTKT
+5 WRITE !," Total records marked for deletion: ",CLNKT,!
+6 IF CLNKT>0
WRITE !," Patients to be deleted:"
SET IEN=0
FOR
SET IEN=$ORDER(^TMP($JOB,"NOSUS",IEN))
if IEN'>0
QUIT
Begin DoDot:1
+7 WRITE !,?3,$$GET1^DIQ(160,IEN,60,"E")," ",$$GET1^DIQ(160,IEN,.01,"E")
End DoDot:1
+8 WRITE !
+9 QUIT
+10 ;
CHK SET TOTKT=TOTKT+1
+1 SET SUSDT=$ORDER(^ONCO(160,OI,"SUS","B",""))
IF SUSDT'=""
QUIT
+2 if $DATA(^ONCO(165.5,"C",OI))
QUIT
+3 if $ORDER(^ONCO(160,OI,"SUSNR",0))
QUIT
+4 IF '$DATA(^ONCO(160,OI,0))
KILL ^ONCO(160,OI)
QUIT
+5 SET CLNKT=CLNKT+1
+6 SET ^TMP($JOB,"NOSUS",OI)=""
+7 QUIT
+8 ;
CLNOK() ;Confirm deletion
+1 NEW DIR
+2 SET DIR("A")=" Proceed with deletion"
SET DIR("B")="No"
SET DIR(0)="Y"
+3 DO ^DIR
+4 QUIT Y
+5 ;
PURGE ;Delete entries
+1 NEW DIK
SET DIK="^ONCO(160,"
+2 NEW DA
SET DA=0
+3 FOR
SET DA=$ORDER(^TMP($JOB,"NOSUS",DA))
if DA'=+DA
QUIT
DO ^DIK
WRITE "."
+4 WRITE " DONE"
+5 WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
+6 QUIT
+7 ;
LCASE(ONCOSTR) ;Convert string to upper/lowercase
+1 NEW ONCO
FOR ONCO=2:1:$LENGTH(ONCOSTR)
IF $EXTRACT(ONCOSTR,ONCO)?1U
IF $EXTRACT(ONCOSTR,ONCO-1)?1A
SET ONCOSTR=$EXTRACT(ONCOSTR,0,ONCO-1)_$CHAR($ASCII(ONCOSTR,ONCO)+32)_$EXTRACT(ONCOSTR,ONCO+1,999)
+2 QUIT ONCOSTR
UCASE ;Convert string to uppercase
+1 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 QUIT
