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