DGENCDA1 ;ALB/CJM,RMM Zoltan,JAN,PHH,BRM,CKN,DJS - Catastrophic Disabilty API - File Data;Sep 16, 2002 ; 9/22/05 5:25pm
;;5.3;Registration;**121,147,232,302,356,387,475,451,653,894**;Aug 13,1993;Build 48
;
; DG*5.3*894 - Enhance Catastrophic Disability to use Descriptors rather than Diagnoses/Procedures/Conditions.
;
LOCK(DFN) ;
;Description: Locks the catastrophic disability record for a patient
;Input:
; DFN - Patient IEN
;Output:
; Function Value - returns 1 if the patient is catastrophic disability
; record can be locked, otherwise 0
I $G(DFN) L +^DPT(DFN,.39):2
Q $T
;
UNLOCK(DFN) ;
;Description: Unlocks the catastrophic disability record for a patient
;Input:
; DFN - Patient IEN
;Output:
; None
I $G(DFN) L -^DPT(DFN,.39)
Q
;
CHECK(DGCDIS,ERROR) ;
;Description: Validity checks on the catastrophic disability contained
; in the DGCDIS array
;Input:
; DGCDIS - the catastrophic disability array, passed by reference
;Output:
; Function Value - returns 1 if validation checks passed, 0 otherwise
; ERROR - if validation fails an error mssg is returned, pass by
; reference
N VALID,RESULT,EXTERNAL,ITEM,EIEN,EXIT,OK,ISCD,POP,FLD
S ERROR=""
Q:DGCDIS("VCD")="@" 1 ;this is a deletion
Q:DGCDIS("VCD")="N" 1 ;NO value for VCD
D ;drops out of block if invalid condition found
. S VALID=0 ; Usually invalid if it exits early.
. ; CD Flag must have a value if any other CD field is populated
. S POP=0
. I DGCDIS("VCD")="" D Q:POP
. . F FLD="BY","DATE","FACDET","REVDTE","METDET" D Q:POP
. . . I $G(DGCDIS(FLD))]"" S POP=1
. . I POP S ERROR="'VETERAN CATASTROPHICALLY DISABLED?' FIELD MUST HAVE A RESPONSE" Q
. ; Decided by.
. I DGCDIS("VCD")'="",$G(DGCDIS("BY"))="" S ERROR="CATASTROPHIC DISABILITY 'DECIDED BY' REQUIRED" Q
. I $G(DGCDIS("BY"))'="",($L(DGCDIS("BY"))<3)!($L(DGCDIS("BY"))>35) S ERROR="CATASTROPHIC DISABILITY 'DECIDED BY' NOT VALID" Q
. I $$UPPER^DGUTL($G(DGCDIS("BY")))="HINQ" S ERROR="CATASTROPHIC DISABILITY 'DECIDED BY' CAN NOT BE 'HINQ'" Q
. ; Date of Decision
. S OK=1,EXTERNAL=""
. I DGCDIS("VCD")'="",$G(DGCDIS("DATE"))="" S ERROR="'DATE OF CATASTOPHIC DISABILITY DECISION' REQUIRED" Q
. I $G(DGCDIS("DATE"))'="" D
. . I 'DGCDIS("DATE") S OK=0 Q
. . S EXTERNAL=$$EXTERNAL^DILFD(2,.392,"",DGCDIS("DATE"))
. . I EXTERNAL="" S OK=0
. . D CHK^DIE(2,.392,,EXTERNAL,.RESULT)
. . I RESULT="^" S OK=0
. I 'OK S ERROR="'DATE OF CATASTOPHIC DISABILITY DECISION' NOT VALID" Q
. ; Facility Making Determination.
. I DGCDIS("VCD")'=""!(DGCDIS("FACDET")'=""),$$EXTERNAL^DILFD(2,.393,"",$G(DGCDIS("FACDET")))="" S ERROR="'FACILITY MAKING CATASTROPHIC DISABILITY DETERMINATION' NOT VALID" Q
. ; Review Date
. I DGCDIS("VCD")'="",$G(DGCDIS("REVDTE"))="" S ERROR="'CATASTROPHIC DISABILITY REVIEW DATE' REQUIRED" Q
. I DGCDIS("REVDTE")'="" D Q:ERROR'=""
. . S EXTERNAL=$$EXTERNAL^DILFD(2,.394,"",DGCDIS("REVDTE"))
. . I EXTERNAL="" S ERROR="'CATASTROPHIC DISABILITY REVIEW DATE' NOT VALID" Q
. . D CHK^DIE(2,.394,,EXTERNAL,.RESULT)
. . I RESULT="^" S ERROR="'CATASTROPHIC DISABILTY REVIEW DATE' INVALID" Q
. . I $G(DGCDIS("DATE")),DGCDIS("REVDTE")>DGCDIS("DATE") S ERROR="'CD REVIEW DATE' GREATER THAN 'CD DATE OF DETERMINATION'." Q
. ; Method of Determination
. I $G(DGCDIS("METDET"))="",DGCDIS("VCD")'="" S ERROR="'METHOD OF DETERMINATION' IS A REQUIRED VALUE." Q
. I "..2.3."'[("."_$G(DGCDIS("METDET"))_".") S ERROR="'METHOD OF DETERMINATION' NOT VALID" Q
. S ITEM="",EXIT=0
. ; Descriptor
. F S ITEM=$O(DGCDIS("DESCR",ITEM)) Q:'ITEM Q:EXIT D
. . I DGCDIS("DESCR",ITEM)="" Q
. . I $$TYPE^DGENA5(DGCDIS("DESCR",ITEM))'="DE" S EXIT=1,ERROR="'CD DESCRIPTOR' NOT VALID"
. Q:EXIT
. ; Diagnoses
. F S ITEM=$O(DGCDIS("DIAG",ITEM)) Q:'ITEM Q:EXIT D
. . I DGCDIS("DIAG",ITEM)="" Q
. . I $$TYPE^DGENA5(DGCDIS("DIAG",ITEM))'="D" S EXIT=1,ERROR="'CD STATUS DIAGNOSES' NOT VALID"
. Q:EXIT
. ; Procedures
. F S ITEM=$O(DGCDIS("PROC",ITEM)) Q:'ITEM Q:EXIT D
. . I DGCDIS("PROC",ITEM)="" Q
. . I $$TYPE^DGENA5(DGCDIS("PROC",ITEM))'="P" S EXIT=1,ERROR="'CD STATUS PROCEDURE' NOT VALID" Q
. . S EIEN="" F S EIEN=$O(DGCDIS("EXT",ITEM,EIEN)) Q:EIEN="" D
. . . I '$$LIMBOK^DGENA5(DGCDIS("PROC",ITEM),DGCDIS("EXT",ITEM,EIEN)) S EXIT=1,ERROR="'CD STATUS AFFECTED EXTREMITY' INVALID"
. Q:EXIT
. ; Conditions
. F S ITEM=$O(DGCDIS("COND",ITEM)) Q:'ITEM Q:EXIT D
. . I DGCDIS("COND",ITEM)="" Q
. . I $$TYPE^DGENA5(DGCDIS("COND",ITEM))'="C" S EXIT=1,ERROR="'' NOT VALID" Q
. . I '$$VALID^DGENA5(DGCDIS("COND",ITEM),DGCDIS("SCORE",ITEM)) S EXIT=1,ERROR="'CD CONDITION SCORE' NOT VALID" Q
. . I ".1.2.3."'[("."_DGCDIS("PERM",ITEM)_".") S ERROR="'PERMANENT STATUS INDICATOR' NOT VALID" Q
. Q:EXIT
. ; No reason present?
. I DGCDIS("VCD")="Y",('$D(DGCDIS("DESCR"))&('$D(DGCDIS("DIAG")))&('$D(DGCDIS("PROC")))&('$D(DGCDIS("COND")))) S ERROR="'CD REASON' NOT PRESENT" Q
. S VALID=1
Q VALID
;
ISCD(DGCDIS) ; Returns 1/0, is the patient CD?
; DGCDIS("DESCR",N)=CD REASON for Descriptor.
; DGCDIS("DIAG",N)=CD REASON for Diagnosis.
; DGCDIS("COND",N)=CD REASON for Condition.
; DGCDIS("SCORE",N)=SCORE (for condition.)
; DGCDIS("PERM",N)=Permanent Indicator (for condition).
; DGCDIS("PROC",N)=CD REASON for procedure.
; DGCDIS("EXT",N)=Affected Extremity (for procedure.)
N CD S CD=0 ; True if patient is CD.
N SUB,LIMB,LCODE,EXT,LIEN,EXCLUDE
S SUB=""
; DG*5.3*894 - Add Descriptor
F S SUB=$O(DGCDIS("DESCR",SUB)) Q:SUB="" D
. I $$TYPE^DGENA5($G(DGCDIS("DESCR",SUB)))'="DE" Q
. S CD=CD+1
F S SUB=$O(DGCDIS("DIAG",SUB)) Q:SUB="" D
. I $$TYPE^DGENA5($G(DGCDIS("DIAG",SUB)))'="D" Q
. S CD=CD+1
F S SUB=$O(DGCDIS("PROC",SUB)) Q:SUB="" D
. I $$TYPE^DGENA5($G(DGCDIS("PROC",SUB)))'="P" Q
. S LCODE=0
. F S LCODE=$O(DGCDIS("EXT",SUB,LCODE)) Q:'LCODE D
. . S EXT=DGCDIS("EXT",SUB,LCODE)
. . Q:EXT=""
. . S LIEN=$O(^DGEN(27.17,DGCDIS("PROC",SUB),1,"B",EXT,0))
. . Q:LIEN=""
. . S LIMB=$$LIMBCODE^DGENA5(DGCDIS("PROC",SUB),LIEN)
. . I LIMB'=EXT Q
. . I $D(EXCLUDE(SUB,LIMB)) Q
. . S EXCLUDE(SUB,LIMB)=""
. . S CD=CD+.5
F S SUB=$O(DGCDIS("COND",SUB)) Q:SUB="" D
. I $$TYPE^DGENA5($G(DGCDIS("COND",SUB)))'="C" Q
. I '$$RANGEMET^DGENA5(DGCDIS("COND",SUB),DGCDIS("SCORE",SUB),DGCDIS("PERM",SUB)) Q
. S CD=CD+1
S CD=(CD'<1)
Q CD
;
ERRDISP(FILE) ; Display error.
N LINE
S LINE=0
W:$X !
W "ERROR updating ",$S(FILE=2.401:"CD DESCRIPTORS",FILE=2.399!(FILE=2.409):"CD HISTORY",1:"PATIENT CD DATA"),!
F S LINE=$O(DGCDERR("DIERR",1,"TEXT",LINE)) Q:'LINE W ?5,DGCDERR("DIERR",1,"TEXT",LINE),!
W !
Q
;
DELETE(DFN) ;
;Description: Delete a catastrophic disability record for a patient
;Input:
; DFN - Patient IEN
;Output:
; Function Value - returns 1 if successful, otherwise 0
N SUCCESS,DIK,DA
S SUCCESS=1
D ;drops out if invalid condition found
. I $G(DFN),$D(^DPT(DFN,0))
. E S SUCCESS=0 Q
. I '$$LOCK(DFN) S SUCCESS=0 Q
. ;
. N DA,DIK
. S DA(1)=DFN
. S DA=.39
. S DIK="^DPT("_DFN_","_DA_","
. D ^DIK
. ;
. N SIEN,SUBFILE
. F SUBFILE=.401,.396,.397,.398 I $D(^DPT(DFN,SUBFILE)) D
. . S SIEN=0
. . F S SIEN=$O(^DPT(DFN,SUBFILE,SIEN)) Q:SIEN="" Q:SIEN'?.N D
. . . N DA,DIK
. . . S DA=SIEN
. . . S DA(1)=DFN
. . . S DIK="^DPT("_DFN_","_SUBFILE_","
. . . D ^DIK
. ;
. N DA,DIK
. S DA(1)=DFN
. S DA=2.401
. S DIK="^DPT("_DFN_","
. D ^DIK
. ; Note -- CD HISTORY field (#.399) must not be deleted.
D UNLOCK(DFN)
Q SUCCESS
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENCDA1 7612 printed Oct 16, 2024@18:43:07 Page 2
DGENCDA1 ;ALB/CJM,RMM Zoltan,JAN,PHH,BRM,CKN,DJS - Catastrophic Disabilty API - File Data;Sep 16, 2002 ; 9/22/05 5:25pm
+1 ;;5.3;Registration;**121,147,232,302,356,387,475,451,653,894**;Aug 13,1993;Build 48
+2 ;
+3 ; DG*5.3*894 - Enhance Catastrophic Disability to use Descriptors rather than Diagnoses/Procedures/Conditions.
+4 ;
LOCK(DFN) ;
+1 ;Description: Locks the catastrophic disability record for a patient
+2 ;Input:
+3 ; DFN - Patient IEN
+4 ;Output:
+5 ; Function Value - returns 1 if the patient is catastrophic disability
+6 ; record can be locked, otherwise 0
+7 IF $GET(DFN)
LOCK +^DPT(DFN,.39):2
+8 QUIT $TEST
+9 ;
UNLOCK(DFN) ;
+1 ;Description: Unlocks the catastrophic disability record for a patient
+2 ;Input:
+3 ; DFN - Patient IEN
+4 ;Output:
+5 ; None
+6 IF $GET(DFN)
LOCK -^DPT(DFN,.39)
+7 QUIT
+8 ;
CHECK(DGCDIS,ERROR) ;
+1 ;Description: Validity checks on the catastrophic disability contained
+2 ; in the DGCDIS array
+3 ;Input:
+4 ; DGCDIS - the catastrophic disability array, passed by reference
+5 ;Output:
+6 ; Function Value - returns 1 if validation checks passed, 0 otherwise
+7 ; ERROR - if validation fails an error mssg is returned, pass by
+8 ; reference
+9 NEW VALID,RESULT,EXTERNAL,ITEM,EIEN,EXIT,OK,ISCD,POP,FLD
+10 SET ERROR=""
+11 ;this is a deletion
if DGCDIS("VCD")="@"
QUIT 1
+12 ;NO value for VCD
if DGCDIS("VCD")="N"
QUIT 1
+13 ;drops out of block if invalid condition found
Begin DoDot:1
+14 ; Usually invalid if it exits early.
SET VALID=0
+15 ; CD Flag must have a value if any other CD field is populated
+16 SET POP=0
+17 IF DGCDIS("VCD")=""
Begin DoDot:2
+18 FOR FLD="BY","DATE","FACDET","REVDTE","METDET"
Begin DoDot:3
+19 IF $GET(DGCDIS(FLD))]""
SET POP=1
End DoDot:3
if POP
QUIT
+20 IF POP
SET ERROR="'VETERAN CATASTROPHICALLY DISABLED?' FIELD MUST HAVE A RESPONSE"
QUIT
End DoDot:2
if POP
QUIT
+21 ; Decided by.
+22 IF DGCDIS("VCD")'=""
IF $GET(DGCDIS("BY"))=""
SET ERROR="CATASTROPHIC DISABILITY 'DECIDED BY' REQUIRED"
QUIT
+23 IF $GET(DGCDIS("BY"))'=""
IF ($LENGTH(DGCDIS("BY"))<3)!($LENGTH(DGCDIS("BY"))>35)
SET ERROR="CATASTROPHIC DISABILITY 'DECIDED BY' NOT VALID"
QUIT
+24 IF $$UPPER^DGUTL($GET(DGCDIS("BY")))="HINQ"
SET ERROR="CATASTROPHIC DISABILITY 'DECIDED BY' CAN NOT BE 'HINQ'"
QUIT
+25 ; Date of Decision
+26 SET OK=1
SET EXTERNAL=""
+27 IF DGCDIS("VCD")'=""
IF $GET(DGCDIS("DATE"))=""
SET ERROR="'DATE OF CATASTOPHIC DISABILITY DECISION' REQUIRED"
QUIT
+28 IF $GET(DGCDIS("DATE"))'=""
Begin DoDot:2
+29 IF 'DGCDIS("DATE")
SET OK=0
QUIT
+30 SET EXTERNAL=$$EXTERNAL^DILFD(2,.392,"",DGCDIS("DATE"))
+31 IF EXTERNAL=""
SET OK=0
+32 DO CHK^DIE(2,.392,,EXTERNAL,.RESULT)
+33 IF RESULT="^"
SET OK=0
End DoDot:2
+34 IF 'OK
SET ERROR="'DATE OF CATASTOPHIC DISABILITY DECISION' NOT VALID"
QUIT
+35 ; Facility Making Determination.
+36 IF DGCDIS("VCD")'=""!(DGCDIS("FACDET")'="")
IF $$EXTERNAL^DILFD(2,.393,"",$GET(DGCDIS("FACDET")))=""
SET ERROR="'FACILITY MAKING CATASTROPHIC DISABILITY DETERMINATION' NOT VALID"
QUIT
+37 ; Review Date
+38 IF DGCDIS("VCD")'=""
IF $GET(DGCDIS("REVDTE"))=""
SET ERROR="'CATASTROPHIC DISABILITY REVIEW DATE' REQUIRED"
QUIT
+39 IF DGCDIS("REVDTE")'=""
Begin DoDot:2
+40 SET EXTERNAL=$$EXTERNAL^DILFD(2,.394,"",DGCDIS("REVDTE"))
+41 IF EXTERNAL=""
SET ERROR="'CATASTROPHIC DISABILITY REVIEW DATE' NOT VALID"
QUIT
+42 DO CHK^DIE(2,.394,,EXTERNAL,.RESULT)
+43 IF RESULT="^"
SET ERROR="'CATASTROPHIC DISABILTY REVIEW DATE' INVALID"
QUIT
+44 IF $GET(DGCDIS("DATE"))
IF DGCDIS("REVDTE")>DGCDIS("DATE")
SET ERROR="'CD REVIEW DATE' GREATER THAN 'CD DATE OF DETERMINATION'."
QUIT
End DoDot:2
if ERROR'=""
QUIT
+45 ; Method of Determination
+46 IF $GET(DGCDIS("METDET"))=""
IF DGCDIS("VCD")'=""
SET ERROR="'METHOD OF DETERMINATION' IS A REQUIRED VALUE."
QUIT
+47 IF "..2.3."'[("."_$GET(DGCDIS("METDET"))_".")
SET ERROR="'METHOD OF DETERMINATION' NOT VALID"
QUIT
+48 SET ITEM=""
SET EXIT=0
+49 ; Descriptor
+50 FOR
SET ITEM=$ORDER(DGCDIS("DESCR",ITEM))
if 'ITEM
QUIT
if EXIT
QUIT
Begin DoDot:2
+51 IF DGCDIS("DESCR",ITEM)=""
QUIT
+52 IF $$TYPE^DGENA5(DGCDIS("DESCR",ITEM))'="DE"
SET EXIT=1
SET ERROR="'CD DESCRIPTOR' NOT VALID"
End DoDot:2
+53 if EXIT
QUIT
+54 ; Diagnoses
+55 FOR
SET ITEM=$ORDER(DGCDIS("DIAG",ITEM))
if 'ITEM
QUIT
if EXIT
QUIT
Begin DoDot:2
+56 IF DGCDIS("DIAG",ITEM)=""
QUIT
+57 IF $$TYPE^DGENA5(DGCDIS("DIAG",ITEM))'="D"
SET EXIT=1
SET ERROR="'CD STATUS DIAGNOSES' NOT VALID"
End DoDot:2
+58 if EXIT
QUIT
+59 ; Procedures
+60 FOR
SET ITEM=$ORDER(DGCDIS("PROC",ITEM))
if 'ITEM
QUIT
if EXIT
QUIT
Begin DoDot:2
+61 IF DGCDIS("PROC",ITEM)=""
QUIT
+62 IF $$TYPE^DGENA5(DGCDIS("PROC",ITEM))'="P"
SET EXIT=1
SET ERROR="'CD STATUS PROCEDURE' NOT VALID"
QUIT
+63 SET EIEN=""
FOR
SET EIEN=$ORDER(DGCDIS("EXT",ITEM,EIEN))
if EIEN=""
QUIT
Begin DoDot:3
+64 IF '$$LIMBOK^DGENA5(DGCDIS("PROC",ITEM),DGCDIS("EXT",ITEM,EIEN))
SET EXIT=1
SET ERROR="'CD STATUS AFFECTED EXTREMITY' INVALID"
End DoDot:3
End DoDot:2
+65 if EXIT
QUIT
+66 ; Conditions
+67 FOR
SET ITEM=$ORDER(DGCDIS("COND",ITEM))
if 'ITEM
QUIT
if EXIT
QUIT
Begin DoDot:2
+68 IF DGCDIS("COND",ITEM)=""
QUIT
+69 IF $$TYPE^DGENA5(DGCDIS("COND",ITEM))'="C"
SET EXIT=1
SET ERROR="'' NOT VALID"
QUIT
+70 IF '$$VALID^DGENA5(DGCDIS("COND",ITEM),DGCDIS("SCORE",ITEM))
SET EXIT=1
SET ERROR="'CD CONDITION SCORE' NOT VALID"
QUIT
+71 IF ".1.2.3."'[("."_DGCDIS("PERM",ITEM)_".")
SET ERROR="'PERMANENT STATUS INDICATOR' NOT VALID"
QUIT
End DoDot:2
+72 if EXIT
QUIT
+73 ; No reason present?
+74 IF DGCDIS("VCD")="Y"
IF ('$DATA(DGCDIS("DESCR"))&('$DATA(DGCDIS("DIAG")))&('$DATA(DGCDIS("PROC")))&('$DATA(DGCDIS("COND"))))
SET ERROR="'CD REASON' NOT PRESENT"
QUIT
+75 SET VALID=1
End DoDot:1
+76 QUIT VALID
+77 ;
ISCD(DGCDIS) ; Returns 1/0, is the patient CD?
+1 ; DGCDIS("DESCR",N)=CD REASON for Descriptor.
+2 ; DGCDIS("DIAG",N)=CD REASON for Diagnosis.
+3 ; DGCDIS("COND",N)=CD REASON for Condition.
+4 ; DGCDIS("SCORE",N)=SCORE (for condition.)
+5 ; DGCDIS("PERM",N)=Permanent Indicator (for condition).
+6 ; DGCDIS("PROC",N)=CD REASON for procedure.
+7 ; DGCDIS("EXT",N)=Affected Extremity (for procedure.)
+8 ; True if patient is CD.
NEW CD
SET CD=0
+9 NEW SUB,LIMB,LCODE,EXT,LIEN,EXCLUDE
+10 SET SUB=""
+11 ; DG*5.3*894 - Add Descriptor
+12 FOR
SET SUB=$ORDER(DGCDIS("DESCR",SUB))
if SUB=""
QUIT
Begin DoDot:1
+13 IF $$TYPE^DGENA5($GET(DGCDIS("DESCR",SUB)))'="DE"
QUIT
+14 SET CD=CD+1
End DoDot:1
+15 FOR
SET SUB=$ORDER(DGCDIS("DIAG",SUB))
if SUB=""
QUIT
Begin DoDot:1
+16 IF $$TYPE^DGENA5($GET(DGCDIS("DIAG",SUB)))'="D"
QUIT
+17 SET CD=CD+1
End DoDot:1
+18 FOR
SET SUB=$ORDER(DGCDIS("PROC",SUB))
if SUB=""
QUIT
Begin DoDot:1
+19 IF $$TYPE^DGENA5($GET(DGCDIS("PROC",SUB)))'="P"
QUIT
+20 SET LCODE=0
+21 FOR
SET LCODE=$ORDER(DGCDIS("EXT",SUB,LCODE))
if 'LCODE
QUIT
Begin DoDot:2
+22 SET EXT=DGCDIS("EXT",SUB,LCODE)
+23 if EXT=""
QUIT
+24 SET LIEN=$ORDER(^DGEN(27.17,DGCDIS("PROC",SUB),1,"B",EXT,0))
+25 if LIEN=""
QUIT
+26 SET LIMB=$$LIMBCODE^DGENA5(DGCDIS("PROC",SUB),LIEN)
+27 IF LIMB'=EXT
QUIT
+28 IF $DATA(EXCLUDE(SUB,LIMB))
QUIT
+29 SET EXCLUDE(SUB,LIMB)=""
+30 SET CD=CD+.5
End DoDot:2
End DoDot:1
+31 FOR
SET SUB=$ORDER(DGCDIS("COND",SUB))
if SUB=""
QUIT
Begin DoDot:1
+32 IF $$TYPE^DGENA5($GET(DGCDIS("COND",SUB)))'="C"
QUIT
+33 IF '$$RANGEMET^DGENA5(DGCDIS("COND",SUB),DGCDIS("SCORE",SUB),DGCDIS("PERM",SUB))
QUIT
+34 SET CD=CD+1
End DoDot:1
+35 SET CD=(CD'<1)
+36 QUIT CD
+37 ;
ERRDISP(FILE) ; Display error.
+1 NEW LINE
+2 SET LINE=0
+3 if $X
WRITE !
+4 WRITE "ERROR updating ",$SELECT(FILE=2.401:"CD DESCRIPTORS",FILE=2.399!(FILE=2.409):"CD HISTORY",1:"PATIENT CD DATA"),!
+5 FOR
SET LINE=$ORDER(DGCDERR("DIERR",1,"TEXT",LINE))
if 'LINE
QUIT
WRITE ?5,DGCDERR("DIERR",1,"TEXT",LINE),!
+6 WRITE !
+7 QUIT
+8 ;
DELETE(DFN) ;
+1 ;Description: Delete a catastrophic disability record for a patient
+2 ;Input:
+3 ; DFN - Patient IEN
+4 ;Output:
+5 ; Function Value - returns 1 if successful, otherwise 0
+6 NEW SUCCESS,DIK,DA
+7 SET SUCCESS=1
+8 ;drops out if invalid condition found
Begin DoDot:1
+9 IF $GET(DFN)
IF $DATA(^DPT(DFN,0))
+10 IF '$TEST
SET SUCCESS=0
QUIT
+11 IF '$$LOCK(DFN)
SET SUCCESS=0
QUIT
+12 ;
+13 NEW DA,DIK
+14 SET DA(1)=DFN
+15 SET DA=.39
+16 SET DIK="^DPT("_DFN_","_DA_","
+17 DO ^DIK
+18 ;
+19 NEW SIEN,SUBFILE
+20 FOR SUBFILE=.401,.396,.397,.398
IF $DATA(^DPT(DFN,SUBFILE))
Begin DoDot:2
+21 SET SIEN=0
+22 FOR
SET SIEN=$ORDER(^DPT(DFN,SUBFILE,SIEN))
if SIEN=""
QUIT
if SIEN'?.N
QUIT
Begin DoDot:3
+23 NEW DA,DIK
+24 SET DA=SIEN
+25 SET DA(1)=DFN
+26 SET DIK="^DPT("_DFN_","_SUBFILE_","
+27 DO ^DIK
End DoDot:3
End DoDot:2
+28 ;
+29 NEW DA,DIK
+30 SET DA(1)=DFN
+31 SET DA=2.401
+32 SET DIK="^DPT("_DFN_","
+33 DO ^DIK
+34 ; Note -- CD HISTORY field (#.399) must not be deleted.
End DoDot:1
+35 DO UNLOCK(DFN)
+36 QUIT SUCCESS
+37 ;
