DGENCDA1 ;ALB/CJM,RMM Zoltan,JAN,PHH,BRM,CKN - 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,1015**;Aug 13,1993;Build 21
;
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
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
. . I $G(DGCDIS("DIAG",1))]""!($G(DGCDIS("COND",1))]"")!($G(DGCDIS("PROC",1))]"") D
. . . S POP=1,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
. ; 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("DIAG"))!$D(DGCDIS("PROC"))!$D(DGCDIS("COND"))) S ERROR="'CD STATUS REASON' NOT PRESENT" Q
. ; VCD doesn't match determination status?
. S ISCD=$$ISCD(.DGCDIS)
. I DGCDIS("VCD")="Y",'ISCD S ERROR="Not enough diagnoses/procedures/conditions to qualify for CD Status." Q
. I DGCDIS("VCD")="N",ISCD S ERROR="Veteran has enough diagnoses/procedures/conditions to qualify for CD Status." Q
. S VALID=1
Q VALID
;
ISCD(DGCDIS) ; Returns 1/0, is the patient CD?
; DGCDIS("DIAG",N)=CD REASON for Diagnosis.
; DGCDIS("COND",N)=CD REASON for Condition.
; DGCDIS("SCORE",N)=SCORE (for condition.)
; DGCDIS("PERM",N)=Permanant 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=""
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)
;S DGCDIS("VCD")=$E("NY",CD+1)
Q CD
;
ERRDISP(FILE) ; Display error.
N LINE
S LINE=0
W:$X !
W "ERROR updating ",$S(FILE=2.396:"CD DIAGNOSES",FILE=2.397:"CD PROCEDURES",FILE=2.398:"CD CONDITIONS",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,DIE,DR,DA,D0,DIC
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
. S DIE="^DPT("
. S DR=".39////@"
. S DR=DR_";.391////@"
. S DR=DR_";.392////@"
. S DR=DR_";.393////@"
. S DR=DR_";.394////@"
. S DR=DR_";.395////@"
. S DR=DR_";.3951////@"
. S DR=DR_";.3952////@"
. S DR=DR_";.3953////@"
. S DA=DFN
. D ^DIE
. N SIEN,SUBFILE
. F SUBFILE=.396,.397,.398 I $D(^DPT(DFN,SUBFILE)) D
. . S SIEN=0
. . F S SIEN=$O(^DPT(DFN,SUBFILE,SIEN)) Q:'SIEN D
. . . N DA,DIE,DR
. . . S DIE="^DPT("_DFN_","_SUBFILE_","
. . . S DR=".01////@"
. . . S DA=SIEN,DA(1)=DFN
. . . D ^DIE
. ; Note -- CD HISTORY field (#.399) must not be deleted.
D UNLOCK(DFN)
Q SUCCESS
DGENCDA1 ;ALB/CJM,RMM Zoltan,JAN,PHH,BRM,CKN - 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,1015**;Aug 13,1993;Build 21
+2 ;
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 ;drops out of block if invalid condition found
Begin DoDot:1
+13 ; Usually invalid if it exits early.
SET VALID=0
+14 ; CD Flag must have a value if any other CD field is populated
+15 SET POP=0
+16 IF DGCDIS("VCD")=""
Begin DoDot:2
+17 FOR FLD="BY","DATE","FACDET","REVDTE","METDET"
Begin DoDot:3
+18 IF $GET(DGCDIS(FLD))]""
SET POP=1
End DoDot:3
IF POP
QUIT
+19 IF POP
SET ERROR="'VETERAN CATASTROPHICALLY DISABLED?' FIELD MUST HAVE A RESPONSE"
QUIT
+20 IF $GET(DGCDIS("DIAG",1))]""!($GET(DGCDIS("COND",1))]"")!($GET(DGCDIS("PROC",1))]"")
Begin DoDot:3
+21 SET POP=1
SET ERROR="'VETERAN CATASTROPHICALLY DISABLED?' FIELD MUST HAVE A RESPONSE"
QUIT
End DoDot:3
End DoDot:2
IF POP
QUIT
+22 ; Decided by.
+23 IF DGCDIS("VCD")'=""
IF $GET(DGCDIS("BY"))=""
SET ERROR="CATASTROPHIC DISABILITY 'DECIDED BY' REQUIRED"
QUIT
+24 IF $GET(DGCDIS("BY"))'=""
IF ($LENGTH(DGCDIS("BY"))<3)!($LENGTH(DGCDIS("BY"))>35)
SET ERROR="CATASTROPHIC DISABILITY 'DECIDED BY' NOT VALID"
QUIT
+25 IF $$UPPER^DGUTL($GET(DGCDIS("BY")))="HINQ"
SET ERROR="CATASTROPHIC DISABILITY 'DECIDED BY' CAN NOT BE 'HINQ'"
QUIT
+26 ; Date of Decision
+27 SET OK=1
SET EXTERNAL=""
+28 IF DGCDIS("VCD")'=""
IF $GET(DGCDIS("DATE"))=""
SET ERROR="'DATE OF CATASTOPHIC DISABILITY DECISION' REQUIRED"
QUIT
+29 IF $GET(DGCDIS("DATE"))'=""
Begin DoDot:2
+30 IF 'DGCDIS("DATE")
SET OK=0
QUIT
+31 SET EXTERNAL=$$EXTERNAL^DILFD(2,.392,"",DGCDIS("DATE"))
+32 IF EXTERNAL=""
SET OK=0
+33 DO CHK^DIE(2,.392,,EXTERNAL,.RESULT)
+34 IF RESULT="^"
SET OK=0
End DoDot:2
+35 IF 'OK
SET ERROR="'DATE OF CATASTOPHIC DISABILITY DECISION' NOT VALID"
QUIT
+36 ; Facility Making Determination.
+37 IF DGCDIS("VCD")'=""!(DGCDIS("FACDET")'="")
IF $$EXTERNAL^DILFD(2,.393,"",$GET(DGCDIS("FACDET")))=""
SET ERROR="'FACILITY MAKING CATASTROPHIC DISABILITY DETERMINATION' NOT VALID"
QUIT
+38 ; Review Date
+39 IF DGCDIS("VCD")'=""
IF $GET(DGCDIS("REVDTE"))=""
SET ERROR="'CATASTROPHIC DISABILITY REVIEW DATE' REQUIRED"
QUIT
+40 IF DGCDIS("REVDTE")'=""
Begin DoDot:2
+41 SET EXTERNAL=$$EXTERNAL^DILFD(2,.394,"",DGCDIS("REVDTE"))
+42 IF EXTERNAL=""
SET ERROR="'CATASTROPHIC DISABILITY REVIEW DATE' NOT VALID"
QUIT
+43 DO CHK^DIE(2,.394,,EXTERNAL,.RESULT)
+44 IF RESULT="^"
SET ERROR="'CATASTROPHIC DISABILTY REVIEW DATE' INVALID"
QUIT
+45 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
+46 ; Method of Determination
+47 IF $GET(DGCDIS("METDET"))=""
IF DGCDIS("VCD")'=""
SET ERROR="'METHOD OF DETERMINATION' IS A REQUIRED VALUE."
QUIT
+48 IF "..2.3."'[("."_$GET(DGCDIS("METDET"))_".")
SET ERROR="'METHOD OF DETERMINATION' NOT VALID"
QUIT
+49 SET ITEM=""
SET EXIT=0
+50 ; Diagnoses
+51 FOR
SET ITEM=$ORDER(DGCDIS("DIAG",ITEM))
IF 'ITEM
QUIT
IF EXIT
QUIT
Begin DoDot:2
+52 IF DGCDIS("DIAG",ITEM)=""
QUIT
+53 IF $$TYPE^DGENA5(DGCDIS("DIAG",ITEM))'="D"
SET EXIT=1
SET ERROR="'CD STATUS DIAGNOSES' NOT VALID"
End DoDot:2
+54 IF EXIT
QUIT
+55 ; Procedures
+56 FOR
SET ITEM=$ORDER(DGCDIS("PROC",ITEM))
IF 'ITEM
QUIT
IF EXIT
QUIT
Begin DoDot:2
+57 IF DGCDIS("PROC",ITEM)=""
QUIT
+58 IF $$TYPE^DGENA5(DGCDIS("PROC",ITEM))'="P"
SET EXIT=1
SET ERROR="'CD STATUS PROCEDURE' NOT VALID"
QUIT
+59 SET EIEN=""
FOR
SET EIEN=$ORDER(DGCDIS("EXT",ITEM,EIEN))
IF EIEN=""
QUIT
Begin DoDot:3
+60 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
+61 IF EXIT
QUIT
+62 ; Conditions
+63 FOR
SET ITEM=$ORDER(DGCDIS("COND",ITEM))
IF 'ITEM
QUIT
IF EXIT
QUIT
Begin DoDot:2
+64 IF DGCDIS("COND",ITEM)=""
QUIT
+65 IF $$TYPE^DGENA5(DGCDIS("COND",ITEM))'="C"
SET EXIT=1
SET ERROR="'' NOT VALID"
QUIT
+66 IF '$$VALID^DGENA5(DGCDIS("COND",ITEM),DGCDIS("SCORE",ITEM))
SET EXIT=1
SET ERROR="'CD CONDITION SCORE' NOT VALID"
QUIT
+67 IF ".1.2.3."'[("."_DGCDIS("PERM",ITEM)_".")
SET ERROR="'PERMANENT STATUS INDICATOR' NOT VALID"
QUIT
End DoDot:2
+68 IF EXIT
QUIT
+69 ; No reason present?
+70 IF DGCDIS("VCD")="Y"
IF '($DATA(DGCDIS("DIAG"))!$DATA(DGCDIS("PROC"))!$DATA(DGCDIS("COND")))
SET ERROR="'CD STATUS REASON' NOT PRESENT"
QUIT
+71 ; VCD doesn't match determination status?
+72 SET ISCD=$$ISCD(.DGCDIS)
+73 IF DGCDIS("VCD")="Y"
IF 'ISCD
SET ERROR="Not enough diagnoses/procedures/conditions to qualify for CD Status."
QUIT
+74 IF DGCDIS("VCD")="N"
IF ISCD
SET ERROR="Veteran has enough diagnoses/procedures/conditions to qualify for CD Status."
QUIT
+75 SET VALID=1
End DoDot:1
+76 QUIT VALID
+77 ;
ISCD(DGCDIS) ; Returns 1/0, is the patient CD?
+1 ; DGCDIS("DIAG",N)=CD REASON for Diagnosis.
+2 ; DGCDIS("COND",N)=CD REASON for Condition.
+3 ; DGCDIS("SCORE",N)=SCORE (for condition.)
+4 ; DGCDIS("PERM",N)=Permanant Indicator (for condition).
+5 ; DGCDIS("PROC",N)=CD REASON for procedure.
+6 ; DGCDIS("EXT",N)=Affected Extremity (for procedure.)
+7 ; True if patient is CD.
NEW CD
SET CD=0
+8 NEW SUB,LIMB,LCODE,EXT,LIEN,EXCLUDE
+9 SET SUB=""
+10 FOR
SET SUB=$ORDER(DGCDIS("DIAG",SUB))
IF SUB=""
QUIT
Begin DoDot:1
+11 IF $$TYPE^DGENA5($GET(DGCDIS("DIAG",SUB)))'="D"
QUIT
+12 SET CD=CD+1
End DoDot:1
+13 FOR
SET SUB=$ORDER(DGCDIS("PROC",SUB))
IF SUB=""
QUIT
Begin DoDot:1
+14 IF $$TYPE^DGENA5($GET(DGCDIS("PROC",SUB)))'="P"
QUIT
+15 SET LCODE=0
+16 FOR
SET LCODE=$ORDER(DGCDIS("EXT",SUB,LCODE))
IF 'LCODE
QUIT
Begin DoDot:2
+17 SET EXT=DGCDIS("EXT",SUB,LCODE)
+18 IF EXT=""
QUIT
+19 SET LIEN=$ORDER(^DGEN(27.17,DGCDIS("PROC",SUB),1,"B",EXT,0))
+20 IF LIEN=""
QUIT
+21 SET LIMB=$$LIMBCODE^DGENA5(DGCDIS("PROC",SUB),LIEN)
+22 IF LIMB'=EXT
QUIT
+23 IF $DATA(EXCLUDE(SUB,LIMB))
QUIT
+24 SET EXCLUDE(SUB,LIMB)=""
+25 SET CD=CD+.5
End DoDot:2
End DoDot:1
+26 FOR
SET SUB=$ORDER(DGCDIS("COND",SUB))
IF SUB=""
QUIT
Begin DoDot:1
+27 IF $$TYPE^DGENA5($GET(DGCDIS("COND",SUB)))'="C"
QUIT
+28 IF '$$RANGEMET^DGENA5(DGCDIS("COND",SUB),DGCDIS("SCORE",SUB),DGCDIS("PERM",SUB))
QUIT
+29 SET CD=CD+1
End DoDot:1
+30 SET CD=(CD'<1)
+31 ;S DGCDIS("VCD")=$E("NY",CD+1)
+32 QUIT CD
+33 ;
ERRDISP(FILE) ; Display error.
+1 NEW LINE
+2 SET LINE=0
+3 IF $X
WRITE !
+4 WRITE "ERROR updating ",$SELECT(FILE=2.396:"CD DIAGNOSES",FILE=2.397:"CD PROCEDURES",FILE=2.398:"CD CONDITIONS",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,DIE,DR,DA,D0,DIC
+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 SET DIE="^DPT("
+13 SET DR=".39////@"
+14 SET DR=DR_";.391////@"
+15 SET DR=DR_";.392////@"
+16 SET DR=DR_";.393////@"
+17 SET DR=DR_";.394////@"
+18 SET DR=DR_";.395////@"
+19 SET DR=DR_";.3951////@"
+20 SET DR=DR_";.3952////@"
+21 SET DR=DR_";.3953////@"
+22 SET DA=DFN
+23 DO ^DIE
+24 NEW SIEN,SUBFILE
+25 FOR SUBFILE=.396,.397,.398
IF $DATA(^DPT(DFN,SUBFILE))
Begin DoDot:2
+26 SET SIEN=0
+27 FOR
SET SIEN=$ORDER(^DPT(DFN,SUBFILE,SIEN))
IF 'SIEN
QUIT
Begin DoDot:3
+28 NEW DA,DIE,DR
+29 SET DIE="^DPT("_DFN_","_SUBFILE_","
+30 SET DR=".01////@"
+31 SET DA=SIEN
SET DA(1)=DFN
+32 DO ^DIE
End DoDot:3
End DoDot:2
+33 ; Note -- CD HISTORY field (#.399) must not be deleted.
End DoDot:1
+34 DO UNLOCK(DFN)
+35 QUIT SUCCESS
