- 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
- ;;5.3;Registration;**121,122,232,237,302,387,451,894**;Aug 13,1993;Build 48
- ;
- ; DG*5.3*894 - Enhance Catastrophic Disability to use Descriptors rather than Diagnoses/Procedures/Conditions.
- ;
- EN ;
- ;Description: Entry point used for enter/edit catastrophic disability
- ; information.
- ;
- N DFN,QUIT,ERROR
- S QUIT=0
- S DFN=$$PATIENT
- D:DFN EN^DGENLCD(DFN)
- Q
- ;
- EDITCD(DFN) ;
- ;Description: For a given patient, used for enter/edit catastrophic
- ; disability information.
- ;
- Q:'$G(DFN)
- N QUIT,ERROR
- S QUIT=0
- I $$GET^DGENCDA(DFN,.DGCDIS) D ; If GET CD succeeds ...
- . ; Set up default values.
- . S DGCDIS("FACDET")=$$INST^DGENU()
- . I 'DGCDIS("DATE") S DGCDIS("DATE")=$G(DT)
- . I 'DGCDIS("REVDTE") S DGCDIS("REVDTE")=DGCDIS("DATE")
- . I DGCDIS("METDET")="" S DGCDIS("METDET")=""
- . ; Keep editing until storage succeeds or user gives up ...
- . F D Q:QUIT
- . . ; Quit if the editing process isn't completed.
- . . I '$$EDIT(.DGCDIS) S QUIT=1 Q
- . . ; Quit if storage is successful.
- . . I $$STORE^DGENCDA2(DFN,.DGCDIS,.ERROR) S QUIT=1 Q
- . . ; Quit if the user elects not to try again.
- . . I '$$AGAIN(.ERROR) S QUIT=1
- S DIR(0)="EA",DIR("A")="Press return to continue..." D ^DIR
- Q
- ;
- AGAIN(ERROR) ;
- ;Description: Asks user whether to try again.
- ;
- N DIR,Y
- W !!,$S(('$L($G(ERROR))):">>> Catastrophic disability information not valid.<<< ",1:">>> "_ERROR_" <<<")
- S DIR(0)="Y",DIR("A")="Try again",DIR("B")="YES"
- D ^DIR
- Q $S(Y=1:1,1:0)
- ;
- PATIENT() ;
- ;Description: Asks user to select a patient.
- ;
- N DFN,QUIT
- S (DFN,QUIT)=""
- F D Q:(QUIT!DFN)
- . D GETPAT^DGRPTU(,,.DFN)
- . I '(DFN>0) S DFN="",QUIT=1 Q
- . I DFN,'$$VET^DGENPTA(DFN) D
- . . W !!,"Catastrophic disability can only be entered for eligible veterans!"
- . . S DFN=""
- Q DFN
- ;
- EDIT(DGCDIS) ;
- ;Description: Allows user to enter values in DGCDIS array
- ; which is passed by reference.
- N SUB,OK,RESPONSE,FLST,EXIT,SUBEXIT,ITEM,FILENUM,FLDNUM,REQ,VAL
- S OK=1
- F VAL="BY^1","DATE^1","REVDTE^1","METDET^1" D Q:'OK
- . S SUB=$P(VAL,"^",1)
- . S REQ=$P(VAL,"^",2)
- . S FILENUM=$$FILE^DGENCDU(SUB)
- . S FLDNUM=$$FLD^DGENCDU(SUB)
- . I '$$PROMPT^DGENU(FILENUM,FLDNUM,DGCDIS(SUB),.RESPONSE,REQ) S OK=0
- . E D
- . . I $P(VAL,"^",1)="BY" S RESPONSE=$$UPPER^DGUTL(RESPONSE)
- . . S DGCDIS(SUB)=RESPONSE
- I 'OK Q OK
- S FLST="DESCR" D
- . N LOOKUP
- . S ITEM="",SUB=FLST
- . F S ITEM=$O(DGCDIS(SUB,ITEM)) Q:ITEM="" S LOOKUP(DGCDIS(SUB,ITEM))=ITEM
- . S EXIT=0
- . S ITEM=1
- . W !
- . F D Q:EXIT
- . . S FILENUM=$$FILE^DGENCDU(SUB)
- . . S FLDNUM=$$FLD^DGENCDU(SUB)
- . . W !
- . . I '$$PROMPT^DGENU(FILENUM,FLDNUM,$G(DGCDIS(SUB,ITEM)),.RESPONSE,0),X="^" S RESPONSE=X
- . . I X="@",$G(DGCDIS(SUB,ITEM)) K DGCDIS(SUB,ITEM) S EXIT=0,OK=1 D QEXIT Q
- . . 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
- . . . N I F I=ITEM:-1:1 I $G(DGCDIS(SUB,I))'="" S HIT=0 Q
- . . 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
- . . I SUB="DESCR",$D(DGCDIS("DESCR")),$G(DGCDIS("DESCR",ITEM))'=RESPONSE N EXIT1,ENTRY S EXIT1=0 D I EXIT1 Q
- . . . S ENTRY=0 F S ENTRY=$O(DGCDIS("DESCR",ENTRY)) Q:ENTRY="" D Q:EXIT1
- . . . . I DGCDIS("DESCR",ENTRY)=RESPONSE D
- . . . . . W !!,"CD Descriptor previously selected, cannot select same CD Descriptor twice"
- . . . . . S RESPONSE="",EXIT=0,OK=1,EXIT1=1
- . . . I EXIT1 D QEXIT
- . . I RESPONSE="^"!(RESPONSE=""&$D(DGCDIS(SUB))) N ITEM,CNT D D:'CNT DELETE^DGENCDA1(DFN) Q
- . . . S EXIT=1,OK=0
- . . . S (ITEM,CNT)=""
- . . . F S ITEM=$O(DGCDIS(SUB,ITEM)) Q:ITEM="" D
- . . . . I DGCDIS(SUB,ITEM)'=""&(DGCDIS(SUB,ITEM)'="^") S CNT=1 Q
- . . . . I DGCDIS(SUB,ITEM)="" K DGCDIS(SUB,ITEM) Q
- . . . . I DGCDIS(SUB,ITEM)="^" K DGCDIS(SUB,ITEM)
- . . I RESPONSE'="",$D(LOOKUP(RESPONSE)) S ITEM=LOOKUP(RESPONSE)
- . . E S ITEM=$O(DGCDIS(SUB,""),-1)+1,LOOKUP(RESPONSE)=ITEM
- . . S DGCDIS(SUB,ITEM)=RESPONSE
- . . S SUBEXIT=0
- . . S ITEM=ITEM+'SUBEXIT
- I $D(DGCDIS("DESCR")) S DGCDIS("VCD")="Y",OK=1 W !!,"VETERAN IS CATASTROPHICALLY DISABLED",!
- E I '$D(DGCDIS("DESCR")) D
- . S DGCDIS("VCD")="N",OK=1
- . N I F I="BY","DATE","DTFACIRV","FACDET","METDET","REVDTE","VETREQDT" S DGCDIS(I)=""
- . W !!,"VETERAN IS NOT CATASTROPHICALLY DISABLED",!
- Q OK
- ;
- CKDOAD() ; Ask qualifying question if descriptor is AMPUTATION, DISARTICULATION OR DETACHMENT
- N CK
- F D Q:CK'=""
- . W !,"Has the Amputation, Disarticulation or Detachment occurred on more "
- . W !,"than one limb? "
- . R CK:120
- . I CK["?" W !!,"Enter 'YES' or 'NO'.",! S CK="" Q
- . S CK=$S($E(CK)="Y":1,$E(CK)="y":1,$E(CK)="N":0,$E(CK)="n":0,1:"")
- I CK=0 W !!,"The Descriptor does not meet the criteria to be added."
- Q CK
- ;
- QEXIT() ; sets an empty DGCDIS entry before exiting
- S ITEM=$O(DGCDIS(SUB,ITEM))
- I ITEM="" S ITEM=$O(DGCDIS(SUB,""),-1)+1,DGCDIS(SUB,ITEM)=""
- Q
- ;
- DBPROC() ; replaces input transform for CD Procedure
- Q ($P(^DGEN(27.17,+Y,0),U,3)["ICPT")!($P(^DGEN(27.17,+Y,0),U,9)=$$ICDVER^DGENA5("P"))
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENCD 5276 printed Feb 19, 2025@00:08:29 Page 2
- 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
- +2 ;
- +3 ; DG*5.3*894 - Enhance Catastrophic Disability to use Descriptors rather than Diagnoses/Procedures/Conditions.
- +4 ;
- EN ;
- +1 ;Description: Entry point used for enter/edit catastrophic disability
- +2 ; information.
- +3 ;
- +4 NEW DFN,QUIT,ERROR
- +5 SET QUIT=0
- +6 SET DFN=$$PATIENT
- +7 if DFN
- DO EN^DGENLCD(DFN)
- +8 QUIT
- +9 ;
- EDITCD(DFN) ;
- +1 ;Description: For a given patient, used for enter/edit catastrophic
- +2 ; disability information.
- +3 ;
- +4 if '$GET(DFN)
- QUIT
- +5 NEW QUIT,ERROR
- +6 SET QUIT=0
- +7 ; If GET CD succeeds ...
- IF $$GET^DGENCDA(DFN,.DGCDIS)
- Begin DoDot:1
- +8 ; Set up default values.
- +9 SET DGCDIS("FACDET")=$$INST^DGENU()
- +10 IF 'DGCDIS("DATE")
- SET DGCDIS("DATE")=$GET(DT)
- +11 IF 'DGCDIS("REVDTE")
- SET DGCDIS("REVDTE")=DGCDIS("DATE")
- +12 IF DGCDIS("METDET")=""
- SET DGCDIS("METDET")=""
- +13 ; Keep editing until storage succeeds or user gives up ...
- +14 FOR
- Begin DoDot:2
- +15 ; Quit if the editing process isn't completed.
- +16 IF '$$EDIT(.DGCDIS)
- SET QUIT=1
- QUIT
- +17 ; Quit if storage is successful.
- +18 IF $$STORE^DGENCDA2(DFN,.DGCDIS,.ERROR)
- SET QUIT=1
- QUIT
- +19 ; Quit if the user elects not to try again.
- +20 IF '$$AGAIN(.ERROR)
- SET QUIT=1
- End DoDot:2
- if QUIT
- QUIT
- End DoDot:1
- +21 SET DIR(0)="EA"
- SET DIR("A")="Press return to continue..."
- DO ^DIR
- +22 QUIT
- +23 ;
- AGAIN(ERROR) ;
- +1 ;Description: Asks user whether to try again.
- +2 ;
- +3 NEW DIR,Y
- +4 WRITE !!,$SELECT(('$LENGTH($GET(ERROR))):">>> Catastrophic disability information not valid.<<< ",1:">>> "_ERROR_" <<<")
- +5 SET DIR(0)="Y"
- SET DIR("A")="Try again"
- SET DIR("B")="YES"
- +6 DO ^DIR
- +7 QUIT $SELECT(Y=1:1,1:0)
- +8 ;
- PATIENT() ;
- +1 ;Description: Asks user to select a patient.
- +2 ;
- +3 NEW DFN,QUIT
- +4 SET (DFN,QUIT)=""
- +5 FOR
- Begin DoDot:1
- +6 DO GETPAT^DGRPTU(,,.DFN)
- +7 IF '(DFN>0)
- SET DFN=""
- SET QUIT=1
- QUIT
- +8 IF DFN
- IF '$$VET^DGENPTA(DFN)
- Begin DoDot:2
- +9 WRITE !!,"Catastrophic disability can only be entered for eligible veterans!"
- +10 SET DFN=""
- End DoDot:2
- End DoDot:1
- if (QUIT!DFN)
- QUIT
- +11 QUIT DFN
- +12 ;
- EDIT(DGCDIS) ;
- +1 ;Description: Allows user to enter values in DGCDIS array
- +2 ; which is passed by reference.
- +3 NEW SUB,OK,RESPONSE,FLST,EXIT,SUBEXIT,ITEM,FILENUM,FLDNUM,REQ,VAL
- +4 SET OK=1
- +5 FOR VAL="BY^1","DATE^1","REVDTE^1","METDET^1"
- Begin DoDot:1
- +6 SET SUB=$PIECE(VAL,"^",1)
- +7 SET REQ=$PIECE(VAL,"^",2)
- +8 SET FILENUM=$$FILE^DGENCDU(SUB)
- +9 SET FLDNUM=$$FLD^DGENCDU(SUB)
- +10 IF '$$PROMPT^DGENU(FILENUM,FLDNUM,DGCDIS(SUB),.RESPONSE,REQ)
- SET OK=0
- +11 IF '$TEST
- Begin DoDot:2
- +12 IF $PIECE(VAL,"^",1)="BY"
- SET RESPONSE=$$UPPER^DGUTL(RESPONSE)
- +13 SET DGCDIS(SUB)=RESPONSE
- End DoDot:2
- End DoDot:1
- if 'OK
- QUIT
- +14 IF 'OK
- QUIT OK
- +15 SET FLST="DESCR"
- Begin DoDot:1
- +16 NEW LOOKUP
- +17 SET ITEM=""
- SET SUB=FLST
- +18 FOR
- SET ITEM=$ORDER(DGCDIS(SUB,ITEM))
- if ITEM=""
- QUIT
- SET LOOKUP(DGCDIS(SUB,ITEM))=ITEM
- +19 SET EXIT=0
- +20 SET ITEM=1
- +21 WRITE !
- +22 FOR
- Begin DoDot:2
- +23 SET FILENUM=$$FILE^DGENCDU(SUB)
- +24 SET FLDNUM=$$FLD^DGENCDU(SUB)
- +25 WRITE !
- +26 IF '$$PROMPT^DGENU(FILENUM,FLDNUM,$GET(DGCDIS(SUB,ITEM)),.RESPONSE,0)
- IF X="^"
- SET RESPONSE=X
- +27 IF X="@"
- IF $GET(DGCDIS(SUB,ITEM))
- KILL DGCDIS(SUB,ITEM)
- SET EXIT=0
- SET OK=1
- DO QEXIT
- QUIT
- +28 IF RESPONSE=""
- NEW HIT
- SET HIT=1
- Begin DoDot:3
- +29 NEW I
- FOR I=ITEM:-1:1
- IF $GET(DGCDIS(SUB,I))'=""
- SET HIT=0
- QUIT
- End DoDot:3
- IF HIT
- WRITE !!,"Must enter at least one CD Descriptor or ""^"" to exit"
- SET EXIT=0
- SET OK=1
- DO QEXIT
- QUIT
- +30 IF SUB="DESCR"
- IF RESPONSE'="^"
- IF RESPONSE'=""
- IF $PIECE(^DGEN(27.17,RESPONSE,0),U,4)=5
- IF '$DATA(LOOKUP(RESPONSE))
- IF '$$CKDOAD
- SET RESPONSE=""
- SET EXIT=0
- SET OK=1
- DO QEXIT
- QUIT
- +31 IF SUB="DESCR"
- IF $DATA(DGCDIS("DESCR"))
- IF $GET(DGCDIS("DESCR",ITEM))'=RESPONSE
- NEW EXIT1,ENTRY
- SET EXIT1=0
- Begin DoDot:3
- +32 SET ENTRY=0
- FOR
- SET ENTRY=$ORDER(DGCDIS("DESCR",ENTRY))
- if ENTRY=""
- QUIT
- Begin DoDot:4
- +33 IF DGCDIS("DESCR",ENTRY)=RESPONSE
- Begin DoDot:5
- +34 WRITE !!,"CD Descriptor previously selected, cannot select same CD Descriptor twice"
- +35 SET RESPONSE=""
- SET EXIT=0
- SET OK=1
- SET EXIT1=1
- End DoDot:5
- End DoDot:4
- if EXIT1
- QUIT
- +36 IF EXIT1
- DO QEXIT
- End DoDot:3
- IF EXIT1
- QUIT
- +37 IF RESPONSE="^"!(RESPONSE=""&$DATA(DGCDIS(SUB)))
- NEW ITEM,CNT
- Begin DoDot:3
- +38 SET EXIT=1
- SET OK=0
- +39 SET (ITEM,CNT)=""
- +40 FOR
- SET ITEM=$ORDER(DGCDIS(SUB,ITEM))
- if ITEM=""
- QUIT
- Begin DoDot:4
- +41 IF DGCDIS(SUB,ITEM)'=""&(DGCDIS(SUB,ITEM)'="^")
- SET CNT=1
- QUIT
- +42 IF DGCDIS(SUB,ITEM)=""
- KILL DGCDIS(SUB,ITEM)
- QUIT
- +43 IF DGCDIS(SUB,ITEM)="^"
- KILL DGCDIS(SUB,ITEM)
- End DoDot:4
- End DoDot:3
- if 'CNT
- DO DELETE^DGENCDA1(DFN)
- QUIT
- +44 IF RESPONSE'=""
- IF $DATA(LOOKUP(RESPONSE))
- SET ITEM=LOOKUP(RESPONSE)
- +45 IF '$TEST
- SET ITEM=$ORDER(DGCDIS(SUB,""),-1)+1
- SET LOOKUP(RESPONSE)=ITEM
- +46 SET DGCDIS(SUB,ITEM)=RESPONSE
- +47 SET SUBEXIT=0
- +48 SET ITEM=ITEM+'SUBEXIT
- End DoDot:2
- if EXIT
- QUIT
- End DoDot:1
- +49 IF $DATA(DGCDIS("DESCR"))
- SET DGCDIS("VCD")="Y"
- SET OK=1
- WRITE !!,"VETERAN IS CATASTROPHICALLY DISABLED",!
- +50 IF '$TEST
- IF '$DATA(DGCDIS("DESCR"))
- Begin DoDot:1
- +51 SET DGCDIS("VCD")="N"
- SET OK=1
- +52 NEW I
- FOR I="BY","DATE","DTFACIRV","FACDET","METDET","REVDTE","VETREQDT"
- SET DGCDIS(I)=""
- +53 WRITE !!,"VETERAN IS NOT CATASTROPHICALLY DISABLED",!
- End DoDot:1
- +54 QUIT OK
- +55 ;
- CKDOAD() ; Ask qualifying question if descriptor is AMPUTATION, DISARTICULATION OR DETACHMENT
- +1 NEW CK
- +2 FOR
- Begin DoDot:1
- +3 WRITE !,"Has the Amputation, Disarticulation or Detachment occurred on more "
- +4 WRITE !,"than one limb? "
- +5 READ CK:120
- +6 IF CK["?"
- WRITE !!,"Enter 'YES' or 'NO'.",!
- SET CK=""
- QUIT
- +7 SET CK=$SELECT($EXTRACT(CK)="Y":1,$EXTRACT(CK)="y":1,$EXTRACT(CK)="N":0,$EXTRACT(CK)="n":0,1:"")
- End DoDot:1
- if CK'=""
- QUIT
- +8 IF CK=0
- WRITE !!,"The Descriptor does not meet the criteria to be added."
- +9 QUIT CK
- +10 ;
- QEXIT() ; sets an empty DGCDIS entry before exiting
- +1 SET ITEM=$ORDER(DGCDIS(SUB,ITEM))
- +2 IF ITEM=""
- SET ITEM=$ORDER(DGCDIS(SUB,""),-1)+1
- SET DGCDIS(SUB,ITEM)=""
- +3 QUIT
- +4 ;
- DBPROC() ; replaces input transform for CD Procedure
- +1 QUIT ($PIECE(^DGEN(27.17,+Y,0),U,3)["ICPT")!($PIECE(^DGEN(27.17,+Y,0),U,9)=$$ICDVER^DGENA5("P"))