DGENCDRP.m

DGENCDRP ;ISA/Zoltan - Catastrophic Disability Eligibily Code Report;6/24/99

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

REPORT ; Print a report of all patients having the CATASTROPHICALLY DISABLED

 ; Eligibility code.

 W:$X !!

 W "This routine will print a report of all patients having the",!

 W "inactivated CATASTROPHIC DISABILITY eligibility code.",!

 N PFX,L,DIC,FLDS,BY,DIOBEG,DIOEND

 D DT^DICRW ; Set up FM required variables.

 S PFX="^TMP($J,""DGENCDRP""," ; Partial global reference.

 S DIOBEG="D MAKELIST^DGENCDRP(""^TMP($J,""""DGENCDRP"""")"",$J'="_$J_")"

 S DIOEND="K ^TMP($J,""DGENCDRP"")"

 S L=0 ; No SORT prompt.

 S DIC="^DPT(" ; Global prefix.

 S FLDS="[DGENCD ELIG CODE]" ; Fields to print.

 S BY(0)=PFX ; Sorted list.

 S L(0)=2 ; Number of subscripts in sorted list.

 D EN1^DIP

 Q

MAKELIST(ARR,SILENT) ;

 ; Returns a list of patients having the CATASTROPHICALLY DISABLED

 ; Eligibility code as either their PRIMARY or SECONDARY Eligibility.

 K @ARR

 S SILENT=''$G(SILENT,0) ; Suppress screen output.

 N ELIG,DFN,X

 I 'SILENT D

 . W "Creating list of patients having the CATASTROPHICALLY DISABLED",!

 . W "Eligibility Code..."

 S ELIG=""

 F  S ELIG=$O(^DIC(8,"B","CATASTROPHICALLY DISABLED",ELIG)) Q:ELIG=""  D

 . ; "AEL" index ^DPT("AEL",DFN,elig)=""

 . ; Note this inex contains both primary eligibility (#.361) and

 . ;  Patient eligibilities (#361).

 . S DFN=""

 . F X=1:1 S DFN=$O(^DPT("AEL",DFN)) Q:DFN=""  W:X#10000'!SILENT "." I $D(^DPT("AEL",DFN,ELIG)) D ADD(ARR,DFN)

 Q

ADD(ARR,DFN) ; Add Patient to array.

 N NAME

 S NAME=$P(^DPT(DFN,0),"^",1)

 S @ARR@(NAME,DFN)=""

 Q

DGENCDRP  ;ISA/Zoltan - Catastrophic Disability Eligibily Code Report;6/24/99

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

REPORT    ; Print a report of all patients having the CATASTROPHICALLY DISABLED

 +1       ; Eligibility code.

 +2        IF $X

               WRITE !!

 +3        WRITE "This routine will print a report of all patients having the",!

 +4        WRITE "inactivated CATASTROPHIC DISABILITY eligibility code.",!

 +5        NEW PFX,L,DIC,FLDS,BY,DIOBEG,DIOEND

 +6       ; Set up FM required variables.

           DO DT^DICRW

 +7       ; Partial global reference.

           SET PFX="^TMP($J,""DGENCDRP"","

 +8        SET DIOBEG="D MAKELIST^DGENCDRP(""^TMP($J,""""DGENCDRP"""")"",$J'="_$JOB_")"

 +9        SET DIOEND="K ^TMP($J,""DGENCDRP"")"

 +10      ; No SORT prompt.

           SET L=0

 +11      ; Global prefix.

           SET DIC="^DPT("

 +12      ; Fields to print.

           SET FLDS="[DGENCD ELIG CODE]"

 +13      ; Sorted list.

           SET BY(0)=PFX

 +14      ; Number of subscripts in sorted list.

           SET L(0)=2

 +15       DO EN1^DIP

 +16       QUIT 

MAKELIST(ARR,SILENT) ;

 +1       ; Returns a list of patients having the CATASTROPHICALLY DISABLED

 +2       ; Eligibility code as either their PRIMARY or SECONDARY Eligibility.

 +3        KILL @ARR

 +4       ; Suppress screen output.

           SET SILENT=''$GET(SILENT,0)

 +5        NEW ELIG,DFN,X

 +6        IF 'SILENT

               Begin DoDot:1

 +7                WRITE "Creating list of patients having the CATASTROPHICALLY DISABLED",!

 +8                WRITE "Eligibility Code..."

               End DoDot:1

 +9        SET ELIG=""

 +10       FOR 

               SET ELIG=$ORDER(^DIC(8,"B","CATASTROPHICALLY DISABLED",ELIG))

               IF ELIG=""

                   QUIT 

               Begin DoDot:1

 +11      ; "AEL" index ^DPT("AEL",DFN,elig)=""

 +12      ; Note this inex contains both primary eligibility (#.361) and

 +13      ;  Patient eligibilities (#361).

 +14               SET DFN=""

 +15               FOR X=1:1

                       SET DFN=$ORDER(^DPT("AEL",DFN))

                       IF DFN=""

                           QUIT 

                       IF X#10000'!SILENT

                           WRITE "."

                       IF $DATA(^DPT("AEL",DFN,ELIG))

                           DO ADD(ARR,DFN)

               End DoDot:1

 +16       QUIT 

ADD(ARR,DFN) ; Add Patient to array.

 +1        NEW NAME

 +2        SET NAME=$PIECE(^DPT(DFN,0),"^",1)

 +3        SET @ARR@(NAME,DFN)=""

 +4        QUIT