BTIULO2 ; IHS/ITSC/LJF - MORE TIU OBJECTS ;06-Aug-2018 16:28;DU
;;1.0;TEXT INTEGRATION UTILITIES;**1001,1002,1006,1020**;NOV 04, 2004;Build 7
;IHS/IHTSC/LJF 4/28/2005 PATCH 1002 added EP; to MCR and MCD entry points
;1006 check for invalid visit
;1020 added new lookup for medicare and railroad numbers
;
CURDIET(DFN,VST) ;EP; returns patient's current diet for visit
NEW ADM,Y
S ADM=$$PMV^BTIUU1(VST,DFN),Y=""
I ADM<1 Q "Current Diet: No current order"
I $L($T(CUR^FHORD7)) D CUR^FHORD7
Q "Current Diet: "_$S(Y]"":Y,1:"No current order")
;
FOODADR(DFN) ;EP; returns food allergies and ADRs
NEW GMRA,GMRAL,X,ALLRG,ADR,Y,Z,TIUY,COUNT
K ^TMP("BTIULO",$J)
S GMRA="0^0^010" D EN1^GMRADPT
I GMRAL="" Q "Allergies/ADRs: Unknown"
I GMRAL=0 D Q X
. S Z="Allergies/ADRs: "
. S Y=$O(GMRAL(0)) I Y S X=$P(GMRAL(Y),U,2) I X]"" S X=Z_X Q
. S X=Z_"None found in system"
;
S (ALLRG,ADR)=""
S X=0 F S X=$O(GMRAL(X)) Q:'X D
. I $P(GMRAL(X),U,5)=0 S ALLRG=ALLRG_$P(GMRAL(X),U,2)_"; " Q
. S ADR=ADR_$P(GMRAL(X),U,2)_"; "
S ALLRG=$S(ALLRG="":"None found",1:$P(ALLRG_";","; ;"))
S ADR=$S(ADR="":"None found",1:$P(ADR_";","; ;"))
S X="Food Allergies: "_ALLRG_"; AdvReac: "_ADR S TIUY=$$WRAP^TIULS(X,73)
F COUNT=1:1 Q:$P(TIUY,"|",COUNT)="" S ^TMP("BTIULO",$J,COUNT,0)=$P(TIUY,"|",COUNT)
Q "~@^TMP(""BTIULO"",$J)"
;
;
LASTIMM(DFN,TIUIMM,TIUNM) ;EP -- returns last immunization date
; TIUIMM=HL7 codes separated by ^ then generic name at end after ;
; example TIUIMM="2^10^89;Polio Vax"
; TIUNM=1 to return imm name; =0 to just return date
; TIUDE will be set to iens in BI Table Data Elements file
; TIUDATA "|" pieces within each "^" will be
; IEN PIECE
;---> 1 = Visit Type: "I"=Immunization, "S"=Skin Test.
;---> 9 2 = Vaccine Name, Long
;---> 25 3 = HL7 code for immunization
;---> 56 4 = Date of Visit Fileman format (YYYMMDD).
;
NEW I,TIUDE,TIUANS,X,TIUCODE,TIUDATA
Q:'$G(DFN) Q:'$G(TIUIMM)
; -- set all codes sent into array
F I=1:1 S X=$P(TIUIMM,U,I) Q:'X S TIUCODE(+X)=""
; -- set data elements to return
F I=9,25,56 S TIUDE(I)=""
; -- get imm hx from imm app
D IMMHX^BIRPC(.TIUDATA,DFN,.TIUDE)
; -- evaluate results
K TIUANS F I=1:1 S X=$P(TIUDATA,U,I) Q:X="" D
. Q:$P(X,"|")'="I" ;not immunization
. Q:'$D(TIUCODE($P(X,"|",3))) ;not in imm set sent
. I '$D(TIUANS) S TIUANS=X Q ;set first imm found
. I $P(TIUANS,"|",4)<$P(X,"|",4) S TIUANS=X ;keep latest date
; -- return results
I '$D(TIUANS) Q $S(TIUNM:"Last "_$P(TIUIMM,";",2)_": ",1:"")_"None Recorded"
Q $S(TIUNM:"Last "_$P(TIUANS,"|",2)_": ",1:"")_$$FMTE^XLFDT($P(TIUANS,"|",4))
;
;
IMMDUE(DFN,TARGET) ;EP; -- returns immunizations due (via Immunization app)
NEW TIUIMM,TIUCAP,TIU31,ERROR,TIUX,TIUY,CNT,X
S TIUCAP="Immunizations Due: "
I '$G(DFN) Q TIUCAP_"?? patient unknown"
I '$L($T(IMMFORC^BIRPC)) Q TIUCAP_"Unknown; Immunization v7.1 not installed"
;
D IMMFORC^BIRPC(.TIUIMM,DFN)
;
S TIU31=$C(31)_$C(31)
;--- Check for error in 2nd piece of return value.
S ERROR=$P(TIUIMM,TIU31,2) I ERROR]"" Q TIUCAP_ERROR
;
;--- If no error, so take 1st piece of return value and process it.
S TIUIMM=$P(TIUIMM,TIU31,1) K @TARGET
;
NEW TIUX,TIUY F TIUX=1:1 S TIUY=$P(TIUIMM,U,TIUX) Q:TIUY="" D
. S X=$P(TIUY,"|") S:$P(TIUY,"|",2)]"" X=X_" ("_$P(TIUY,"|",2)_$P(TIUY,"|",3)_")"
. S CNT=$G(CNT)+1 I CNT=1 S @TARGET@(1,0)="Immunizations Due: "_X Q
. S @TARGET@(CNT,0)=$$SP(17)_X
;
Q "~@"_$NA(@TARGET)
;
LASTSK(DFN,TIUSK) ;EP -- returns last skin test date and result
; TIUSK=skin test name
; TIUDE will be set to iens in BI Table Data Elements file
; TIUDATA "|" pieces within each "^" will be
; IEN PIECE
;---> 1 = Visit Type: "I"=Immunization, "S"=Skin Test.
;---> 38 2 = Skin Test Result
;---> 40 3 = Skin Test - Date Read in DD-mmm_YYYY format.
;---> 41 4 = Skin Test Name
;
NEW I,TIUDE,TIUANS,X
Q:'$G(DFN) Q:'$G(TIUIMM)
; -- set data elements to return
F I=38,40,41 S TIUDE(I)=""
; -- get imm hx from imm app
D IMMHX^BIRPC(.TIUDATA,DFN,.TIUDE)
; -- evaluate results
K TIUANS F I=1:1 S TIUX=$P(TIUDATA,U,I) Q:TIUX="" D
. Q:$P(TIUX,"|")'="S" ;not skin test
. Q:$P(TIUX,"|",4)'=TIUSK ;not test type sent
. S X=$P(TIUX,"|",3) D ^%DT S $P(TIUX,"|",5)=Y ;need FM date format
. I '$D(TIUANS) S TIUANS=TIUX Q ;set first one found
. I $P(TIUANS,"|",5)<$P(TIUX,"|",5) S TIUANS=TIUX ;keep latest date
; -- return results
I '$D(TIUANS) Q "Last "_TIUSK_": None Recorded"
Q "Last "_TIUSK_": "_$P(TIUANS,"|",3)_" - "_$P(TIUANS,"|",38)
;
;
LASTPAP(DFN) ;EP; -- returns last pap date and result
NEW N,Y,BW,DATE,LINE
I $P(^DPT(DFN,0),U,2)="M" Q ""
S N=0 F S N=$O(^BWPCD("C",DFN,N)) Q:'N D
.S Y=^BWPCD(N,0)
.I $P(Y,U,4)=1 S DATE=$P(Y,U,12) D
..S BW("PAP",9999999-DATE)=DATE_U_$P(Y,U,5)_U_N
I '$D(BW("PAP")) Q "No PAP on record"
S N=$O(BW("PAP",0)) I 'N Q "No PAP on record"
S N=BW("PAP",N),LINE="Last PAP: "_$$FMTE^XLFDT(+N,"5D")
S LINE=LINE_" Result - "_$$GET1^DIQ(9002086.31,$P(N,U,2),.01)
S LINE=LINE_" ("_$$GET1^DIQ(9002086.1,$P(N,U,3),.14)_")"
Q LINE
;
LASTMAM(DFN) ;EP; -- returns last mammogram date and result
NEW N,Y,BW,DATE,LINE,X
I $P(^DPT(DFN,0),U,2)="M" Q ""
S N=0 F S N=$O(^BWPCD("C",DFN,N)) Q:'N D
. S Y=^BWPCD(N,0)
. S X=+$P(Y,U,4) I (X'=25)&(X'=26)&(X'=28) Q ;mamo iens are 25,26,28
. S DATE=$P(Y,U,12)
. S BW("MAM",9999999-DATE)=DATE_U_$P(Y,U,5)_U_N_U_$P(Y,U,4)
I '$D(BW("MAM")) Q "No Mammogram on record"
S N=$O(BW("MAM",0)) I 'N Q "No Mammogram on record"
S N=BW("MAM",N)
S LINE="Last "_$$GET1^DIQ(9002086.2,$P(N,U,4),.01)_": "
S LINE=LINE_$$FMTE^XLFDT(+N,"5D")
S LINE=LINE_" Result - "_$$GET1^DIQ(9002086.31,+$P(N,U,2),.01)
S LINE=LINE_" ("_$$GET1^DIQ(9002086.1,$P(N,U,3),.14)_")"
Q LINE
;
;
;
VSTINS(DFN,VISIT) ;EP; returns insurance coverage at visit time
NEW VDT,LINE,PVT
I ('$G(DFN))!('$G(VISIT)) Q "Invalid visit"
S LINE="",VDT=+$G(^AUPNVSIT(VISIT,0)) I 'VDT Q LINE
I $$MCR^AUPNPAT(DFN,VDT)=1 S LINE="MEDICARE #"_$$MCR2(DFN)_"/"
I $$MCD^AUPNPAT(DFN,VDT)=1 S LINE=LINE_"MEDICAID #"_$$MCD(DFN)_"/"
;I $$PI^AUPNPAT(DFN,VDT)=1 S LINE=LINE_"PVT INS ("_$$PIN^AUPNPAT(DFN,VDT,"E")_")/"
I $$PI^AUPNPAT(DFN,VDT)=1 S PVT=$$THIRD(DFN) S LINE=LINE_"PVT INS ("_PVT_")/"
I $$RR^AUPNPAT(DFN,VDT)=1 S LINE=LINE_"RR INS #"_$$GETRRE^AGUTL(DFN,VDT)_")/"
Q $S(LINE="":"",1:$E(LINE,1,$L(LINE)-1))
;
POLICY(DFN,VISIT) ; EP; returns prvt insurance policy number at visit time
NEW INSUR,IEN,PVT
S PVT=""
S INSUR=$$PIN^AUPNPAT(DFN,VISIT,"I"),IEN=0
I INSUR S PVT=$$THIRD(DFN)
Q PVT
;S IEN=$O(^AUPNPRVT(DFN,11,"B",INSUR,0))
;I IEN Q "#"_$P($G(^AUPNPRVT(DFN,11,IEN,0)),U,2)
Q ""
MCR(DFN) ;EP; returns medicare number for patient
NEW IEN
S IEN=$$GETMCR^AGUTL(DFN)
I IEN'="" Q IEN
S IEN=$O(^AUPNMCR("B",DFN,0)) I 'IEN Q "??"
Q $P($G(^AUPNMCR(IEN,0)),U,3)
;
MCR2(DFN) ;EP; returns medicare number for patient
NEW IEN,NUMBER,TYPE,IEN2,MCARE,COV,DNAME,INS
S MCARE=""
S NUMBER=$$GETMCR^AGUTL(DFN)
;I '+NUMBER D
;.S IEN=$O(^AUPNMCR("B",DFN,0))
;.S NUMBER=$P($G(^AUPNMCR(IEN,0)),U,3)
S IEN2=0 F S IEN2=$O(^AUPNMCR(DFN,11,IEN2)) Q:'+IEN2 D
.S DATA=$G(^AUPNMCR(DFN,11,IEN2,0))
.S EXP=$P(DATA,U,2)
.Q:(+EXP)&(EXP<DT)
.S COV=$P(DATA,U,3)
.I COV="A"!(COV="B") S DNAME="Part "_COV_"-"_NUMBER
.I COV="D" D
..S INS=$$GET1^DIQ(9999999.18,$P(DATA,U,4),.01)
..S DNAME="Part "_COV_" "_INS_"-"_$P(DATA,U,6)
.I MCARE="" S MCARE=DNAME
.E S MCARE=MCARE_";"_DNAME
Q MCARE
RRE(DFN) ;EP; returns railroad number for patient
NEW IEN,NUMBER,TYPE,IEN2,RRE,COV,DNAME,INS
S RRE=""
S NUMBER=$$GETRRE^AGUTL(DFN)
S IEN2=0 F S IEN2=$O(^AUPNRRE(DFN,11,IEN2)) Q:'+IEN2 D
.S DATA=$G(^AUPNRRE(DFN,11,IEN2,0))
.S EXP=$P(DATA,U,2)
.Q:(+EXP)&(EXP<DT)
.S COV=$P(DATA,U,3)
.I COV="A"!(COV="B") S DNAME="Part "_COV_"-"_NUMBER
.I COV="D" D
..S INS=$$GET1^DIQ(9999999.18,$P(DATA,U,4),.01)
..S DNAME="Part "_COV_" "_INS_"-"_$P(DATA,U,6)
.I RRE="" S RRE=DNAME
.E S RRE=RRE_";"_DNAME
Q RRE
MCD(DFN) ;EP; returns medicaid number for patient
NEW IEN
S IEN=$O(^AUPNMCD("B",DFN,0)) I 'IEN Q "??"
Q $P($G(^AUPNMCD(IEN,0)),U,3)
THIRD(DFN) ;EP returns third party insurance
NEW IEN,TYPE,DATA,NAME,NUMBER,PVT,EXP
S PVT=""
S TYPE="" F S TYPE=$O(^AUPNPRVT(DFN,11,"B",TYPE)) Q:'+TYPE D
.S IEN="" F S IEN=$O(^AUPNPRVT(DFN,11,"B",TYPE,IEN)) Q:'+IEN D
..S DATA=$G(^AUPNPRVT(DFN,11,IEN,0))
..S EXP=$P(DATA,U,7)
..Q:(+EXP)&(EXP<DT)
..Q:DATA=""
..S NAME=$$GET1^DIQ(9999999.18,$P(DATA,U,1),.01)
..S NUMBER=$P($G(^AUPNPRVT(DFN,11,IEN,2)),U,1)
..;following code looks at the Member Number field of Insurer multiple.
..;from Policy Holder File
..I NUMBER="" D
...I +$P(DATA,U,8) S NUMBER=$P($G(^AUPN3PPH($P(DATA,U,8),0)),U,4)
..I PVT="" S PVT=NAME_"-"_NUMBER
..E S PVT=PVT_";"_NAME_"-"_NUMBER
Q PVT
;
LASTEXAM(DFN,CODE) ;EP; returns last V Exam date and result
; CODE=unique code from exam file or exam name
NEW EXAM,DATE,RESULT,N,SUB
S SUB=$S($L(CODE)=2:"C",1:"B") ;was code or name sent
S EXAM=$O(^AUTTEXAM(SUB,CODE,0)) I EXAM="" Q ""
S DATE=$O(^AUPNVXAM("AA",+$G(DFN),EXAM,0)) I DATE="" Q "None Found"
S RESULT="Date: "_$$FMTE^XLFDT(9999999-DATE,"D")
S N=$O(^AUPNVXAM("AA",DFN,EXAM,DATE,0)) I 'N Q RESULT_" Results: No Results"
Q RESULT_" Results: "_$$GET1^DIQ(9000010.13,N,.04)
;
LASTHF(DFN,NAME) ;EP; returns last V Health Factor
; NAME = exact name of health factor in file
NEW FACTOR,DATE,RESULT,N
S RESULT=NAME_": "
S FACTOR=$O(^AUTTHF("B",NAME,0)) I 'FACTOR Q ""
S DATE=$O(^AUPNVHF("AA",+$G(DFN),FACTOR,0)) I DATE="" Q RESULT_"Not Found"
S RESULT=RESULT_$$FMTE^XLFDT(9999999-DATE,"D")
S N=$O(^AUPNVHF("AA",DFN,FACTOR,DATE,0)) I 'N Q RESULT
S X=$$GET1^DIQ(9000010.23,N,.04) ;severity level
;Q RESULT_$S(X]"":" Level: "_$$GET1^DIQ(9000010.13,N,.04),1:"")
Q RESULT_$S(X]"":" Level: "_X,1:"") ;IHS/ITSC/LJF 12/10/2004 PATCH 1001 typo, file is .23 not .13
;
LSTHFALL(TARGET,DFN) ;EP; returns last occurence for ALL V Health Factors for patient
NEW FACTOR,DATE,RESULT,N
S DATE=$O(^AUPNVHF("AA",+$G(DFN),FACTOR,0)) I DATE="" Q RESULT_"Not Found"
S RESULT=RESULT_$$FMTE^XLFDT(9999999-DATE,"D")
S N=$O(^AUPNVHF("AA",DFN,FACTOR,DATE,0)) I 'N Q RESULT
S X=$$GET1^DIQ(9000010.23,N,.04) ;severity level
Q RESULT_$S(X]"":" Level: "_$$GET1^DIQ(9000010.13,N,.04),1:"")
Q "~@"_$NA(@TARGET)
;
PTADDRS(DFN) ;EP; returns patient's current address
NEW CNT,LINE,FIELD
I '$G(DFN) Q ""
K ^TMP("BTIULO",$J)
S CNT=0 F FIELD=.111:.001:.116 D
. S LINE=$$GET1^DIQ(2,DFN,FIELD) Q:LINE=""
. I FIELD<.115 S CNT=CNT+1 ;separate lines for street address portion
. S ^TMP("BTIULO",$J,CNT,0)=$G(^TMP("BTIULO",$J,CNT,0))_LINE_" "
I '$D(^TMP("BTIULO",$J)) Q "No Current Address Found"
Q "~@^TMP(""BTIULO"",$J)"
;
PHONE(DFN) ;EP; -- returns patient's current phone numbers
NEW HOME,OFFICE
Q:'$G(DFN)
S HOME=$$GET1^DIQ(2,DFN,.131) S:HOME]"" HOME=HOME_" (home)"
S OFFICE=$$GET1^DIQ(2,DFN,.132) S:OFFICE]"" OFFICE=OFFICE_" (office)"
I HOME="",OFFICE="" S HOME="No Phone in record"
Q HOME_$S(HOME="":"",OFFICE="":"",1:"/")_OFFICE
;
ELIG(DFN) ;EP; -- returns patient's Eligebility Status
N ELIG
Q:'$G(DFN)
S ELIG=$$GET1^DIQ(9000001,DFN,1112)
Q "ELIGIBILITY STATUS: "_$S(ELIG]"":ELIG,1:"??")
;
PAD(DATA,LENGTH) ; pad length of data
Q $E(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)
;
SP(NUM) ; pad spaces
Q $$PAD(" ",NUM)
BTIULO2 ; IHS/ITSC/LJF - MORE TIU OBJECTS ;06-Aug-2018 16:28;DU
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1001,1002,1006,1020**;NOV 04, 2004;Build 7
+2 ;IHS/IHTSC/LJF 4/28/2005 PATCH 1002 added EP; to MCR and MCD entry points
+3 ;1006 check for invalid visit
+4 ;1020 added new lookup for medicare and railroad numbers
+5 ;
CURDIET(DFN,VST) ;EP; returns patient's current diet for visit
+1 NEW ADM,Y
+2 SET ADM=$$PMV^BTIUU1(VST,DFN)
SET Y=""
+3 IF ADM<1
QUIT "Current Diet: No current order"
+4 IF $LENGTH($TEXT(CUR^FHORD7))
DO CUR^FHORD7
+5 QUIT "Current Diet: "_$SELECT(Y]"":Y,1:"No current order")
+6 ;
FOODADR(DFN) ;EP; returns food allergies and ADRs
+1 NEW GMRA,GMRAL,X,ALLRG,ADR,Y,Z,TIUY,COUNT
+2 KILL ^TMP("BTIULO",$JOB)
+3 SET GMRA="0^0^010"
DO EN1^GMRADPT
+4 IF GMRAL=""
QUIT "Allergies/ADRs: Unknown"
+5 IF GMRAL=0
Begin DoDot:1
+6 SET Z="Allergies/ADRs: "
+7 SET Y=$ORDER(GMRAL(0))
IF Y
SET X=$PIECE(GMRAL(Y),U,2)
IF X]""
SET X=Z_X
QUIT
+8 SET X=Z_"None found in system"
End DoDot:1
QUIT X
+9 ;
+10 SET (ALLRG,ADR)=""
+11 SET X=0
FOR
SET X=$ORDER(GMRAL(X))
IF 'X
QUIT
Begin DoDot:1
+12 IF $PIECE(GMRAL(X),U,5)=0
SET ALLRG=ALLRG_$PIECE(GMRAL(X),U,2)_"; "
QUIT
+13 SET ADR=ADR_$PIECE(GMRAL(X),U,2)_"; "
End DoDot:1
+14 SET ALLRG=$SELECT(ALLRG="":"None found",1:$PIECE(ALLRG_";","; ;"))
+15 SET ADR=$SELECT(ADR="":"None found",1:$PIECE(ADR_";","; ;"))
+16 SET X="Food Allergies: "_ALLRG_"; AdvReac: "_ADR
SET TIUY=$$WRAP^TIULS(X,73)
+17 FOR COUNT=1:1
IF $PIECE(TIUY,"|",COUNT)=""
QUIT
SET ^TMP("BTIULO",$JOB,COUNT,0)=$PIECE(TIUY,"|",COUNT)
+18 QUIT "~@^TMP(""BTIULO"",$J)"
+19 ;
+20 ;
LASTIMM(DFN,TIUIMM,TIUNM) ;EP -- returns last immunization date
+1 ; TIUIMM=HL7 codes separated by ^ then generic name at end after ;
+2 ; example TIUIMM="2^10^89;Polio Vax"
+3 ; TIUNM=1 to return imm name; =0 to just return date
+4 ; TIUDE will be set to iens in BI Table Data Elements file
+5 ; TIUDATA "|" pieces within each "^" will be
+6 ; IEN PIECE
+7 ;---> 1 = Visit Type: "I"=Immunization, "S"=Skin Test.
+8 ;---> 9 2 = Vaccine Name, Long
+9 ;---> 25 3 = HL7 code for immunization
+10 ;---> 56 4 = Date of Visit Fileman format (YYYMMDD).
+11 ;
+12 NEW I,TIUDE,TIUANS,X,TIUCODE,TIUDATA
+13 IF '$GET(DFN)
QUIT
IF '$GET(TIUIMM)
QUIT
+14 ; -- set all codes sent into array
+15 FOR I=1:1
SET X=$PIECE(TIUIMM,U,I)
IF 'X
QUIT
SET TIUCODE(+X)=""
+16 ; -- set data elements to return
+17 FOR I=9,25,56
SET TIUDE(I)=""
+18 ; -- get imm hx from imm app
+19 DO IMMHX^BIRPC(.TIUDATA,DFN,.TIUDE)
+20 ; -- evaluate results
+21 KILL TIUANS
FOR I=1:1
SET X=$PIECE(TIUDATA,U,I)
IF X=""
QUIT
Begin DoDot:1
+22 ;not immunization
IF $PIECE(X,"|")'="I"
QUIT
+23 ;not in imm set sent
IF '$DATA(TIUCODE($PIECE(X,"|",3)))
QUIT
+24 ;set first imm found
IF '$DATA(TIUANS)
SET TIUANS=X
QUIT
+25 ;keep latest date
IF $PIECE(TIUANS,"|",4)<$PIECE(X,"|",4)
SET TIUANS=X
End DoDot:1
+26 ; -- return results
+27 IF '$DATA(TIUANS)
QUIT $SELECT(TIUNM:"Last "_$PIECE(TIUIMM,";",2)_": ",1:"")_"None Recorded"
+28 QUIT $SELECT(TIUNM:"Last "_$PIECE(TIUANS,"|",2)_": ",1:"")_$$FMTE^XLFDT($PIECE(TIUANS,"|",4))
+29 ;
+30 ;
IMMDUE(DFN,TARGET) ;EP; -- returns immunizations due (via Immunization app)
+1 NEW TIUIMM,TIUCAP,TIU31,ERROR,TIUX,TIUY,CNT,X
+2 SET TIUCAP="Immunizations Due: "
+3 IF '$GET(DFN)
QUIT TIUCAP_"?? patient unknown"
+4 IF '$LENGTH($TEXT(IMMFORC^BIRPC))
QUIT TIUCAP_"Unknown; Immunization v7.1 not installed"
+5 ;
+6 DO IMMFORC^BIRPC(.TIUIMM,DFN)
+7 ;
+8 SET TIU31=$CHAR(31)_$CHAR(31)
+9 ;--- Check for error in 2nd piece of return value.
+10 SET ERROR=$PIECE(TIUIMM,TIU31,2)
IF ERROR]""
QUIT TIUCAP_ERROR
+11 ;
+12 ;--- If no error, so take 1st piece of return value and process it.
+13 SET TIUIMM=$PIECE(TIUIMM,TIU31,1)
KILL @TARGET
+14 ;
+15 NEW TIUX,TIUY
FOR TIUX=1:1
SET TIUY=$PIECE(TIUIMM,U,TIUX)
IF TIUY=""
QUIT
Begin DoDot:1
+16 SET X=$PIECE(TIUY,"|")
IF $PIECE(TIUY,"|",2)]""
SET X=X_" ("_$PIECE(TIUY,"|",2)_$PIECE(TIUY,"|",3)_")"
+17 SET CNT=$GET(CNT)+1
IF CNT=1
SET @TARGET@(1,0)="Immunizations Due: "_X
QUIT
+18 SET @TARGET@(CNT,0)=$$SP(17)_X
End DoDot:1
+19 ;
+20 QUIT "~@"_$NAME(@TARGET)
+21 ;
LASTSK(DFN,TIUSK) ;EP -- returns last skin test date and result
+1 ; TIUSK=skin test name
+2 ; TIUDE will be set to iens in BI Table Data Elements file
+3 ; TIUDATA "|" pieces within each "^" will be
+4 ; IEN PIECE
+5 ;---> 1 = Visit Type: "I"=Immunization, "S"=Skin Test.
+6 ;---> 38 2 = Skin Test Result
+7 ;---> 40 3 = Skin Test - Date Read in DD-mmm_YYYY format.
+8 ;---> 41 4 = Skin Test Name
+9 ;
+10 NEW I,TIUDE,TIUANS,X
+11 IF '$GET(DFN)
QUIT
IF '$GET(TIUIMM)
QUIT
+12 ; -- set data elements to return
+13 FOR I=38,40,41
SET TIUDE(I)=""
+14 ; -- get imm hx from imm app
+15 DO IMMHX^BIRPC(.TIUDATA,DFN,.TIUDE)
+16 ; -- evaluate results
+17 KILL TIUANS
FOR I=1:1
SET TIUX=$PIECE(TIUDATA,U,I)
IF TIUX=""
QUIT
Begin DoDot:1
+18 ;not skin test
IF $PIECE(TIUX,"|")'="S"
QUIT
+19 ;not test type sent
IF $PIECE(TIUX,"|",4)'=TIUSK
QUIT
+20 ;need FM date format
SET X=$PIECE(TIUX,"|",3)
DO ^%DT
SET $PIECE(TIUX,"|",5)=Y
+21 ;set first one found
IF '$DATA(TIUANS)
SET TIUANS=TIUX
QUIT
+22 ;keep latest date
IF $PIECE(TIUANS,"|",5)<$PIECE(TIUX,"|",5)
SET TIUANS=TIUX
End DoDot:1
+23 ; -- return results
+24 IF '$DATA(TIUANS)
QUIT "Last "_TIUSK_": None Recorded"
+25 QUIT "Last "_TIUSK_": "_$PIECE(TIUANS,"|",3)_" - "_$PIECE(TIUANS,"|",38)
+26 ;
+27 ;
LASTPAP(DFN) ;EP; -- returns last pap date and result
+1 NEW N,Y,BW,DATE,LINE
+2 IF $PIECE(^DPT(DFN,0),U,2)="M"
QUIT ""
+3 SET N=0
FOR
SET N=$ORDER(^BWPCD("C",DFN,N))
IF 'N
QUIT
Begin DoDot:1
+4 SET Y=^BWPCD(N,0)
+5 IF $PIECE(Y,U,4)=1
SET DATE=$PIECE(Y,U,12)
Begin DoDot:2
+6 SET BW("PAP",9999999-DATE)=DATE_U_$PIECE(Y,U,5)_U_N
End DoDot:2
End DoDot:1
+7 IF '$DATA(BW("PAP"))
QUIT "No PAP on record"
+8 SET N=$ORDER(BW("PAP",0))
IF 'N
QUIT "No PAP on record"
+9 SET N=BW("PAP",N)
SET LINE="Last PAP: "_$$FMTE^XLFDT(+N,"5D")
+10 SET LINE=LINE_" Result - "_$$GET1^DIQ(9002086.31,$PIECE(N,U,2),.01)
+11 SET LINE=LINE_" ("_$$GET1^DIQ(9002086.1,$PIECE(N,U,3),.14)_")"
+12 QUIT LINE
+13 ;
LASTMAM(DFN) ;EP; -- returns last mammogram date and result
+1 NEW N,Y,BW,DATE,LINE,X
+2 IF $PIECE(^DPT(DFN,0),U,2)="M"
QUIT ""
+3 SET N=0
FOR
SET N=$ORDER(^BWPCD("C",DFN,N))
IF 'N
QUIT
Begin DoDot:1
+4 SET Y=^BWPCD(N,0)
+5 ;mamo iens are 25,26,28
SET X=+$PIECE(Y,U,4)
IF (X'=25)&(X'=26)&(X'=28)
QUIT
+6 SET DATE=$PIECE(Y,U,12)
+7 SET BW("MAM",9999999-DATE)=DATE_U_$PIECE(Y,U,5)_U_N_U_$PIECE(Y,U,4)
End DoDot:1
+8 IF '$DATA(BW("MAM"))
QUIT "No Mammogram on record"
+9 SET N=$ORDER(BW("MAM",0))
IF 'N
QUIT "No Mammogram on record"
+10 SET N=BW("MAM",N)
+11 SET LINE="Last "_$$GET1^DIQ(9002086.2,$PIECE(N,U,4),.01)_": "
+12 SET LINE=LINE_$$FMTE^XLFDT(+N,"5D")
+13 SET LINE=LINE_" Result - "_$$GET1^DIQ(9002086.31,+$PIECE(N,U,2),.01)
+14 SET LINE=LINE_" ("_$$GET1^DIQ(9002086.1,$PIECE(N,U,3),.14)_")"
+15 QUIT LINE
+16 ;
+17 ;
+18 ;
VSTINS(DFN,VISIT) ;EP; returns insurance coverage at visit time
+1 NEW VDT,LINE,PVT
+2 IF ('$GET(DFN))!('$GET(VISIT))
QUIT "Invalid visit"
+3 SET LINE=""
SET VDT=+$GET(^AUPNVSIT(VISIT,0))
IF 'VDT
QUIT LINE
+4 IF $$MCR^AUPNPAT(DFN,VDT)=1
SET LINE="MEDICARE #"_$$MCR2(DFN)_"/"
+5 IF $$MCD^AUPNPAT(DFN,VDT)=1
SET LINE=LINE_"MEDICAID #"_$$MCD(DFN)_"/"
+6 ;I $$PI^AUPNPAT(DFN,VDT)=1 S LINE=LINE_"PVT INS ("_$$PIN^AUPNPAT(DFN,VDT,"E")_")/"
+7 IF $$PI^AUPNPAT(DFN,VDT)=1
SET PVT=$$THIRD(DFN)
SET LINE=LINE_"PVT INS ("_PVT_")/"
+8 IF $$RR^AUPNPAT(DFN,VDT)=1
SET LINE=LINE_"RR INS #"_$$GETRRE^AGUTL(DFN,VDT)_")/"
+9 QUIT $SELECT(LINE="":"",1:$EXTRACT(LINE,1,$LENGTH(LINE)-1))
+10 ;
POLICY(DFN,VISIT) ; EP; returns prvt insurance policy number at visit time
+1 NEW INSUR,IEN,PVT
+2 SET PVT=""
+3 SET INSUR=$$PIN^AUPNPAT(DFN,VISIT,"I")
SET IEN=0
+4 IF INSUR
SET PVT=$$THIRD(DFN)
+5 QUIT PVT
+6 ;S IEN=$O(^AUPNPRVT(DFN,11,"B",INSUR,0))
+7 ;I IEN Q "#"_$P($G(^AUPNPRVT(DFN,11,IEN,0)),U,2)
+8 QUIT ""
MCR(DFN) ;EP; returns medicare number for patient
+1 NEW IEN
+2 SET IEN=$$GETMCR^AGUTL(DFN)
+3 IF IEN'=""
QUIT IEN
+4 SET IEN=$ORDER(^AUPNMCR("B",DFN,0))
IF 'IEN
QUIT "??"
+5 QUIT $PIECE($GET(^AUPNMCR(IEN,0)),U,3)
+6 ;
MCR2(DFN) ;EP; returns medicare number for patient
+1 NEW IEN,NUMBER,TYPE,IEN2,MCARE,COV,DNAME,INS
+2 SET MCARE=""
+3 SET NUMBER=$$GETMCR^AGUTL(DFN)
+4 ;I '+NUMBER D
+5 ;.S IEN=$O(^AUPNMCR("B",DFN,0))
+6 ;.S NUMBER=$P($G(^AUPNMCR(IEN,0)),U,3)
+7 SET IEN2=0
FOR
SET IEN2=$ORDER(^AUPNMCR(DFN,11,IEN2))
IF '+IEN2
QUIT
Begin DoDot:1
+8 SET DATA=$GET(^AUPNMCR(DFN,11,IEN2,0))
+9 SET EXP=$PIECE(DATA,U,2)
+10 IF (+EXP)&(EXP<DT)
QUIT
+11 SET COV=$PIECE(DATA,U,3)
+12 IF COV="A"!(COV="B")
SET DNAME="Part "_COV_"-"_NUMBER
+13 IF COV="D"
Begin DoDot:2
+14 SET INS=$$GET1^DIQ(9999999.18,$PIECE(DATA,U,4),.01)
+15 SET DNAME="Part "_COV_" "_INS_"-"_$PIECE(DATA,U,6)
End DoDot:2
+16 IF MCARE=""
SET MCARE=DNAME
+17 IF '$TEST
SET MCARE=MCARE_";"_DNAME
End DoDot:1
+18 QUIT MCARE
RRE(DFN) ;EP; returns railroad number for patient
+1 NEW IEN,NUMBER,TYPE,IEN2,RRE,COV,DNAME,INS
+2 SET RRE=""
+3 SET NUMBER=$$GETRRE^AGUTL(DFN)
+4 SET IEN2=0
FOR
SET IEN2=$ORDER(^AUPNRRE(DFN,11,IEN2))
IF '+IEN2
QUIT
Begin DoDot:1
+5 SET DATA=$GET(^AUPNRRE(DFN,11,IEN2,0))
+6 SET EXP=$PIECE(DATA,U,2)
+7 IF (+EXP)&(EXP<DT)
QUIT
+8 SET COV=$PIECE(DATA,U,3)
+9 IF COV="A"!(COV="B")
SET DNAME="Part "_COV_"-"_NUMBER
+10 IF COV="D"
Begin DoDot:2
+11 SET INS=$$GET1^DIQ(9999999.18,$PIECE(DATA,U,4),.01)
+12 SET DNAME="Part "_COV_" "_INS_"-"_$PIECE(DATA,U,6)
End DoDot:2
+13 IF RRE=""
SET RRE=DNAME
+14 IF '$TEST
SET RRE=RRE_";"_DNAME
End DoDot:1
+15 QUIT RRE
MCD(DFN) ;EP; returns medicaid number for patient
+1 NEW IEN
+2 SET IEN=$ORDER(^AUPNMCD("B",DFN,0))
IF 'IEN
QUIT "??"
+3 QUIT $PIECE($GET(^AUPNMCD(IEN,0)),U,3)
THIRD(DFN) ;EP returns third party insurance
+1 NEW IEN,TYPE,DATA,NAME,NUMBER,PVT,EXP
+2 SET PVT=""
+3 SET TYPE=""
FOR
SET TYPE=$ORDER(^AUPNPRVT(DFN,11,"B",TYPE))
IF '+TYPE
QUIT
Begin DoDot:1
+4 SET IEN=""
FOR
SET IEN=$ORDER(^AUPNPRVT(DFN,11,"B",TYPE,IEN))
IF '+IEN
QUIT
Begin DoDot:2
+5 SET DATA=$GET(^AUPNPRVT(DFN,11,IEN,0))
+6 SET EXP=$PIECE(DATA,U,7)
+7 IF (+EXP)&(EXP<DT)
QUIT
+8 IF DATA=""
QUIT
+9 SET NAME=$$GET1^DIQ(9999999.18,$PIECE(DATA,U,1),.01)
+10 SET NUMBER=$PIECE($GET(^AUPNPRVT(DFN,11,IEN,2)),U,1)
+11 ;following code looks at the Member Number field of Insurer multiple.
+12 ;from Policy Holder File
+13 IF NUMBER=""
Begin DoDot:3
+14 IF +$PIECE(DATA,U,8)
SET NUMBER=$PIECE($GET(^AUPN3PPH($PIECE(DATA,U,8),0)),U,4)
End DoDot:3
+15 IF PVT=""
SET PVT=NAME_"-"_NUMBER
+16 IF '$TEST
SET PVT=PVT_";"_NAME_"-"_NUMBER
End DoDot:2
End DoDot:1
+17 QUIT PVT
+18 ;
LASTEXAM(DFN,CODE) ;EP; returns last V Exam date and result
+1 ; CODE=unique code from exam file or exam name
+2 NEW EXAM,DATE,RESULT,N,SUB
+3 ;was code or name sent
SET SUB=$SELECT($LENGTH(CODE)=2:"C",1:"B")
+4 SET EXAM=$ORDER(^AUTTEXAM(SUB,CODE,0))
IF EXAM=""
QUIT ""
+5 SET DATE=$ORDER(^AUPNVXAM("AA",+$GET(DFN),EXAM,0))
IF DATE=""
QUIT "None Found"
+6 SET RESULT="Date: "_$$FMTE^XLFDT(9999999-DATE,"D")
+7 SET N=$ORDER(^AUPNVXAM("AA",DFN,EXAM,DATE,0))
IF 'N
QUIT RESULT_" Results: No Results"
+8 QUIT RESULT_" Results: "_$$GET1^DIQ(9000010.13,N,.04)
+9 ;
LASTHF(DFN,NAME) ;EP; returns last V Health Factor
+1 ; NAME = exact name of health factor in file
+2 NEW FACTOR,DATE,RESULT,N
+3 SET RESULT=NAME_": "
+4 SET FACTOR=$ORDER(^AUTTHF("B",NAME,0))
IF 'FACTOR
QUIT ""
+5 SET DATE=$ORDER(^AUPNVHF("AA",+$GET(DFN),FACTOR,0))
IF DATE=""
QUIT RESULT_"Not Found"
+6 SET RESULT=RESULT_$$FMTE^XLFDT(9999999-DATE,"D")
+7 SET N=$ORDER(^AUPNVHF("AA",DFN,FACTOR,DATE,0))
IF 'N
QUIT RESULT
+8 ;severity level
SET X=$$GET1^DIQ(9000010.23,N,.04)
+9 ;Q RESULT_$S(X]"":" Level: "_$$GET1^DIQ(9000010.13,N,.04),1:"")
+10 ;IHS/ITSC/LJF 12/10/2004 PATCH 1001 typo, file is .23 not .13
QUIT RESULT_$SELECT(X]"":" Level: "_X,1:"")
+11 ;
LSTHFALL(TARGET,DFN) ;EP; returns last occurence for ALL V Health Factors for patient
+1 NEW FACTOR,DATE,RESULT,N
+2 SET DATE=$ORDER(^AUPNVHF("AA",+$GET(DFN),FACTOR,0))
IF DATE=""
QUIT RESULT_"Not Found"
+3 SET RESULT=RESULT_$$FMTE^XLFDT(9999999-DATE,"D")
+4 SET N=$ORDER(^AUPNVHF("AA",DFN,FACTOR,DATE,0))
IF 'N
QUIT RESULT
+5 ;severity level
SET X=$$GET1^DIQ(9000010.23,N,.04)
+6 QUIT RESULT_$SELECT(X]"":" Level: "_$$GET1^DIQ(9000010.13,N,.04),1:"")
+7 QUIT "~@"_$NAME(@TARGET)
+8 ;
PTADDRS(DFN) ;EP; returns patient's current address
+1 NEW CNT,LINE,FIELD
+2 IF '$GET(DFN)
QUIT ""
+3 KILL ^TMP("BTIULO",$JOB)
+4 SET CNT=0
FOR FIELD=.111:.001:.116
Begin DoDot:1
+5 SET LINE=$$GET1^DIQ(2,DFN,FIELD)
IF LINE=""
QUIT
+6 ;separate lines for street address portion
IF FIELD<.115
SET CNT=CNT+1
+7 SET ^TMP("BTIULO",$JOB,CNT,0)=$GET(^TMP("BTIULO",$JOB,CNT,0))_LINE_" "
End DoDot:1
+8 IF '$DATA(^TMP("BTIULO",$JOB))
QUIT "No Current Address Found"
+9 QUIT "~@^TMP(""BTIULO"",$J)"
+10 ;
PHONE(DFN) ;EP; -- returns patient's current phone numbers
+1 NEW HOME,OFFICE
+2 IF '$GET(DFN)
QUIT
+3 SET HOME=$$GET1^DIQ(2,DFN,.131)
IF HOME]""
SET HOME=HOME_" (home)"
+4 SET OFFICE=$$GET1^DIQ(2,DFN,.132)
IF OFFICE]""
SET OFFICE=OFFICE_" (office)"
+5 IF HOME=""
IF OFFICE=""
SET HOME="No Phone in record"
+6 QUIT HOME_$SELECT(HOME="":"",OFFICE="":"",1:"/")_OFFICE
+7 ;
ELIG(DFN) ;EP; -- returns patient's Eligebility Status
+1 NEW ELIG
+2 IF '$GET(DFN)
QUIT
+3 SET ELIG=$$GET1^DIQ(9000001,DFN,1112)
+4 QUIT "ELIGIBILITY STATUS: "_$SELECT(ELIG]"":ELIG,1:"??")
+5 ;
PAD(DATA,LENGTH) ; pad length of data
+1 QUIT $EXTRACT(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)
+2 ;
SP(NUM) ; pad spaces
+1 QUIT $$PAD(" ",NUM)
