DGENCDRP ;ISA/Zoltan - Catastrophic Disability Eligibily Code Report;6/24/99
;;5.3;Registration;**232**;Aug 13,1993
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENCDRP 1635 printed Dec 13, 2024@02:42:30 Page 2
DGENCDRP ;ISA/Zoltan - Catastrophic Disability Eligibily Code Report;6/24/99
+1 ;;5.3;Registration;**232**;Aug 13,1993
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
