Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGENCD

DGENCD.m

Go to the documentation of this file. 
  1. DGENCD ;ALB/CJM,Zoltan,ISA/KWP,JAN,BRM - Catastrophic Disability Enter/Edit Option;May 24, 1999,Nov 14, 2001 ; 8/4/03 3:01pm
  1.  ;;5.3;Registration;**121,122,232,237,302,387,451,1015**;Aug 13,1993;Build 21
  1.  ;
  1. EN ;
  1.  ;Description: Entry point used for enter/edit catastrophic disability
  1.  ;  information.
  1.  ;
  1.  N DFN,QUIT,ERROR
  1.  S QUIT=0
  1.  S DFN=$$PATIENT
  1.  D:DFN EN^DGENLCD(DFN)
  1.  Q
  1.  ;
  1. EDITCD(DFN) ;
  1.  ;Description: For a given patient, used for enter/edit catastrophic 
  1.  ; disability information.
  1.  ;
  1.  Q:'$G(DFN)
  1.  N QUIT,ERROR
  1.  S QUIT=0
  1.  I $$GET^DGENCDA(DFN,.DGCDIS) D  ; If GET CD succeeds ...
  1.  . ; Set up default values.
  1.  . S DGCDIS("FACDET")=$$INST^DGENU()
  1.  . I 'DGCDIS("DATE") S DGCDIS("DATE")=$G(DT)
  1.  . I 'DGCDIS("REVDTE") S DGCDIS("REVDTE")=DGCDIS("DATE")
  1.  . I DGCDIS("METDET")="" S DGCDIS("METDET")=""
  1.  . ; Keep editing until storage succeeds or user gives up ...
  1.  . F  D  Q:QUIT
  1.  . . ; Quit if the editing process isn't completed.
  1.  . . I '$$EDIT(.DGCDIS) S QUIT=1 Q
  1.  . . ; Quit if storage is successful.
  1.  . . I $$STORE^DGENCDA2(DFN,.DGCDIS,.ERROR) S QUIT=1 Q
  1.  . . ; Quit if the user elects not to try again.
  1.  . . I '$$AGAIN(.ERROR) S QUIT=1
  1.  Q
  1.  ;
  1. AGAIN(ERROR) ;
  1.  ;Description: Asks user whether to try again.
  1.  ;
  1.  N DIR,Y
  1.  W !!,$S(('$L($G(ERROR))):">>> Catastrophic disability information not valid.<<< ",1:">>> "_ERROR_" <<<")
  1.  S DIR(0)="Y",DIR("A")="Try again",DIR("B")="YES"
  1.  D ^DIR
  1.  Q $S(Y=1:1,1:0)
  1.  ;
  1. PATIENT() ;
  1.  ;Description: Asks user to select a patient.
  1.  ;
  1.  N DFN,QUIT
  1.  S (DFN,QUIT)=""
  1.  F  D  Q:(QUIT!DFN)
  1.  . D GETPAT^DGRPTU(,,.DFN)
  1.  . I '(DFN>0) S DFN="",QUIT=1 Q
  1.  . I DFN,'$$VET^DGENPTA(DFN) D
  1.  . . W !!,"Catastrophic disability can only be entered for eligible veterans!"
  1.  . . S DFN=""
  1.  Q DFN
  1.  ;
  1. EDIT(DGCDIS) ;
  1.  ;Description: Allows user to enter values in DGCDIS array
  1.  ; which is passed by reference.
  1.  N SUB,OK,RESPONSE,FLST,EXIT,SUBEXIT,ITEM,FILENUM,FLDNUM,GETOUT,REQ,VAL
  1.  S OK=1
  1.  F VAL="BY^1","DATE^1","REVDTE^1","METDET^1" D  Q:'OK
  1.  . S SUB=$P(VAL,"^",1)
  1.  . S REQ=$P(VAL,"^",2)
  1.  . S FILENUM=$$FILE^DGENCDU(SUB)
  1.  . S FLDNUM=$$FLD^DGENCDU(SUB)
  1.  . I '$$PROMPT^DGENU(FILENUM,FLDNUM,DGCDIS(SUB),.RESPONSE,REQ) S OK=0
  1.  . E  D
  1.  . . I $P(VAL,"^",1)="BY" S RESPONSE=$$UPPER^DGUTL(RESPONSE)
  1.  . . S DGCDIS(SUB)=RESPONSE
  1.  I 'OK Q OK
  1.  S GETOUT=0
  1.  F FLST="DIAG","PROC;EXT","COND;SCORE;PERM" D  Q:'OK!GETOUT
  1.  . N LOOKUP
  1.  . S ITEM="",SUB=$P(FLST,";")
  1.  . F  S ITEM=$O(DGCDIS(SUB,ITEM)) Q:ITEM=""  S LOOKUP(DGCDIS(SUB,ITEM))=ITEM
  1.  . S EXIT=0
  1.  . S ITEM=1
  1.  . W !
  1.  . F  D  Q:EXIT
  1.  . . N PC
  1.  . . S SUB=$P(FLST,";")
  1.  . . S FILENUM=$$FILE^DGENCDU(SUB)
  1.  . . S FLDNUM=$$FLD^DGENCDU(SUB)
  1.  . . W !
  1.  . . I '$$PROMPT^DGENU(FILENUM,FLDNUM,$G(DGCDIS(SUB,ITEM)),.RESPONSE,0) S (EXIT,GETOUT)=1 Q
  1.  . . I RESPONSE="" D  Q
  1.  . . . F PC=1:1:$L(FLST,";") K DGCDIS($P(FLST,";",PC),ITEM)
  1.  . . . S ITEM=$O(DGCDIS(SUB,ITEM))
  1.  . . . I ITEM="" S EXIT=1
  1.  . . I $G(LOOKUP(RESPONSE)) S ITEM=LOOKUP(RESPONSE)
  1.  . . E  S ITEM=$O(DGCDIS(SUB,""),-1)+1,LOOKUP(RESPONSE)=ITEM
  1.  . . S DGCDIS(SUB,ITEM)=RESPONSE
  1.  . . S SUBEXIT=0
  1.  . . F PC=2:1:$L(FLST,";") D  Q:SUBEXIT
  1.  . . . S SUB=$P(FLST,";",PC)
  1.  . . . S FLDNUM=$$FLD^DGENCDU(SUB)
  1.  . . . I '$$PROMPT^DGENU(FILENUM,FLDNUM,$G(DGCDIS(SUB,ITEM)),.RESPONSE,1) S SUBEXIT=1 Q
  1.  . . . I RESPONSE="" S (EXIT,SUBEXIT)=1 Q
  1.  . . . I SUB="EXT" D  Q
  1.  . . . . I '$D(DGCDIS(SUB,ITEM,1)) S DGCDIS(SUB,ITEM,1)=RESPONSE
  1.  . . . . E  S:DGCDIS(SUB,ITEM,1)'=RESPONSE DGCDIS(SUB,ITEM,2)=RESPONSE
  1.  . . . I SUB="SCORE",'$$VALID^DGENA5(DGCDIS("COND",ITEM),RESPONSE) D  Q
  1.  . . . . W !,"ERROR: This is not a valid test score.",!
  1.  . . . . Q:$G(DGCDIS("SCORE",ITEM))
  1.  . . . . K LOOKUP(DGCDIS("COND",ITEM))
  1.  . . . . F PC=1:1:$L(FLST,";") K DGCDIS($P(FLST,";",PC),ITEM)
  1.  . . . . S PC=$L(FLST,";")
  1.  . . . I SUB="SCORE",'$$RANGEMET^DGENA5(DGCDIS("COND",ITEM),RESPONSE,1) D  Q
  1.  . . . . S PC=$L(FLST,";")
  1.  . . . . S DGCDIS("SCORE",ITEM)=RESPONSE
  1.  . . . . S DGCDIS("PERM",ITEM)=""
  1.  . . . S DGCDIS(SUB,ITEM)=RESPONSE
  1.  . . S ITEM=ITEM+'SUBEXIT
  1.  S DGCDIS("VCD")="Y"
  1.  S DGCDIS("VCD")=$S($$ISCD^DGENCDA1(.DGCDIS):"Y",1:"N")
  1.  S OK=$$PROMPT^DGENU(2,.39,DGCDIS("VCD"),.RESPONSE,0) ; Is Veteran CD?
  1.  I OK S DGCDIS("VCD")=RESPONSE
  1.  Q OK