- ONCOFDP ;Hines OIFO/GWB - FOLLOW DEAD PATIENTS ;07/12/00
- ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
- DEAD ;Death information
- K DXS,DIOT S D0=ONCOD0,DIR("A")=" Edit Data",DIR("B")="Y",DIR(0)="Y"
- D ^ONCOXDI,^DIR G ED:Y,RC:'Y,EX
- ;
- ED W !! S DA=ONCOD0,DR="[ONCO DEATH]",DIE="^ONCO(160," D ^DIE
- W !! K DXS,DIOT D ^ONCOXDI
- S DIR("A")=" Data OK",DIR("B")="Yes",DIR(0)="Y" D ^DIR G ED:'Y,RC:Y,EX
- ;
- RC W !!,"First Recurrence Information..."
- S XD1=0,UPOUT=""
- F S XD1=$O(^ONCO(165.5,"C",ONCOD0,XD1)) Q:XD1'>0 D Q:UPOUT="Y"
- .S ONCOX2=$G(^ONCO(165.5,XD1,2)),ONCOTOP=$P(ONCOX2,U,1)
- .S TOP=$P($G(^ONCO(164,+ONCOTOP,0)),U,1)
- .S SITEGP=$P(^ONCO(165.5,XD1,0),U,1)
- .S ACCNO=$P(^ONCO(165.5,XD1,0),U,5),SEQNO=$P(^ONCO(165.5,XD1,0),U,6)
- .W !!,"Primary: ",$E(ACCNO,1,4),"-",$E(ACCNO,5,9),"/",SEQNO," ",TOP,!
- .S DIE="^ONCO(165.5,",DA=XD1,DR="71;D CHECK^ONCOFDP;70;@1" D ^DIE I $D(Y) S UPOUT="Y"
- D CHKCHG^ONCOAIF
- ;
- DC ;Delete Contacts
- Q:'$D(^ONCO(160,"APC",ONCOD0))
- H W @IOF,!!!?15,"--------------DELETE PATIENT'S CONTACTS---------------"
- S D0=ONCOD0 K DXS,DIOT D ^ONCOXCL
- W !!?5,"Patient is dead - please delete contacts as soon as possible."
- W !?5,"Deletion will affect this patient's contacts only.",!
- S DIR("A")=" Delete Contacts",DIR(0)="Y",DIR("B")="Yes" D ^DIR,KC:Y
- Q
- ;
- KC ;Delete FOLLOW-UP CONTACT (160.03) sub-file and CONTACT (165) file
- ;entries
- D WAIT^DICD W !?5,"Deleting contacts..." D EN1 G EX
- EN1 S XDC=0 F S XDC=$O(^ONCO(160,"APC",ONCOD0,XDC)) Q:XDC'>0 S ONCOC0=XDC D I C=0 S DIK="^ONCO(165,",DA=ONCOC0 D ^DIK W "*"
- .S C=0
- .S XDP=0 F S XDP=$O(^ONCO(160,"ACP",ONCOC0,XDP)) Q:XDP'>0 I XDP'=ONCOD0 S C=1 Q
- .I C=1 Q
- .S XDP=0 F S XDP=$O(^ONCO(160,"AC",ONCOC0,XDP)) Q:XDP'>0 I XDP'=ONCOD0 S C=1 Q
- .I C=1 Q
- .S XDP=0 F S XDP=$O(^ONCO(160,"AE",ONCOC0,XDP)) Q:XDP'>0 I XDP'=ONCOD0 S C=1 Q
- .I C=1 Q
- .I $D(^ONCO(165.5,"APS",ONCOC0)) S C=1 Q
- .I $D(^ONCO(165.5,"AFP",ONCOC0)) S C=1 Q
- .I $D(^ONCO(165.5,"AMP",ONCOC0)) S C=1 Q
- .I $D(^ONCO(165.5,"AOP3",ONCOC0)) S C=1 Q
- .I $D(^ONCO(165.5,"AOP4",ONCOC0)) S C=1 Q
- .I $D(^ONCO(165.5,"APST",ONCOC0)) S C=1 Q
- ;Delete FOLLOW-UP CONTACT (160,420) sub-file (160.03)
- S DA=0,DA(1)=ONCOD0 F S DA=$O(^ONCO(160,DA(1),"C",DA)) Q:DA'?1.N S DIK="^ONCO(160,"_DA(1)_",""C""," D ^DIK
- I '$D(ONCODAC) S D0=ONCOD0 D ^ONCOXCL W ?35,"(None - Patient is Deceased)"
- N ONCOC0 S ONCOC0=$P(^ONCO(160,ONCOD0,1),U,6) G KA:ONCOC0="",KA:$D(^ONCO(165,ONCOC0,0))
- CD S X="<CONTACT DELETED>",Y=$O(^ONCO(165,"B",X,0))
- I Y="" S (DIC,DLAYGO)="^ONCO(165,",DIC(0)="ZL" D FILE^DICN
- S OLDLFC=$P($G(^ONCO(160,ONCOD0,1)),U,6)
- K:OLDLFC'="" ^ONCO(160,"AC",OLDLFC,ONCOD0)
- S $P(^ONCO(160,ONCOD0,1),U,6)=+Y
- S ^ONCO(160,"AC",+Y,ONCOD0)=""
- K OLDLFC
- KA ;Delete FOLLOW-UP ATTEMPTS (160,410) sub-file (160.06)
- W:'$D(ONCODAC) !!?5,"Deleting Follow-up Attempts..."
- S XX=$P($G(^ONCO(160,ONCOD0,"A",0)),U,3) I XX'="" S DIK="^ONCO(160,"_DA(1)_",""A""," F DA=1:1:XX I $D(^(DA)) D ^DIK
- F I="A","C" K ^ONCO(160,DA(1),I)
- Q
- ;
- DAC ;Delete dead patients's Contacts
- W @IOF,"ARCHIVING of Contact File, Attempts and Contacts"
- W !!?5,"For dead patients - clean out unnecessary data.",!!!
- W ?5,"Working..."
- S XD0=0 F S XD0=$O(^ONCO(160,"AS",0,XD0)) Q:XD0'>0 S ONCOD0=XD0,ONCODAC=1 D EN1 W:'(XD0#100) "."
- EX ;RETURN from calling program, ONCOAIF/ONCOFUL
- K RC,RT,XD0,XX,XD1,XDC,I,DIK,DIC,XDP,ONCOD1
- Q
- CHECK ;Check TYPE of FIRST RECURRENCE
- ;If 99, stuff 99/99/9999 into DATE of FIRST RECURRENCE
- ;If 00 or 70, stuff 00/00/0000 into DATE of FIRST RECURRENCE
- S TOFR=$P($G(^ONCO(165.5,XD1,5)),U,2)
- Q:TOFR=""
- I $P($G(^ONCO(160.12,TOFR,0)),U,1)=99 D
- .S $P(^ONCO(165.5,XD1,5),U,1)=9999999
- .W !,"DATE of FIRST RECURRENCE: 99/99/9999//"
- .S Y="@1"
- I ($P($G(^ONCO(160.12,TOFR,0)),U,1)="00")!($P($G(^ONCO(160.12,TOFR,0)),U,1)=70) D
- .S $P(^ONCO(165.5,XD1,5),U,1)="0000000"
- .W !,"DATE of FIRST RECURRENCE: 00/00/0000//"
- .S Y="@1"
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCOFDP 3940 printed Feb 18, 2025@23:51:31 Page 2
- ONCOFDP ;Hines OIFO/GWB - FOLLOW DEAD PATIENTS ;07/12/00
- +1 ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
- DEAD ;Death information
- +1 KILL DXS,DIOT
- SET D0=ONCOD0
- SET DIR("A")=" Edit Data"
- SET DIR("B")="Y"
- SET DIR(0)="Y"
- +2 DO ^ONCOXDI
- DO ^DIR
- if Y
- GOTO ED
- if 'Y
- GOTO RC
- GOTO EX
- +3 ;
- ED WRITE !!
- SET DA=ONCOD0
- SET DR="[ONCO DEATH]"
- SET DIE="^ONCO(160,"
- DO ^DIE
- +1 WRITE !!
- KILL DXS,DIOT
- DO ^ONCOXDI
- +2 SET DIR("A")=" Data OK"
- SET DIR("B")="Yes"
- SET DIR(0)="Y"
- DO ^DIR
- if 'Y
- GOTO ED
- if Y
- GOTO RC
- GOTO EX
- +3 ;
- RC WRITE !!,"First Recurrence Information..."
- +1 SET XD1=0
- SET UPOUT=""
- +2 FOR
- SET XD1=$ORDER(^ONCO(165.5,"C",ONCOD0,XD1))
- if XD1'>0
- QUIT
- Begin DoDot:1
- +3 SET ONCOX2=$GET(^ONCO(165.5,XD1,2))
- SET ONCOTOP=$PIECE(ONCOX2,U,1)
- +4 SET TOP=$PIECE($GET(^ONCO(164,+ONCOTOP,0)),U,1)
- +5 SET SITEGP=$PIECE(^ONCO(165.5,XD1,0),U,1)
- +6 SET ACCNO=$PIECE(^ONCO(165.5,XD1,0),U,5)
- SET SEQNO=$PIECE(^ONCO(165.5,XD1,0),U,6)
- +7 WRITE !!,"Primary: ",$EXTRACT(ACCNO,1,4),"-",$EXTRACT(ACCNO,5,9),"/",SEQNO," ",TOP,!
- +8 SET DIE="^ONCO(165.5,"
- SET DA=XD1
- SET DR="71;D CHECK^ONCOFDP;70;@1"
- DO ^DIE
- IF $DATA(Y)
- SET UPOUT="Y"
- End DoDot:1
- if UPOUT="Y"
- QUIT
- +9 DO CHKCHG^ONCOAIF
- +10 ;
- DC ;Delete Contacts
- +1 if '$DATA(^ONCO(160,"APC",ONCOD0))
- QUIT
- H WRITE @IOF,!!!?15,"--------------DELETE PATIENT'S CONTACTS---------------"
- +1 SET D0=ONCOD0
- KILL DXS,DIOT
- DO ^ONCOXCL
- +2 WRITE !!?5,"Patient is dead - please delete contacts as soon as possible."
- +3 WRITE !?5,"Deletion will affect this patient's contacts only.",!
- +4 SET DIR("A")=" Delete Contacts"
- SET DIR(0)="Y"
- SET DIR("B")="Yes"
- DO ^DIR
- if Y
- DO KC
- +5 QUIT
- +6 ;
- KC ;Delete FOLLOW-UP CONTACT (160.03) sub-file and CONTACT (165) file
- +1 ;entries
- +2 DO WAIT^DICD
- WRITE !?5,"Deleting contacts..."
- DO EN1
- GOTO EX
- EN1 SET XDC=0
- FOR
- SET XDC=$ORDER(^ONCO(160,"APC",ONCOD0,XDC))
- if XDC'>0
- QUIT
- SET ONCOC0=XDC
- Begin DoDot:1
- +1 SET C=0
- +2 SET XDP=0
- FOR
- SET XDP=$ORDER(^ONCO(160,"ACP",ONCOC0,XDP))
- if XDP'>0
- QUIT
- IF XDP'=ONCOD0
- SET C=1
- QUIT
- +3 IF C=1
- QUIT
- +4 SET XDP=0
- FOR
- SET XDP=$ORDER(^ONCO(160,"AC",ONCOC0,XDP))
- if XDP'>0
- QUIT
- IF XDP'=ONCOD0
- SET C=1
- QUIT
- +5 IF C=1
- QUIT
- +6 SET XDP=0
- FOR
- SET XDP=$ORDER(^ONCO(160,"AE",ONCOC0,XDP))
- if XDP'>0
- QUIT
- IF XDP'=ONCOD0
- SET C=1
- QUIT
- +7 IF C=1
- QUIT
- +8 IF $DATA(^ONCO(165.5,"APS",ONCOC0))
- SET C=1
- QUIT
- +9 IF $DATA(^ONCO(165.5,"AFP",ONCOC0))
- SET C=1
- QUIT
- +10 IF $DATA(^ONCO(165.5,"AMP",ONCOC0))
- SET C=1
- QUIT
- +11 IF $DATA(^ONCO(165.5,"AOP3",ONCOC0))
- SET C=1
- QUIT
- +12 IF $DATA(^ONCO(165.5,"AOP4",ONCOC0))
- SET C=1
- QUIT
- +13 IF $DATA(^ONCO(165.5,"APST",ONCOC0))
- SET C=1
- QUIT
- End DoDot:1
- IF C=0
- SET DIK="^ONCO(165,"
- SET DA=ONCOC0
- DO ^DIK
- WRITE "*"
- +14 ;Delete FOLLOW-UP CONTACT (160,420) sub-file (160.03)
- +15 SET DA=0
- SET DA(1)=ONCOD0
- FOR
- SET DA=$ORDER(^ONCO(160,DA(1),"C",DA))
- if DA'?1.N
- QUIT
- SET DIK="^ONCO(160,"_DA(1)_",""C"","
- DO ^DIK
- +16 IF '$DATA(ONCODAC)
- SET D0=ONCOD0
- DO ^ONCOXCL
- WRITE ?35,"(None - Patient is Deceased)"
- +17 NEW ONCOC0
- SET ONCOC0=$PIECE(^ONCO(160,ONCOD0,1),U,6)
- if ONCOC0=""
- GOTO KA
- if $DATA(^ONCO(165,ONCOC0,0))
- GOTO KA
- CD SET X="<CONTACT DELETED>"
- SET Y=$ORDER(^ONCO(165,"B",X,0))
- +1 IF Y=""
- SET (DIC,DLAYGO)="^ONCO(165,"
- SET DIC(0)="ZL"
- DO FILE^DICN
- +2 SET OLDLFC=$PIECE($GET(^ONCO(160,ONCOD0,1)),U,6)
- +3 if OLDLFC'=""
- KILL ^ONCO(160,"AC",OLDLFC,ONCOD0)
- +4 SET $PIECE(^ONCO(160,ONCOD0,1),U,6)=+Y
- +5 SET ^ONCO(160,"AC",+Y,ONCOD0)=""
- +6 KILL OLDLFC
- KA ;Delete FOLLOW-UP ATTEMPTS (160,410) sub-file (160.06)
- +1 if '$DATA(ONCODAC)
- WRITE !!?5,"Deleting Follow-up Attempts..."
- +2 SET XX=$PIECE($GET(^ONCO(160,ONCOD0,"A",0)),U,3)
- IF XX'=""
- SET DIK="^ONCO(160,"_DA(1)_",""A"","
- FOR DA=1:1:XX
- IF $DATA(^(DA))
- DO ^DIK
- +3 FOR I="A","C"
- KILL ^ONCO(160,DA(1),I)
- +4 QUIT
- +5 ;
- DAC ;Delete dead patients's Contacts
- +1 WRITE @IOF,"ARCHIVING of Contact File, Attempts and Contacts"
- +2 WRITE !!?5,"For dead patients - clean out unnecessary data.",!!!
- +3 WRITE ?5,"Working..."
- +4 SET XD0=0
- FOR
- SET XD0=$ORDER(^ONCO(160,"AS",0,XD0))
- if XD0'>0
- QUIT
- SET ONCOD0=XD0
- SET ONCODAC=1
- DO EN1
- if '(XD0#100)
- WRITE "."
- EX ;RETURN from calling program, ONCOAIF/ONCOFUL
- +1 KILL RC,RT,XD0,XX,XD1,XDC,I,DIK,DIC,XDP,ONCOD1
- +2 QUIT
- CHECK ;Check TYPE of FIRST RECURRENCE
- +1 ;If 99, stuff 99/99/9999 into DATE of FIRST RECURRENCE
- +2 ;If 00 or 70, stuff 00/00/0000 into DATE of FIRST RECURRENCE
- +3 SET TOFR=$PIECE($GET(^ONCO(165.5,XD1,5)),U,2)
- +4 if TOFR=""
- QUIT
- +5 IF $PIECE($GET(^ONCO(160.12,TOFR,0)),U,1)=99
- Begin DoDot:1
- +6 SET $PIECE(^ONCO(165.5,XD1,5),U,1)=9999999
- +7 WRITE !,"DATE of FIRST RECURRENCE: 99/99/9999//"
- +8 SET Y="@1"
- End DoDot:1
- +9 IF ($PIECE($GET(^ONCO(160.12,TOFR,0)),U,1)="00")!($PIECE($GET(^ONCO(160.12,TOFR,0)),U,1)=70)
- Begin DoDot:1
- +10 SET $PIECE(^ONCO(165.5,XD1,5),U,1)="0000000"
- +11 WRITE !,"DATE of FIRST RECURRENCE: 00/00/0000//"
- +12 SET Y="@1"
- End DoDot:1