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 Dec 13, 2024@02:42:26 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"))
