Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGENA5

DGENA5.m

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