DGENA5 ;ALB/EZ,CKN,TEJ,KUM - Enrollment API - CD Processing ;8/15/08 11:10am
;;5.3;Registration;**232,688,850,894,1109**;Aug 13, 1993;Build 13
;Phase II API's Related to Catastrophic Disability.
;
; The following variable names are used consistently in this routine:
; DFN = IEN in PATIENT file (#2).
; REASON = IEN in CATASTROPHIC DISABILITY REASONS file (#2).
; COND = Sub-ien PATIENT(#2) CD STATUS CONDITIONS field (#.398).
; SCORE = Score achieved by veteran on a test (#2, #.398, #1).
; PERM = Permanent Indicator (#2, #.398, #2).
; D2 = Secondary delimiter (optional.)
;
; Processing related to a patient (#2).
VCD(DFN) ; Veteran Catastrophically Disabled? (#.39)
Q $P($G(^DPT(DFN,.39)),"^",6)
CONDHELP(DFN,COND) ; Display help text for a condition.
; Applies to the PATIENT file (#2) CD STATUS CONDITIONS field (#.398)
; Note - Help text stored in 27.17 CD REASONS.
N REASON
S REASON=$$REASON(DFN,COND)
D HELP(REASON)
Q
CONDINP(DFN,COND,SCORE) ; Validate a score entered by the user for a PATIENT.
N REASON
S REASON=$$REASON(DFN,COND)
Q $$VALID(REASON,SCORE)
CONDMET(DFN,COND) ; Determine whether a condition meets the criteria.
N SCORE,PERM
S REASON=$$REASON(DFN,COND)
S SCORE=$$PATSCORE(DFN,COND)
S PERM=$$PATPERM(DFN,COND)
Q $$RANGEMET(REASON,SCORE,PERM)
; Patient Field Lookup.
REASON(DFN,COND) ; Get the CD REASON for this patient, for this condition.
N REASON
I DFN=""!(COND="") D
. S REASON=$G(DGCDREAS)
. I REASON="",$G(ITEM)'="" S REASON=$G(DGCDIS("COND",ITEM))
E S REASON=$P($G(^DPT(DFN,.398,COND,0)),"^",1)
Q REASON
PATSCORE(DFN,COND) ; Get the TEST SCORE for this patient, for this condition.
N REASON
I DFN=""!(COND="") Q ""
S REASON=$P($G(^DPT(DFN,.398,COND,0)),"^",2)
Q REASON
PATPERM(DFN,COND) ; Get the PERMANENT INDICATOR for this patient+condition.
N REASON
I DFN=""!(COND="") Q ""
S REASON=$P($G(^DPT(DFN,.398,COND,0)),"^",3)
Q REASON
; Processing related to catastrophic disability reasons (#27.17)
HELP(REASON) ; Display help text from 27.17 CD REASONS.
N LINE
Q:$$TYPE(REASON)'="C"
S LINE=0
W !,"HELP TEXT FOR ",$$NAME(REASON),!
F S LINE=$O(^DGEN(27.17,REASON,3,LINE)) Q:'LINE D
. W ?3,^DGEN(27.17,REASON,3,LINE,0),!
Q
VALID(REASON,SCORE) ; Validate a proposed score for a test.
N TEST,X
S TEST=$$VALSCORE(REASON)
S X=SCORE
I @TEST Q 1
Q 0
RANGEMET(REASON,SCORE,PERM) ; Determine whether this reason is satisfied.
N TEST
S TEST=$$RANGE(REASON)
I @TEST Q 1
Q 0
; APIs to access CD REASONS file.
NAME(REASON) ; Return NAME (.01) for this CD REASON.
Q:'REASON ""
Q $P($G(^DGEN(27.17,REASON,0)),"^",1)
TYPE(REASON) ; Return TYPE (#1) for this CD REASON.
Q:'REASON ""
Q $P($G(^DGEN(27.17,REASON,0)),"^",2)
VALSCORE(REASON) ; Return VALIDATION (#7) for this CD REASON.
; This determines whether a score is valid at all.
Q $G(^DGEN(27.17,REASON,4))
RANGE(REASON) ; Return TEST SCORE RANGE (#5) for this CD REASON.
; This determines whether the score qualifies for CD.
Q $G(^DGEN(27.17,REASON,2))
FILENAME(REASON) ; Return the file name to which this CD Reason points.
N CODEPTR,DIC,DO
S U=$G(U,"^")
S CODEPTR=$$CODEPTR(REASON)
I CODEPTR="" Q ""
S DIC="^"_$P(CODEPTR,";",2)
S DIC(0)=""
D DO^DIC1
Q $P(DO,"^",1)
CODE(REASON) ; Return the HL7 Transmission Code for this CD Reason.
Q:'REASON ""
Q $P($G(^DGEN(27.17,REASON,0)),"^",4)
CODENAME(REASON) ; Return name of code associated with this CD Reason.
N CODEPTR,CODEIEN,CODEGLO,CODEPC,CODENAME,CODE
S CODEPTR=$$CODEPTR(REASON)
I CODEPTR="" Q ""
S CODEIEN=$P(CODEPTR,";",1)
S CODEGLO=$P(CODEPTR,";",2)
S CODEPC=$S(CODEGLO="ICD9(":3,CODEGLO="ICD0(":4,CODEGLO="ICPT(":2)
S CODEGLO="^"_CODEGLO_CODEIEN_",0)"
S CODE=$P(@CODEGLO,"^",1)
S CODENAME=$P(@CODEGLO,"^",CODEPC)
Q CODENAME
CODEPTR(REASON) ; Internal label--get pointer to CODE.
Q $P($G(^DGEN(27.17,REASON,0)),"^",3)
LSCREEN(LIMBCODE) ; Used to validate LIMB in screen.
N REASON
S REASON=""
I $G(D0)=""!($G(D1)="") D
. S REASON=$G(DGCDREAS)
. I REASON="",$G(ITEM)'="" S REASON=$G(DGCDIS("PROC",ITEM))
E S REASON=$P($G(^DPT(D0,.397,D1,0)),"^",1)
I REASON="" Q ".RUE.LUE.RLE.LLE.BLE.BLU."[("."_LIMBCODE_".")
Q $$LIMBOK(REASON,LIMBCODE)
LIMBOK(REASON,LIMBCODE) ; Return 1/0 Affected Extremity OK for this REASON.
N LIMBIEN,VALID
S VALID=0
S LIMBIEN=0
F S LIMBIEN=$$NEXTLIMB(REASON,LIMBIEN) Q:'LIMBIEN D Q:VALID
. I $$LIMBCODE(REASON,LIMBIEN)=LIMBCODE S VALID=1
Q VALID
NEXTLIMB(REASON,LIMBIEN) ; Get next possible limb for this REASON.
I 'LIMBIEN S LIMBIEN=0
S LIMBIEN=$O(^DGEN(27.17,REASON,1,LIMBIEN))
I 'LIMBIEN S LIMBIEN=""
Q LIMBIEN
LIMBCODE(REASON,LIMBIEN) ; Return limb code for an affected limb.
Q $P($G(^DGEN(27.17,REASON,1,LIMBIEN,0)),"^",1)
; HL7-related changes.
HL7TORSN(HL7VAL,D2) ; Return REASON IEN for a HL7 Transmission Value.
; This function returns the IEN or 0 if there is none.
S D2=$S(11[$D(D2):D2,11[$D(HLECH):$E(HLECH),1:"~")
I $P("KATZ^FOLS^RUG3^FIM^GAF","^",$P(HL7VAL,D2,1))=$P(HL7VAL,D2,2) D
. S HL7VAL=$P("KATZ^FOLS^RUG3^FIM^GAF","^",+HL7VAL)
E S HL7VAL=$P(HL7VAL,D2)
Q:HL7VAL="" 0
Q +$O(^DGEN(27.17,"C",HL7VAL,""))
; * check the new DESCRIPTOR seq - DG*5.3*894
HL7TODSC(HL7VAL,D2) ; Return DESCRIPTOR IEN for a HL7 Transmission Value.
; This function returns the IEN or 0 if there is none.
Q:HL7VAL="" 0
Q +$O(^DGEN(27.17,"C",HL7VAL,""))
RSNTOHL7(REASON,D2) ; Return HL7 Segment Value for this Reason.
Q:REASON="" 0
S D2=$S(11[$D(D2):D2,11[$D(HLECH):$E(HLECH),1:"~")
N NAME,NUMBER,TABLE,FILE,CODE,HL7VAL
;DG*5.3*1109 - Initialize HL7VAL to avoid hard error if REASON doesn't exist in #27.17
S HL7VAL=""
I $$TYPE(REASON)="C" D
. S CODE=$$CODE(REASON)
. Q:CODE=""
. S NUMBER=$L($P("KATZ^FOLS^RUG3^FIM^GAF^",CODE),"^")
. Q:NUMBER>5
. S TABLE="VA0043"
. S HL7VAL=NUMBER_D2_CODE_D2_TABLE
E D
. S NAME=$$NAME(REASON)
. Q:NAME=""
. S CODE=$$CODE(REASON)
. Q:CODE=""
. S FILE=$$FILENAME(REASON)
. Q:FILE=""
. S HL7VAL=CODE_D2_NAME_D2_FILE
; NOTE: an undefined variable error on the following line may
; result, if someone has tampered with the CATASTROPHIC
; DISABILITY REASONS file (#27.17).
Q HL7VAL
; * check the new DESCRIPTOR seq - DG*5.3*894
DSCR2HL7(DGDFN,D2) ; Return HL7 Sequence Value for all Descriptors.
S DG2=DGDFN
S DGHLENCD="~|\&"
K DGTMP,DSCRTOHL7
M DGTMP=^DPT(DG2,.401)
I $D(DGTMP) S (I1,I2)=0 F S I1=$O(DGTMP(I1)),I2=I2+1 Q:+I1=0 S DG2717=+DGTMP(I1,0),$P(DSCRTOHL7,$E(DGHLENCD,2),I2)=$$TOHL7()
Q $G(DSCRTOHL7,0)
TOHL7() ;
; DG*5.3*1109 - If TYPE of Catastrophic Disability Reason is DESCRIPTOR then return HL7 TRANSMISSION VALUE, otherwise return -1
; Avoid an undefined DG2717 variable error if DG2717 is not defined
I $G(DG2717)="" Q -1
;I $P(^DGEN(27.17,DG2717,0),U,2)="DE" Q $P(^DGEN(27.17,DG2717,0),U,4)
I $P($G(^DGEN(27.17,DG2717,0)),U,2)="DE" Q $P(^DGEN(27.17,DG2717,0),U,4)
Q -1
;
HLTOLIMB(HLVAL,D2) ; Convert HL7 transmission value to Limb code.
; HLVAL = HL7 text of "Affected Extremity" code.
; D2 = Secondary delimiter (for future expansion.)
; NOTE: D2 Parameter is ignored at present, but may be
; required in future if the sequence structure changes.
Q $P("RUE-RLE-LUE-LLE-BLE-BLU","-",+HLVAL)
LIMBTOHL(LIMB,D2) ; Convert Limb code to HL7 transmission value.
; LIMB = Affected Extremity code: RUE = Right Upper Extremity;
; LLE = Left Lower Extremity; also RLE and LUE.
; D2 = Secondary Delimiter to use in this HL7 sequence.
S D2=$S(11[$D(D2):D2,11[$D(HLECH):$E(HLECH),1:"~")
N NUMBER,HLVAL
I "-RUE-RLE-LUE-LLE-BLE-BLU-"'[("-"_LIMB_"-")!(LIMB["-") Q ""
S NUMBER=$L($P("-RUE-RLE-LUE-LLE-BLE-BLU","-"_LIMB_"-"),"-")
S HLVAL=NUMBER_D2_LIMB_D2_"VA0042"
Q HLVAL
PERMTOHL(NUMBER,D2) ; Convert Permanent Status Indicator to HL7 sequence.
; NUMBER = 1 for Permanent, 2 for Not Permanent, 3 for Unknown.
; D2 = Secondary Delimiter to use in this HL7 sequence.
S D2=$S(11[$D(D2):D2,11[$D(HLECH):$E(HLECH),1:"~")
N PERM,HLVAL
S PERM=$P("PERMANENT-NOT PERMANENT-UNKNOWN","-",NUMBER)
I PERM="" Q ""
S HLVAL=NUMBER_D2_PERM_D2_"VA0045"
Q HLVAL
METH2HL7(METHOD,D2) ; Convert Method of Determination to HL7 Transmission Value.
S D2=$S(11[$D(D2):D2,11[$D(HLECH):$E(HLECH),1:"~")
N METHS
S METHS="AUTOMATED RECORD REVIEW^MEDICAL RECORD REVIEW^PHYSICAL EXAMINATION"
I ".1.2.3."'[("."_METHOD_".") Q ""
Q METHOD_D2_$P(METHS,"^",METHOD)_D2_"VA0041"
;
ICDVER(CODESYS) ; DG*5.3*850
; determine if ICD-9 or ICD-10 CD should be used
; To be used in DIC(S) call from input transforms from 2.396;.01
; and 2.397;.01
; Requires DA(1) be defined
; output - the correct value in ICDIEN 9
; ^ICDS("C","10D",30)=""
; ^ICDS("C","ICD",1)=""
;
; ^ICDS("C","10P",31)=""
; ^ICDS("C","ICP",2)=""
; -- DDATE := date of decision
; DGar
; DDCDIS(DATE) := date of decision from Listman Screen, not saved yet
;
N DFN1,ICDIEN,DDATE,IMPDATE
S CODESYS=$S($G(CODESYS)="D":"10D",$G(CODESYS)="P":"10P",1:"10D")
S DFN1=$S($G(DA(1))'="":DA(1),$G(DFN)'="":DFN,1:"")
S DDATE=$P($G(^DPT(DFN1,.39)),"^",2) ;Date of decision
I $G(DGCDIS("DATE")) S DDATE=DGCDIS("DATE") ;called from code, date not stored yet
I DDATE="" S DDATE=DT
S IMPDATE=$P($$IMPDATE^DGPTIC10($G(CODESYS)),"^",1)
I CODESYS="10D" D
. I DDATE<IMPDATE S ICDIEN=1
. I DDATE'<IMPDATE S ICDIEN=30
I CODESYS="10P" D
. I DDATE<IMPDATE S ICDIEN=2
. I DDATE'<IMPDATE S ICDIEN=31
Q ICDIEN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENA5 9605 printed Sep 23, 2025@20:18:12 Page 2
DGENA5 ;ALB/EZ,CKN,TEJ,KUM - Enrollment API - CD Processing ;8/15/08 11:10am
+1 ;;5.3;Registration;**232,688,850,894,1109**;Aug 13, 1993;Build 13
+2 ;Phase II API's Related to Catastrophic Disability.
+3 ;
+4 ; The following variable names are used consistently in this routine:
+5 ; DFN = IEN in PATIENT file (#2).
+6 ; REASON = IEN in CATASTROPHIC DISABILITY REASONS file (#2).
+7 ; COND = Sub-ien PATIENT(#2) CD STATUS CONDITIONS field (#.398).
+8 ; SCORE = Score achieved by veteran on a test (#2, #.398, #1).
+9 ; PERM = Permanent Indicator (#2, #.398, #2).
+10 ; D2 = Secondary delimiter (optional.)
+11 ;
+12 ; Processing related to a patient (#2).
VCD(DFN) ; Veteran Catastrophically Disabled? (#.39)
+1 QUIT $PIECE($GET(^DPT(DFN,.39)),"^",6)
CONDHELP(DFN,COND) ; Display help text for a condition.
+1 ; Applies to the PATIENT file (#2) CD STATUS CONDITIONS field (#.398)
+2 ; Note - Help text stored in 27.17 CD REASONS.
+3 NEW REASON
+4 SET REASON=$$REASON(DFN,COND)
+5 DO HELP(REASON)
+6 QUIT
CONDINP(DFN,COND,SCORE) ; Validate a score entered by the user for a PATIENT.
+1 NEW REASON
+2 SET REASON=$$REASON(DFN,COND)
+3 QUIT $$VALID(REASON,SCORE)
CONDMET(DFN,COND) ; Determine whether a condition meets the criteria.
+1 NEW SCORE,PERM
+2 SET REASON=$$REASON(DFN,COND)
+3 SET SCORE=$$PATSCORE(DFN,COND)
+4 SET PERM=$$PATPERM(DFN,COND)
+5 QUIT $$RANGEMET(REASON,SCORE,PERM)
+6 ; Patient Field Lookup.
REASON(DFN,COND) ; Get the CD REASON for this patient, for this condition.
+1 NEW REASON
+2 IF DFN=""!(COND="")
Begin DoDot:1
+3 SET REASON=$GET(DGCDREAS)
+4 IF REASON=""
IF $GET(ITEM)'=""
SET REASON=$GET(DGCDIS("COND",ITEM))
End DoDot:1
+5 IF '$TEST
SET REASON=$PIECE($GET(^DPT(DFN,.398,COND,0)),"^",1)
+6 QUIT REASON
PATSCORE(DFN,COND) ; Get the TEST SCORE for this patient, for this condition.
+1 NEW REASON
+2 IF DFN=""!(COND="")
QUIT ""
+3 SET REASON=$PIECE($GET(^DPT(DFN,.398,COND,0)),"^",2)
+4 QUIT REASON
PATPERM(DFN,COND) ; Get the PERMANENT INDICATOR for this patient+condition.
+1 NEW REASON
+2 IF DFN=""!(COND="")
QUIT ""
+3 SET REASON=$PIECE($GET(^DPT(DFN,.398,COND,0)),"^",3)
+4 QUIT REASON
+5 ; Processing related to catastrophic disability reasons (#27.17)
HELP(REASON) ; Display help text from 27.17 CD REASONS.
+1 NEW LINE
+2 if $$TYPE(REASON)'="C"
QUIT
+3 SET LINE=0
+4 WRITE !,"HELP TEXT FOR ",$$NAME(REASON),!
+5 FOR
SET LINE=$ORDER(^DGEN(27.17,REASON,3,LINE))
if 'LINE
QUIT
Begin DoDot:1
+6 WRITE ?3,^DGEN(27.17,REASON,3,LINE,0),!
End DoDot:1
+7 QUIT
VALID(REASON,SCORE) ; Validate a proposed score for a test.
+1 NEW TEST,X
+2 SET TEST=$$VALSCORE(REASON)
+3 SET X=SCORE
+4 IF @TEST
QUIT 1
+5 QUIT 0
RANGEMET(REASON,SCORE,PERM) ; Determine whether this reason is satisfied.
+1 NEW TEST
+2 SET TEST=$$RANGE(REASON)
+3 IF @TEST
QUIT 1
+4 QUIT 0
+5 ; APIs to access CD REASONS file.
NAME(REASON) ; Return NAME (.01) for this CD REASON.
+1 if 'REASON
QUIT ""
+2 QUIT $PIECE($GET(^DGEN(27.17,REASON,0)),"^",1)
TYPE(REASON) ; Return TYPE (#1) for this CD REASON.
+1 if 'REASON
QUIT ""
+2 QUIT $PIECE($GET(^DGEN(27.17,REASON,0)),"^",2)
VALSCORE(REASON) ; Return VALIDATION (#7) for this CD REASON.
+1 ; This determines whether a score is valid at all.
+2 QUIT $GET(^DGEN(27.17,REASON,4))
RANGE(REASON) ; Return TEST SCORE RANGE (#5) for this CD REASON.
+1 ; This determines whether the score qualifies for CD.
+2 QUIT $GET(^DGEN(27.17,REASON,2))
FILENAME(REASON) ; Return the file name to which this CD Reason points.
+1 NEW CODEPTR,DIC,DO
+2 SET U=$GET(U,"^")
+3 SET CODEPTR=$$CODEPTR(REASON)
+4 IF CODEPTR=""
QUIT ""
+5 SET DIC="^"_$PIECE(CODEPTR,";",2)
+6 SET DIC(0)=""
+7 DO DO^DIC1
+8 QUIT $PIECE(DO,"^",1)
CODE(REASON) ; Return the HL7 Transmission Code for this CD Reason.
+1 if 'REASON
QUIT ""
+2 QUIT $PIECE($GET(^DGEN(27.17,REASON,0)),"^",4)
CODENAME(REASON) ; Return name of code associated with this CD Reason.
+1 NEW CODEPTR,CODEIEN,CODEGLO,CODEPC,CODENAME,CODE
+2 SET CODEPTR=$$CODEPTR(REASON)
+3 IF CODEPTR=""
QUIT ""
+4 SET CODEIEN=$PIECE(CODEPTR,";",1)
+5 SET CODEGLO=$PIECE(CODEPTR,";",2)
+6 SET CODEPC=$SELECT(CODEGLO="ICD9(":3,CODEGLO="ICD0(":4,CODEGLO="ICPT(":2)
+7 SET CODEGLO="^"_CODEGLO_CODEIEN_",0)"
+8 SET CODE=$PIECE(@CODEGLO,"^",1)
+9 SET CODENAME=$PIECE(@CODEGLO,"^",CODEPC)
+10 QUIT CODENAME
CODEPTR(REASON) ; Internal label--get pointer to CODE.
+1 QUIT $PIECE($GET(^DGEN(27.17,REASON,0)),"^",3)
LSCREEN(LIMBCODE) ; Used to validate LIMB in screen.
+1 NEW REASON
+2 SET REASON=""
+3 IF $GET(D0)=""!($GET(D1)="")
Begin DoDot:1
+4 SET REASON=$GET(DGCDREAS)
+5 IF REASON=""
IF $GET(ITEM)'=""
SET REASON=$GET(DGCDIS("PROC",ITEM))
End DoDot:1
+6 IF '$TEST
SET REASON=$PIECE($GET(^DPT(D0,.397,D1,0)),"^",1)
+7 IF REASON=""
QUIT ".RUE.LUE.RLE.LLE.BLE.BLU."[("."_LIMBCODE_".")
+8 QUIT $$LIMBOK(REASON,LIMBCODE)
LIMBOK(REASON,LIMBCODE) ; Return 1/0 Affected Extremity OK for this REASON.
+1 NEW LIMBIEN,VALID
+2 SET VALID=0
+3 SET LIMBIEN=0
+4 FOR
SET LIMBIEN=$$NEXTLIMB(REASON,LIMBIEN)
if 'LIMBIEN
QUIT
Begin DoDot:1
+5 IF $$LIMBCODE(REASON,LIMBIEN)=LIMBCODE
SET VALID=1
End DoDot:1
if VALID
QUIT
+6 QUIT VALID
NEXTLIMB(REASON,LIMBIEN) ; Get next possible limb for this REASON.
+1 IF 'LIMBIEN
SET LIMBIEN=0
+2 SET LIMBIEN=$ORDER(^DGEN(27.17,REASON,1,LIMBIEN))
+3 IF 'LIMBIEN
SET LIMBIEN=""
+4 QUIT LIMBIEN
LIMBCODE(REASON,LIMBIEN) ; Return limb code for an affected limb.
+1 QUIT $PIECE($GET(^DGEN(27.17,REASON,1,LIMBIEN,0)),"^",1)
+2 ; HL7-related changes.
HL7TORSN(HL7VAL,D2) ; Return REASON IEN for a HL7 Transmission Value.
+1 ; This function returns the IEN or 0 if there is none.
+2 SET D2=$SELECT(11[$DATA(D2):D2,11[$DATA(HLECH):$EXTRACT(HLECH),1:"~")
+3 IF $PIECE("KATZ^FOLS^RUG3^FIM^GAF","^",$PIECE(HL7VAL,D2,1))=$PIECE(HL7VAL,D2,2)
Begin DoDot:1
+4 SET HL7VAL=$PIECE("KATZ^FOLS^RUG3^FIM^GAF","^",+HL7VAL)
End DoDot:1
+5 IF '$TEST
SET HL7VAL=$PIECE(HL7VAL,D2)
+6 if HL7VAL=""
QUIT 0
+7 QUIT +$ORDER(^DGEN(27.17,"C",HL7VAL,""))
+8 ; * check the new DESCRIPTOR seq - DG*5.3*894
HL7TODSC(HL7VAL,D2) ; Return DESCRIPTOR IEN for a HL7 Transmission Value.
+1 ; This function returns the IEN or 0 if there is none.
+2 if HL7VAL=""
QUIT 0
+3 QUIT +$ORDER(^DGEN(27.17,"C",HL7VAL,""))
RSNTOHL7(REASON,D2) ; Return HL7 Segment Value for this Reason.
+1 if REASON=""
QUIT 0
+2 SET D2=$SELECT(11[$DATA(D2):D2,11[$DATA(HLECH):$EXTRACT(HLECH),1:"~")
+3 NEW NAME,NUMBER,TABLE,FILE,CODE,HL7VAL
+4 ;DG*5.3*1109 - Initialize HL7VAL to avoid hard error if REASON doesn't exist in #27.17
+5 SET HL7VAL=""
+6 IF $$TYPE(REASON)="C"
Begin DoDot:1
+7 SET CODE=$$CODE(REASON)
+8 if CODE=""
QUIT
+9 SET NUMBER=$LENGTH($PIECE("KATZ^FOLS^RUG3^FIM^GAF^",CODE),"^")
+10 if NUMBER>5
QUIT
+11 SET TABLE="VA0043"
+12 SET HL7VAL=NUMBER_D2_CODE_D2_TABLE
End DoDot:1
+13 IF '$TEST
Begin DoDot:1
+14 SET NAME=$$NAME(REASON)
+15 if NAME=""
QUIT
+16 SET CODE=$$CODE(REASON)
+17 if CODE=""
QUIT
+18 SET FILE=$$FILENAME(REASON)
+19 if FILE=""
QUIT
+20 SET HL7VAL=CODE_D2_NAME_D2_FILE
End DoDot:1
+21 ; NOTE: an undefined variable error on the following line may
+22 ; result, if someone has tampered with the CATASTROPHIC
+23 ; DISABILITY REASONS file (#27.17).
+24 QUIT HL7VAL
+25 ; * check the new DESCRIPTOR seq - DG*5.3*894
DSCR2HL7(DGDFN,D2) ; Return HL7 Sequence Value for all Descriptors.
+1 SET DG2=DGDFN
+2 SET DGHLENCD="~|\&"
+3 KILL DGTMP,DSCRTOHL7
+4 MERGE DGTMP=^DPT(DG2,.401)
+5 IF $DATA(DGTMP)
SET (I1,I2)=0
FOR
SET I1=$ORDER(DGTMP(I1))
SET I2=I2+1
if +I1=0
QUIT
SET DG2717=+DGTMP(I1,0)
SET $PIECE(DSCRTOHL7,$EXTRACT(DGHLENCD,2),I2)=$$TOHL7()
+6 QUIT $GET(DSCRTOHL7,0)
TOHL7() ;
+1 ; DG*5.3*1109 - If TYPE of Catastrophic Disability Reason is DESCRIPTOR then return HL7 TRANSMISSION VALUE, otherwise return -1
+2 ; Avoid an undefined DG2717 variable error if DG2717 is not defined
+3 IF $GET(DG2717)=""
QUIT -1
+4 ;I $P(^DGEN(27.17,DG2717,0),U,2)="DE" Q $P(^DGEN(27.17,DG2717,0),U,4)
+5 IF $PIECE($GET(^DGEN(27.17,DG2717,0)),U,2)="DE"
QUIT $PIECE(^DGEN(27.17,DG2717,0),U,4)
+6 QUIT -1
+7 ;
HLTOLIMB(HLVAL,D2) ; Convert HL7 transmission value to Limb code.
+1 ; HLVAL = HL7 text of "Affected Extremity" code.
+2 ; D2 = Secondary delimiter (for future expansion.)
+3 ; NOTE: D2 Parameter is ignored at present, but may be
+4 ; required in future if the sequence structure changes.
+5 QUIT $PIECE("RUE-RLE-LUE-LLE-BLE-BLU","-",+HLVAL)
LIMBTOHL(LIMB,D2) ; Convert Limb code to HL7 transmission value.
+1 ; LIMB = Affected Extremity code: RUE = Right Upper Extremity;
+2 ; LLE = Left Lower Extremity; also RLE and LUE.
+3 ; D2 = Secondary Delimiter to use in this HL7 sequence.
+4 SET D2=$SELECT(11[$DATA(D2):D2,11[$DATA(HLECH):$EXTRACT(HLECH),1:"~")
+5 NEW NUMBER,HLVAL
+6 IF "-RUE-RLE-LUE-LLE-BLE-BLU-"'[("-"_LIMB_"-")!(LIMB["-")
QUIT ""
+7 SET NUMBER=$LENGTH($PIECE("-RUE-RLE-LUE-LLE-BLE-BLU","-"_LIMB_"-"),"-")
+8 SET HLVAL=NUMBER_D2_LIMB_D2_"VA0042"
+9 QUIT HLVAL
PERMTOHL(NUMBER,D2) ; Convert Permanent Status Indicator to HL7 sequence.
+1 ; NUMBER = 1 for Permanent, 2 for Not Permanent, 3 for Unknown.
+2 ; D2 = Secondary Delimiter to use in this HL7 sequence.
+3 SET D2=$SELECT(11[$DATA(D2):D2,11[$DATA(HLECH):$EXTRACT(HLECH),1:"~")
+4 NEW PERM,HLVAL
+5 SET PERM=$PIECE("PERMANENT-NOT PERMANENT-UNKNOWN","-",NUMBER)
+6 IF PERM=""
QUIT ""
+7 SET HLVAL=NUMBER_D2_PERM_D2_"VA0045"
+8 QUIT HLVAL
METH2HL7(METHOD,D2) ; Convert Method of Determination to HL7 Transmission Value.
+1 SET D2=$SELECT(11[$DATA(D2):D2,11[$DATA(HLECH):$EXTRACT(HLECH),1:"~")
+2 NEW METHS
+3 SET METHS="AUTOMATED RECORD REVIEW^MEDICAL RECORD REVIEW^PHYSICAL EXAMINATION"
+4 IF ".1.2.3."'[("."_METHOD_".")
QUIT ""
+5 QUIT METHOD_D2_$PIECE(METHS,"^",METHOD)_D2_"VA0041"
+6 ;
ICDVER(CODESYS) ; DG*5.3*850
+1 ; determine if ICD-9 or ICD-10 CD should be used
+2 ; To be used in DIC(S) call from input transforms from 2.396;.01
+3 ; and 2.397;.01
+4 ; Requires DA(1) be defined
+5 ; output - the correct value in ICDIEN 9
+6 ; ^ICDS("C","10D",30)=""
+7 ; ^ICDS("C","ICD",1)=""
+8 ;
+9 ; ^ICDS("C","10P",31)=""
+10 ; ^ICDS("C","ICP",2)=""
+11 ; -- DDATE := date of decision
+12 ; DGar
+13 ; DDCDIS(DATE) := date of decision from Listman Screen, not saved yet
+14 ;
+15 NEW DFN1,ICDIEN,DDATE,IMPDATE
+16 SET CODESYS=$SELECT($GET(CODESYS)="D":"10D",$GET(CODESYS)="P":"10P",1:"10D")
+17 SET DFN1=$SELECT($GET(DA(1))'="":DA(1),$GET(DFN)'="":DFN,1:"")
+18 ;Date of decision
SET DDATE=$PIECE($GET(^DPT(DFN1,.39)),"^",2)
+19 ;called from code, date not stored yet
IF $GET(DGCDIS("DATE"))
SET DDATE=DGCDIS("DATE")
+20 IF DDATE=""
SET DDATE=DT
+21 SET IMPDATE=$PIECE($$IMPDATE^DGPTIC10($GET(CODESYS)),"^",1)
+22 IF CODESYS="10D"
Begin DoDot:1
+23 IF DDATE<IMPDATE
SET ICDIEN=1
+24 IF DDATE'<IMPDATE
SET ICDIEN=30
End DoDot:1
+25 IF CODESYS="10P"
Begin DoDot:1
+26 IF DDATE<IMPDATE
SET ICDIEN=2
+27 IF DDATE'<IMPDATE
SET ICDIEN=31
End DoDot:1
+28 QUIT ICDIEN
