DGYMF31A.m

DGYMF31A ;ALB/CMM FIND DANGLING PT IN ^DPT TO ^DIC(31 ;12/30/94

 ;;5.3;Registration;**53,1015**;Aug 13, 1993;Build 21

 ;

 ;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

DGYMF31A  ;ALB/CMM FIND DANGLING PT IN ^DPT TO ^DIC(31 ;12/30/94

 +1       ;;5.3;Registration;**53,1015**;Aug 13, 1993;Build 21

 +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