- 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 Jan 18, 2025@03:27:13 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