DGYMF31A ;ALB/CMM FIND DANGLING PT IN ^DPT TO ^DIC(31 ;12/30/94
;;5.3;Registration;**53**;Aug 13, 1993
;
;This is a one shot routine that will loop through the patient
;file entries looking at the disabilities to see if the pointer
;values are valid to file 31 (disability conditions file).
;
DRIVE ;
U IO S PAGE=1
D LOOP
S ^TMP($J,"DG31",0)=NXT,INDEX="B"
D HEAD1 I $O(^TMP($J,"DG31",0))="" W !!,"No bad pointers." Q
D REPORT I END="Y" Q
I $D(^TMP($J,"DG31","D")) S INDEX="D" D HEAD I END'="Y" D REPORT
I END'="Y" W !!,"TOTAL PATIENTS WITH DANGLING POINTER(S) = ",NXT
I $D(ZTSK) D EXIT^DGYMF31
Q
LOOP ;looping through patient file
S (DFN,NXT,CPT)=0 K ^TMP($J,"DG31")
F S DFN=$O(^DPT(DFN)) Q:'DFN D
.S (ANY,CNT)=0,CPT=CPT+1
.I $E(IOST,1,2)="C-" W:'(CPT#100) "."
.F S CNT=$O(^DPT(DFN,.372,CNT)) Q:CNT="" D
..S PTR=+^DPT(DFN,.372,CNT,0)
..I '$D(^DIC(31,PTR,0)) D:BADDEL="Y" KILL S ANY=ANY+1 I ANY D FOUND
.I ANY&(INVALID="Y") D DIS
Q
FOUND ;
S LAST=$$LTD(DFN)
S DEAD=+$G(^DPT(DFN,.35))
I '$D(^TMP($J,"DG31",$S('DEAD:"B",1:"D"),$P(^DPT(DFN,0),"^"))) D
.S NXT=NXT+1,^TMP($J,"DG31",NXT)=$P(^DPT(DFN,0),"^")_"^"_$P(^DPT(DFN,0),"^",9)_"^"_$P(^DPT(DFN,0),"^",3)_"^"_LAST_"^"_DEAD
.S ^TMP($J,"DG31",$S('DEAD:"B",1:"D"),$P(^DPT(DFN,0),"^"),NXT)=""
Q
DIS ;include 'good' disabilities in report
N PTR,TLP,TCT S (TLP,TCT)=0
F S TLP=$O(^DPT(DFN,.372,TLP)) Q:TLP="" D
.S PTR=+^DPT(DFN,.372,TLP,0)
.I $D(^DIC(31,PTR,0)) S TCT=TCT+1,^TMP($J,"DG31",NXT,TCT)=$P(^DIC(31,PTR,0),"^")
Q
HEAD ;
S END="N"
I ($E(IOST,1,2)="C-") S DIR(0)="E" D ^DIR I 'Y S END="Y" K X,Y,DUOUT,DTOUT,DIRUT Q
HEAD1 ;
W @IOF
W !!,"Patients with bad pointers in the Rated Disability field ",?100,"PAGE ",PAGE,!
W !,?5,"Patient Name",?35,"SSN",?50,"Date of Birth",?70,"Last Date of Contact"
I INDEX="D" W ?100,"Date of Death"
I INVALID="Y" W !,?10,"Valid Disabilities on file"
W !
S PAGE=PAGE+1
Q
REPORT ;Display information gathered.
N NM S LP=0,END="N",NM=""
F S NM=$O(^TMP($J,"DG31",INDEX,NM)) Q:(NM="")!(END="Y") D
.F S LP=$O(^TMP($J,"DG31",INDEX,NM,LP)) Q:(LP="")!(END="Y") D
..I $Y+3>IOSL D HEAD I END="Y" Q
..D DATA
..I INVALID="Y" D DATA2
Q
DATA ;
N NODE S NODE=^TMP($J,"DG31",LP)
S SSN=$P(NODE,"^",2),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)
S DEAD=$$FMTE^XLFDT($P(NODE,"^",5)) I DEAD=0 S DEAD=""
S LAST=$$FMTE^XLFDT($P(NODE,"^",4)) I LAST=0 S LAST=""
W !,$P(NODE,"^"),?31,SSN,?50,$$FMTE^XLFDT($P(NODE,"^",3)),?70,LAST,?100,DEAD
;NAME,SSN,DOB,LAST DATE OF CONTACT,DATE OF DEATH
Q
;
DATA2 ;
N TCT S TCT=0
F S TCT=$O(^TMP($J,"DG31",LP,TCT)) Q:TCT=""!(END="Y") D
.I $Y+2>IOSL D HEAD I END'="Y" S NX="Y"
.I END="Y" Q
.I $D(NX) K NX D DATA
.W !,?10,^TMP($J,"DG31",LP,TCT)
Q
LTD(DFN) ; Find Last Treatment Date
; Input: DFN - pointer to the patient in file #2
; Output: LTD - Last Treatment Date (really last date seen at facility)
;
N LTD,X
; - if current inpatient, set LTD = today and quit
I $G(^DPT(DFN,.105)) S LTD=DT G LTDQ
; - get the last discharge date
S LTD=+$O(^DGPM("ATID3",DFN,"")) S:LTD LTD=9999999.9999999-LTD\1 S:LTD>DT LTD=DT
; - get the last registration date and compare to LTD
S X=+$O(^DPT(DFN,"DIS",0)) I X S X=9999999-X\1 S:X>LTD LTD=X
; - get the last appointment and compare to LTD
S X=LTD F S X=$O(^DPT(DFN,"S",X)) Q:'X!(X>DT) I $D(^(X,0)),$P(^(0),"^",2)="" S LTD=X\1
; - get the last stop and compare to LTD
S X=LTD F S X=$O(^SDV("ADT",DFN,X)) Q:'X S LTD=X
LTDQ Q LTD
;
KILL ;Delete pointer from Patient file
S DA(1)=DFN,DA=CNT,DIK="^DPT("_DA(1)_",.372," D ^DIK K DIK,DA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGYMF31A 3662 printed Sep 23, 2025@20:36:13 Page 2
DGYMF31A ;ALB/CMM FIND DANGLING PT IN ^DPT TO ^DIC(31 ;12/30/94
+1 ;;5.3;Registration;**53**;Aug 13, 1993
+2 ;
+3 ;This is a one shot routine that will loop through the patient
+4 ;file entries looking at the disabilities to see if the pointer
+5 ;values are valid to file 31 (disability conditions file).
+6 ;
DRIVE ;
+1 USE IO
SET PAGE=1
+2 DO LOOP
+3 SET ^TMP($JOB,"DG31",0)=NXT
SET INDEX="B"
+4 DO HEAD1
IF $ORDER(^TMP($JOB,"DG31",0))=""
WRITE !!,"No bad pointers."
QUIT
+5 DO REPORT
IF END="Y"
QUIT
+6 IF $DATA(^TMP($JOB,"DG31","D"))
SET INDEX="D"
DO HEAD
IF END'="Y"
DO REPORT
+7 IF END'="Y"
WRITE !!,"TOTAL PATIENTS WITH DANGLING POINTER(S) = ",NXT
+8 IF $DATA(ZTSK)
DO EXIT^DGYMF31
+9 QUIT
LOOP ;looping through patient file
+1 SET (DFN,NXT,CPT)=0
KILL ^TMP($JOB,"DG31")
+2 FOR
SET DFN=$ORDER(^DPT(DFN))
if 'DFN
QUIT
Begin DoDot:1
+3 SET (ANY,CNT)=0
SET CPT=CPT+1
+4 IF $EXTRACT(IOST,1,2)="C-"
if '(CPT#100)
WRITE "."
+5 FOR
SET CNT=$ORDER(^DPT(DFN,.372,CNT))
if CNT=""
QUIT
Begin DoDot:2
+6 SET PTR=+^DPT(DFN,.372,CNT,0)
+7 IF '$DATA(^DIC(31,PTR,0))
if BADDEL="Y"
DO KILL
SET ANY=ANY+1
IF ANY
DO FOUND
End DoDot:2
+8 IF ANY&(INVALID="Y")
DO DIS
End DoDot:1
+9 QUIT
FOUND ;
+1 SET LAST=$$LTD(DFN)
+2 SET DEAD=+$GET(^DPT(DFN,.35))
+3 IF '$DATA(^TMP($JOB,"DG31",$SELECT('DEAD:"B",1:"D"),$PIECE(^DPT(DFN,0),"^")))
Begin DoDot:1
+4 SET NXT=NXT+1
SET ^TMP($JOB,"DG31",NXT)=$PIECE(^DPT(DFN,0),"^")_"^"_$PIECE(^DPT(DFN,0),"^",9)_"^"_$PIECE(^DPT(DFN,0),"^",3)_"^"_LAST_"^"_DEAD
+5 SET ^TMP($JOB,"DG31",$SELECT('DEAD:"B",1:"D"),$PIECE(^DPT(DFN,0),"^"),NXT)=""
End DoDot:1
+6 QUIT
DIS ;include 'good' disabilities in report
+1 NEW PTR,TLP,TCT
SET (TLP,TCT)=0
+2 FOR
SET TLP=$ORDER(^DPT(DFN,.372,TLP))
if TLP=""
QUIT
Begin DoDot:1
+3 SET PTR=+^DPT(DFN,.372,TLP,0)
+4 IF $DATA(^DIC(31,PTR,0))
SET TCT=TCT+1
SET ^TMP($JOB,"DG31",NXT,TCT)=$PIECE(^DIC(31,PTR,0),"^")
End DoDot:1
+5 QUIT
HEAD ;
+1 SET END="N"
+2 IF ($EXTRACT(IOST,1,2)="C-")
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET END="Y"
KILL X,Y,DUOUT,DTOUT,DIRUT
QUIT
HEAD1 ;
+1 WRITE @IOF
+2 WRITE !!,"Patients with bad pointers in the Rated Disability field ",?100,"PAGE ",PAGE,!
+3 WRITE !,?5,"Patient Name",?35,"SSN",?50,"Date of Birth",?70,"Last Date of Contact"
+4 IF INDEX="D"
WRITE ?100,"Date of Death"
+5 IF INVALID="Y"
WRITE !,?10,"Valid Disabilities on file"
+6 WRITE !
+7 SET PAGE=PAGE+1
+8 QUIT
REPORT ;Display information gathered.
+1 NEW NM
SET LP=0
SET END="N"
SET NM=""
+2 FOR
SET NM=$ORDER(^TMP($JOB,"DG31",INDEX,NM))
if (NM="")!(END="Y")
QUIT
Begin DoDot:1
+3 FOR
SET LP=$ORDER(^TMP($JOB,"DG31",INDEX,NM,LP))
if (LP="")!(END="Y")
QUIT
Begin DoDot:2
+4 IF $Y+3>IOSL
DO HEAD
IF END="Y"
QUIT
+5 DO DATA
+6 IF INVALID="Y"
DO DATA2
End DoDot:2
End DoDot:1
+7 QUIT
DATA ;
+1 NEW NODE
SET NODE=^TMP($JOB,"DG31",LP)
+2 SET SSN=$PIECE(NODE,"^",2)
SET SSN=$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,10)
+3 SET DEAD=$$FMTE^XLFDT($PIECE(NODE,"^",5))
IF DEAD=0
SET DEAD=""
+4 SET LAST=$$FMTE^XLFDT($PIECE(NODE,"^",4))
IF LAST=0
SET LAST=""
+5 WRITE !,$PIECE(NODE,"^"),?31,SSN,?50,$$FMTE^XLFDT($PIECE(NODE,"^",3)),?70,LAST,?100,DEAD
+6 ;NAME,SSN,DOB,LAST DATE OF CONTACT,DATE OF DEATH
+7 QUIT
+8 ;
DATA2 ;
+1 NEW TCT
SET TCT=0
+2 FOR
SET TCT=$ORDER(^TMP($JOB,"DG31",LP,TCT))
if TCT=""!(END="Y")
QUIT
Begin DoDot:1
+3 IF $Y+2>IOSL
DO HEAD
IF END'="Y"
SET NX="Y"
+4 IF END="Y"
QUIT
+5 IF $DATA(NX)
KILL NX
DO DATA
+6 WRITE !,?10,^TMP($JOB,"DG31",LP,TCT)
End DoDot:1
+7 QUIT
LTD(DFN) ; Find Last Treatment Date
+1 ; Input: DFN - pointer to the patient in file #2
+2 ; Output: LTD - Last Treatment Date (really last date seen at facility)
+3 ;
+4 NEW LTD,X
+5 ; - if current inpatient, set LTD = today and quit
+6 IF $GET(^DPT(DFN,.105))
SET LTD=DT
GOTO LTDQ
+7 ; - get the last discharge date
+8 SET LTD=+$ORDER(^DGPM("ATID3",DFN,""))
if LTD
SET LTD=9999999.9999999-LTD\1
if LTD>DT
SET LTD=DT
+9 ; - get the last registration date and compare to LTD
+10 SET X=+$ORDER(^DPT(DFN,"DIS",0))
IF X
SET X=9999999-X\1
if X>LTD
SET LTD=X
+11 ; - get the last appointment and compare to LTD
+12 SET X=LTD
FOR
SET X=$ORDER(^DPT(DFN,"S",X))
if 'X!(X>DT)
QUIT
IF $DATA(^(X,0))
IF $PIECE(^(0),"^",2)=""
SET LTD=X\1
+13 ; - get the last stop and compare to LTD
+14 SET X=LTD
FOR
SET X=$ORDER(^SDV("ADT",DFN,X))
if 'X
QUIT
SET LTD=X
LTDQ QUIT LTD
+1 ;
KILL ;Delete pointer from Patient file
+1 SET DA(1)=DFN
SET DA=CNT
SET DIK="^DPT("_DA(1)_",.372,"
DO ^DIK
KILL DIK,DA
+2 QUIT
