- 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 Feb 19, 2025@00:08:31 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 ;