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,DJS - 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,894**;Aug 13,1993;Build 48
  1. ;
  1. ; DG*5.3*894 - Enhance Catastrophic Disability to use Descriptors rather than Diagnoses/Procedures/Conditions.
  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. S DIR(0)="EA",DIR("A")="Press return to continue..." D ^DIR
  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,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 FLST="DESCR" D
  1. . N LOOKUP
  1. . S ITEM="",SUB=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. . . 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),X="^" S RESPONSE=X
  1. . . I X="@",$G(DGCDIS(SUB,ITEM)) K DGCDIS(SUB,ITEM) S EXIT=0,OK=1 D QEXIT Q
  1. . . I RESPONSE="" N HIT S HIT=1 D I HIT W !!,"Must enter at least one CD Descriptor or ""^"" to exit" S EXIT=0,OK=1 D QEXIT Q
  1. . . . N I F I=ITEM:-1:1 I $G(DGCDIS(SUB,I))'="" S HIT=0 Q
  1. . . I SUB="DESCR",RESPONSE'="^",RESPONSE'="",$P(^DGEN(27.17,RESPONSE,0),U,4)=5,'$D(LOOKUP(RESPONSE)) I '$$CKDOAD S RESPONSE="",EXIT=0,OK=1 D QEXIT Q
  1. . . I SUB="DESCR",$D(DGCDIS("DESCR")),$G(DGCDIS("DESCR",ITEM))'=RESPONSE N EXIT1,ENTRY S EXIT1=0 D I EXIT1 Q
  1. . . . S ENTRY=0 F S ENTRY=$O(DGCDIS("DESCR",ENTRY)) Q:ENTRY="" D Q:EXIT1
  1. . . . . I DGCDIS("DESCR",ENTRY)=RESPONSE D
  1. . . . . . W !!,"CD Descriptor previously selected, cannot select same CD Descriptor twice"
  1. . . . . . S RESPONSE="",EXIT=0,OK=1,EXIT1=1
  1. . . . I EXIT1 D QEXIT
  1. . . I RESPONSE="^"!(RESPONSE=""&$D(DGCDIS(SUB))) N ITEM,CNT D D:'CNT DELETE^DGENCDA1(DFN) Q
  1. . . . S EXIT=1,OK=0
  1. . . . S (ITEM,CNT)=""
  1. . . . F S ITEM=$O(DGCDIS(SUB,ITEM)) Q:ITEM="" D
  1. . . . . I DGCDIS(SUB,ITEM)'=""&(DGCDIS(SUB,ITEM)'="^") S CNT=1 Q
  1. . . . . I DGCDIS(SUB,ITEM)="" K DGCDIS(SUB,ITEM) Q
  1. . . . . I DGCDIS(SUB,ITEM)="^" K DGCDIS(SUB,ITEM)
  1. . . I RESPONSE'="",$D(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. . . S ITEM=ITEM+'SUBEXIT
  1. I $D(DGCDIS("DESCR")) S DGCDIS("VCD")="Y",OK=1 W !!,"VETERAN IS CATASTROPHICALLY DISABLED",!
  1. E I '$D(DGCDIS("DESCR")) D
  1. . S DGCDIS("VCD")="N",OK=1
  1. . N I F I="BY","DATE","DTFACIRV","FACDET","METDET","REVDTE","VETREQDT" S DGCDIS(I)=""
  1. . W !!,"VETERAN IS NOT CATASTROPHICALLY DISABLED",!
  1. Q OK
  1. ;
  1. CKDOAD() ; Ask qualifying question if descriptor is AMPUTATION, DISARTICULATION OR DETACHMENT
  1. N CK
  1. F D Q:CK'=""
  1. . W !,"Has the Amputation, Disarticulation or Detachment occurred on more "
  1. . W !,"than one limb? "
  1. . R CK:120
  1. . I CK["?" W !!,"Enter 'YES' or 'NO'.",! S CK="" Q
  1. . S CK=$S($E(CK)="Y":1,$E(CK)="y":1,$E(CK)="N":0,$E(CK)="n":0,1:"")
  1. I CK=0 W !!,"The Descriptor does not meet the criteria to be added."
  1. Q CK
  1. ;
  1. QEXIT() ; sets an empty DGCDIS entry before exiting
  1. S ITEM=$O(DGCDIS(SUB,ITEM))
  1. I ITEM="" S ITEM=$O(DGCDIS(SUB,""),-1)+1,DGCDIS(SUB,ITEM)=""
  1. Q
  1. ;
  1. DBPROC() ; replaces input transform for CD Procedure
  1. Q ($P(^DGEN(27.17,+Y,0),U,3)["ICPT")!($P(^DGEN(27.17,+Y,0),U,9)=$$ICDVER^DGENA5("P"))