source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGENCD.m@ 724

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.0 KB
Line 
1DGENCD ;ALB/CJM,Zoltan,ISA/KWP,JAN,BRM - Catastrophic Disability Enter/Edit Option;May 24, 1999,Nov 14, 2001 ; 8/4/03 3:01pm
2 ;;5.3;Registration;**121,122,232,237,302,387,451**;Aug 13,1993
3 ;
4EN ;
5 ;Description: Entry point used for enter/edit catastrophic disability
6 ; information.
7 ;
8 N DFN,QUIT,ERROR
9 S QUIT=0
10 S DFN=$$PATIENT
11 D:DFN EN^DGENLCD(DFN)
12 Q
13 ;
14EDITCD(DFN) ;
15 ;Description: For a given patient, used for enter/edit catastrophic
16 ; disability information.
17 ;
18 Q:'$G(DFN)
19 N QUIT,ERROR
20 S QUIT=0
21 I $$GET^DGENCDA(DFN,.DGCDIS) D ; If GET CD succeeds ...
22 . ; Set up default values.
23 . S DGCDIS("FACDET")=$$INST^DGENU()
24 . I 'DGCDIS("DATE") S DGCDIS("DATE")=$G(DT)
25 . I 'DGCDIS("REVDTE") S DGCDIS("REVDTE")=DGCDIS("DATE")
26 . I DGCDIS("METDET")="" S DGCDIS("METDET")=""
27 . ; Keep editing until storage succeeds or user gives up ...
28 . F D Q:QUIT
29 . . ; Quit if the editing process isn't completed.
30 . . I '$$EDIT(.DGCDIS) S QUIT=1 Q
31 . . ; Quit if storage is successful.
32 . . I $$STORE^DGENCDA2(DFN,.DGCDIS,.ERROR) S QUIT=1 Q
33 . . ; Quit if the user elects not to try again.
34 . . I '$$AGAIN(.ERROR) S QUIT=1
35 Q
36 ;
37AGAIN(ERROR) ;
38 ;Description: Asks user whether to try again.
39 ;
40 N DIR,Y
41 W !!,$S(('$L($G(ERROR))):">>> Catastrophic disability information not valid.<<< ",1:">>> "_ERROR_" <<<")
42 S DIR(0)="Y",DIR("A")="Try again",DIR("B")="YES"
43 D ^DIR
44 Q $S(Y=1:1,1:0)
45 ;
46PATIENT() ;
47 ;Description: Asks user to select a patient.
48 ;
49 N DFN,QUIT
50 S (DFN,QUIT)=""
51 F D Q:(QUIT!DFN)
52 . D GETPAT^DGRPTU(,,.DFN)
53 . I '(DFN>0) S DFN="",QUIT=1 Q
54 . I DFN,'$$VET^DGENPTA(DFN) D
55 . . W !!,"Catastrophic disability can only be entered for eligible veterans!"
56 . . S DFN=""
57 Q DFN
58 ;
59EDIT(DGCDIS) ;
60 ;Description: Allows user to enter values in DGCDIS array
61 ; which is passed by reference.
62 N SUB,OK,RESPONSE,FLST,EXIT,SUBEXIT,ITEM,FILENUM,FLDNUM,GETOUT,REQ,VAL
63 S OK=1
64 F VAL="BY^1","DATE^1","REVDTE^1","METDET^1" D Q:'OK
65 . S SUB=$P(VAL,"^",1)
66 . S REQ=$P(VAL,"^",2)
67 . S FILENUM=$$FILE^DGENCDU(SUB)
68 . S FLDNUM=$$FLD^DGENCDU(SUB)
69 . I '$$PROMPT^DGENU(FILENUM,FLDNUM,DGCDIS(SUB),.RESPONSE,REQ) S OK=0
70 . E D
71 . . I $P(VAL,"^",1)="BY" S RESPONSE=$$UPPER^DGUTL(RESPONSE)
72 . . S DGCDIS(SUB)=RESPONSE
73 I 'OK Q OK
74 S GETOUT=0
75 F FLST="DIAG","PROC;EXT","COND;SCORE;PERM" D Q:'OK!GETOUT
76 . N LOOKUP
77 . S ITEM="",SUB=$P(FLST,";")
78 . F S ITEM=$O(DGCDIS(SUB,ITEM)) Q:ITEM="" S LOOKUP(DGCDIS(SUB,ITEM))=ITEM
79 . S EXIT=0
80 . S ITEM=1
81 . W !
82 . F D Q:EXIT
83 . . N PC
84 . . S SUB=$P(FLST,";")
85 . . S FILENUM=$$FILE^DGENCDU(SUB)
86 . . S FLDNUM=$$FLD^DGENCDU(SUB)
87 . . W !
88 . . I '$$PROMPT^DGENU(FILENUM,FLDNUM,$G(DGCDIS(SUB,ITEM)),.RESPONSE,0) S (EXIT,GETOUT)=1 Q
89 . . I RESPONSE="" D Q
90 . . . F PC=1:1:$L(FLST,";") K DGCDIS($P(FLST,";",PC),ITEM)
91 . . . S ITEM=$O(DGCDIS(SUB,ITEM))
92 . . . I ITEM="" S EXIT=1
93 . . I $G(LOOKUP(RESPONSE)) S ITEM=LOOKUP(RESPONSE)
94 . . E S ITEM=$O(DGCDIS(SUB,""),-1)+1,LOOKUP(RESPONSE)=ITEM
95 . . S DGCDIS(SUB,ITEM)=RESPONSE
96 . . S SUBEXIT=0
97 . . F PC=2:1:$L(FLST,";") D Q:SUBEXIT
98 . . . S SUB=$P(FLST,";",PC)
99 . . . S FLDNUM=$$FLD^DGENCDU(SUB)
100 . . . I '$$PROMPT^DGENU(FILENUM,FLDNUM,$G(DGCDIS(SUB,ITEM)),.RESPONSE,1) S SUBEXIT=1 Q
101 . . . I RESPONSE="" S (EXIT,SUBEXIT)=1 Q
102 . . . I SUB="EXT" D Q
103 . . . . I '$D(DGCDIS(SUB,ITEM,1)) S DGCDIS(SUB,ITEM,1)=RESPONSE
104 . . . . E S:DGCDIS(SUB,ITEM,1)'=RESPONSE DGCDIS(SUB,ITEM,2)=RESPONSE
105 . . . I SUB="SCORE",'$$VALID^DGENA5(DGCDIS("COND",ITEM),RESPONSE) D Q
106 . . . . W !,"ERROR: This is not a valid test score.",!
107 . . . . Q:$G(DGCDIS("SCORE",ITEM))
108 . . . . K LOOKUP(DGCDIS("COND",ITEM))
109 . . . . F PC=1:1:$L(FLST,";") K DGCDIS($P(FLST,";",PC),ITEM)
110 . . . . S PC=$L(FLST,";")
111 . . . I SUB="SCORE",'$$RANGEMET^DGENA5(DGCDIS("COND",ITEM),RESPONSE,1) D Q
112 . . . . S PC=$L(FLST,";")
113 . . . . S DGCDIS("SCORE",ITEM)=RESPONSE
114 . . . . S DGCDIS("PERM",ITEM)=""
115 . . . S DGCDIS(SUB,ITEM)=RESPONSE
116 . . S ITEM=ITEM+'SUBEXIT
117 S DGCDIS("VCD")="Y"
118 S DGCDIS("VCD")=$S($$ISCD^DGENCDA1(.DGCDIS):"Y",1:"N")
119 S OK=$$PROMPT^DGENU(2,.39,DGCDIS("VCD"),.RESPONSE,0) ; Is Veteran CD?
120 I OK S DGCDIS("VCD")=RESPONSE
121 Q OK
Note: See TracBrowser for help on using the repository browser.