| 1 | DGENCDRP ;ISA/Zoltan - Catastrophic Disability Eligibily Code Report;6/24/99
|
|---|
| 2 | ;;5.3;Registration;**232**;Aug 13,1993
|
|---|
| 3 | REPORT ; Print a report of all patients having the CATASTROPHICALLY DISABLED
|
|---|
| 4 | ; Eligibility code.
|
|---|
| 5 | W:$X !!
|
|---|
| 6 | W "This routine will print a report of all patients having the",!
|
|---|
| 7 | W "inactivated CATASTROPHIC DISABILITY eligibility code.",!
|
|---|
| 8 | N PFX,L,DIC,FLDS,BY,DIOBEG,DIOEND
|
|---|
| 9 | D DT^DICRW ; Set up FM required variables.
|
|---|
| 10 | S PFX="^TMP($J,""DGENCDRP""," ; Partial global reference.
|
|---|
| 11 | S DIOBEG="D MAKELIST^DGENCDRP(""^TMP($J,""""DGENCDRP"""")"",$J'="_$J_")"
|
|---|
| 12 | S DIOEND="K ^TMP($J,""DGENCDRP"")"
|
|---|
| 13 | S L=0 ; No SORT prompt.
|
|---|
| 14 | S DIC="^DPT(" ; Global prefix.
|
|---|
| 15 | S FLDS="[DGENCD ELIG CODE]" ; Fields to print.
|
|---|
| 16 | S BY(0)=PFX ; Sorted list.
|
|---|
| 17 | S L(0)=2 ; Number of subscripts in sorted list.
|
|---|
| 18 | D EN1^DIP
|
|---|
| 19 | Q
|
|---|
| 20 | MAKELIST(ARR,SILENT) ;
|
|---|
| 21 | ; Returns a list of patients having the CATASTROPHICALLY DISABLED
|
|---|
| 22 | ; Eligibility code as either their PRIMARY or SECONDARY Eligibility.
|
|---|
| 23 | K @ARR
|
|---|
| 24 | S SILENT=''$G(SILENT,0) ; Suppress screen output.
|
|---|
| 25 | N ELIG,DFN,X
|
|---|
| 26 | I 'SILENT D
|
|---|
| 27 | . W "Creating list of patients having the CATASTROPHICALLY DISABLED",!
|
|---|
| 28 | . W "Eligibility Code..."
|
|---|
| 29 | S ELIG=""
|
|---|
| 30 | F S ELIG=$O(^DIC(8,"B","CATASTROPHICALLY DISABLED",ELIG)) Q:ELIG="" D
|
|---|
| 31 | . ; "AEL" index ^DPT("AEL",DFN,elig)=""
|
|---|
| 32 | . ; Note this inex contains both primary eligibility (#.361) and
|
|---|
| 33 | . ; Patient eligibilities (#361).
|
|---|
| 34 | . S DFN=""
|
|---|
| 35 | . 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)
|
|---|
| 36 | Q
|
|---|
| 37 | ADD(ARR,DFN) ; Add Patient to array.
|
|---|
| 38 | N NAME
|
|---|
| 39 | S NAME=$P(^DPT(DFN,0),"^",1)
|
|---|
| 40 | S @ARR@(NAME,DFN)=""
|
|---|
| 41 | Q
|
|---|
