DGENA5 ;ISA/Zoltan,ALB/CKN - Enrollment API - CD Processing ; 8/15/08 11:10am
;;5.3;PIMS;**232,1015,1016**;JUN 30, 2012;Build 20
;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."[("."_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,""))
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
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
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","-",+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-"'[("-"_LIMB_"-")!(LIMB["-") Q ""
S NUMBER=$L($P("-RUE-RLE-LUE-LLE-","-"_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) ; Comvert 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"
DGENA5 ;ISA/Zoltan,ALB/CKN - Enrollment API - CD Processing ; 8/15/08 11:10am
+1 ;;5.3;PIMS;**232,1015,1016**;JUN 30, 2012;Build 20
+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."[("."_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,""))
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 IF $$TYPE(REASON)="C"
Begin DoDot:1
+5 SET CODE=$$CODE(REASON)
+6 IF CODE=""
QUIT
+7 SET NUMBER=$LENGTH($PIECE("KATZ^FOLS^RUG3^FIM^GAF^",CODE),"^")
+8 IF NUMBER>5
QUIT
+9 SET TABLE="VA0043"
+10 SET HL7VAL=NUMBER_D2_CODE_D2_TABLE
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 SET NAME=$$NAME(REASON)
+13 IF NAME=""
QUIT
+14 SET CODE=$$CODE(REASON)
+15 IF CODE=""
QUIT
+16 SET FILE=$$FILENAME(REASON)
+17 IF FILE=""
QUIT
+18 SET HL7VAL=CODE_D2_NAME_D2_FILE
End DoDot:1
+19 ; NOTE: an undefined variable error on the following line may
+20 ; result, if someone has tampered with the CATASTROPHIC
+21 ; DISABILITY REASONS file (#27.17).
+22 QUIT HL7VAL
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","-",+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-"'[("-"_LIMB_"-")!(LIMB["-")
QUIT ""
+7 SET NUMBER=$LENGTH($PIECE("-RUE-RLE-LUE-LLE-","-"_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) ; Comvert 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"
