BIUTL1 ;IHS/CMI/MWR - UTIL: PATIENT DEMOGRAPHICS; MAY 10, 2010
;;8.5;IMMUNIZATION;**2**;MAY 15,2012
;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
;; RETRIEVE PATIENTS FOR DUE LISTS & LETTERS.
;; PATCH 2: Add YY option to DOBF. DOBF
;
;----------
NAME(DFN,ORDER) ;EP
;---> Return text of Patient Name.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - ORDER (opt) ""/0=Last,First 2=First Only
; 1=First Last 3=Last Only
;
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^DPT(DFN,0)) "Unknown"
N X S X=$P(^DPT(DFN,0),U)
Q:'$G(ORDER) X
S X=$$FL(X)
Q:ORDER=1 X
Q:ORDER=2 $P(X," ")
Q:ORDER=3 $P(X," ",2)
Q "UNKNOWN ORDER"
;
;
;----------
FL(X) ;EP
;---> Switch First and Last Names.
Q $P($P(X,",",2)," ")_" "_$P(X,",")
;
;
;----------
DOB(DFN) ;EP
;---> Return Patient's Date of Birth in Fileman format.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
;
Q:'$G(DFN) "NO PATIENT"
Q:'$P($G(^DPT(DFN,0)),U,3) "NOT ENTERED"
Q $P(^DPT(DFN,0),U,3)
;
;
;********** PATCH 2, v8.5, MAY 15,2012, IHS/CMI/MWR
;---> Add BIYY option/parameter to DOBF
;----------
DOBF(DFN,BIDT,BINOA,BISL,BIADT,BIYY) ;EP
;---> Date of Birth formatted "09-Sep-1994 (35 Months)"
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - BIDT (opt) Date on which Age should be calculated.
; 3 - BINOA (opt) 1=No age (don't append age).
; 4 - BISL (opt) 1=Slash Date Format: MM/DD/YYYY
; 5 - BIADT (opt) 1=Append "on BIDT" to age.
; 6 - BIYY (opt) 1=2-digit year.
;
N X,Y
S X=$$DOB($G(DFN))
Q:'X X
S X=$S($G(BISL):$$SLDT2^BIUTL5(X,+$G(BIYY)),1:$$TXDT1^BIUTL5(X))
Q:$G(BINOA) X
S Y=$$AGEF(DFN,$G(BIDT))
S:Y["DECEASED" Y="DECEASED"
S X=X_" ("_Y
I $G(BIADT),$G(BIDT) S X=X_" on "_$$SLDT2^BIUTL5(BIDT,+$G(BIYY))
S X=X_")"
Q X
;**********
;
;
;----------
AGE(DFN,BIZ,BIDT) ;EP
;---> Return Patient's Age.
;---> Parameters:
; 1 - DFN (req) IEN in PATIENT File.
; 2 - BIZ (opt) BIZ=1,2,3 1=years, 2=months, 3=days.
; 2 will be assumed if not passed.
; 3 - BIDT (opt) Date on which Age should be calculated.
;
N BIDOB,X,X1,X2 S:$G(BIZ)="" BIZ=2
Q:'$G(DFN) "NO PATIENT"
S BIDOB=$$DOB(DFN)
Q:'BIDOB "Unknown"
I '$G(BIDT)&($$DECEASED(DFN)) D Q X
.S X="DECEASED: "_$$TXDT1^BIUTL5(+^DPT(DFN,.35))
S:'$G(DT) DT=$$DT^XLFDT
S:'$G(BIDT) BIDT=DT
Q:BIDT<BIDOB "NOT BORN"
;
;---> Age in Years.
N BIAGEY,BIAGEM,BID1,BID2,BIM1,BIM2,BIY1,BIY2
S BIM1=$E(BIDOB,4,7),BIM2=$E(BIDT,4,7)
S BIY1=$E(BIDOB,1,3),BIY2=$E(BIDT,1,3)
S BIAGEY=BIY2-BIY1 S:BIM2<BIM1 BIAGEY=BIAGEY-1
S:BIAGEY<1 BIAGEY="<1"
Q:BIZ=1 BIAGEY
;
;---> Age in Months.
S BID1=$E(BIM1,3,4),BIM1=$E(BIM1,1,2)
S BID2=$E(BIM2,3,4),BIM2=$E(BIM2,1,2)
S BIAGEM=12*BIAGEY
I BIM2=BIM1&(BID2<BID1) S BIAGEM=BIAGEM+12
I BIM2>BIM1 S BIAGEM=BIAGEM+BIM2-BIM1
I BIM2<BIM1 S BIAGEM=BIAGEM+BIM2+(12-BIM1)
S:BID2<BID1 BIAGEM=BIAGEM-1
Q:BIZ=2 BIAGEM
;
;---> Age in Days.
S X1=BIDT,X2=BIDOB
D ^%DTC
Q X
;
;
;----------
AGEF(DFN,BIDT) ;EP
;---> Age formatted "35 Months" or "23 Years"
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - BIDT (opt) Date on which Age should be calculated.
;
N Y
S Y=$$AGE(DFN,2,$G(BIDT))
Q:Y["DECEASED" Y
Q:Y["NOT BORN" Y
;
;---> If over 60 months, return years.
I Y>60 S Y=$$AGE(DFN,1,$G(BIDT)) Q Y_$S(Y=1:"year",1:" yrs")
;
;---> If under 1 month return days.
I Y<1 S Y=$$AGE(DFN,3,$G(BIDT)) Q Y_$S(Y=1:" day",1:" days")
;
;---> Return months
Q Y_$S(Y=1:" mth",1:" mths")
;
;
;----------
DECEASED(DFN,BIDT) ;EP
;---> Return 1 if patient is deceased, 0 if not deceased.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - BIDT (opt) If BIDT=1 return Date of Death (Fileman format).
;
Q:'$G(DFN) 0
N X S X=+$G(^DPT(DFN,.35))
Q:'X 0
Q:'$G(BIDT) 1
Q X
;
;
;----------
SEX(DFN,PRON) ;EP
;---> Return "F" is patient is female, "M" if male.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - PRON (opt) Pronoun: 1=he/she, 2=him/her,3=his,her
;
Q:'$G(DFN) ""
Q:'$D(^DPT(DFN,0)) ""
N X S X=$P(^DPT(DFN,0),U,2)
Q:'$G(PRON) X
I PRON=1 Q $S(X="F":"she",1:"he")
I PRON=2 Q $S(X="F":"her",1:"him")
I PRON=3 Q $S(X="F":"her",1:"his")
Q X
;
;
;----------
SEXW(DFN) ;EP
;---> Return Patient sex: "Female"/"Male".
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
;
Q:$$SEX(DFN)="M" "Male"
Q:$$SEX(DFN)="F" "Female"
Q "Unknown"
;
;
;----------
ACTIVE(DFN) ;PEP - Return Patient's Active Status in Immunization Package.
;---> Return text of Patient's Active Status.
;---> $$ACTIVE^BIUTL1(DFN) will return values of either:
;---> "Deceased","Inactive", or "Active".
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
;
N X
S X=$$DECEASED(DFN)
Q:X>0 "Deceased"
S X=$$INACT(DFN)
Q:X "Inactive"
Q:X]"" X
Q "Active"
;
;
;----------
INACT(DFN,TEXT) ;PEP - Return date this patient became Inactive in Immunization.
;---> Return date this patient became Inactive.
;---> $$INACT^BIUTL1(DFN) will return values of either:
;---> "NO PATIENT","UNKNOWN", "NOT IN REGISTER", DATE INACTIVE, or null.
;
;---> NOTE: If $$INACT^BIUTL1(DFN)="" then the Patient is Active.
;
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - TEXT (opt) If TEXT=1, return text of date.
;
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^DPT(DFN,0)) "UNKNOWN"
Q:'$D(^BIP(DFN,0)) "NOT IN REGISTER"
N X S X=$P(^BIP(DFN,0),U,8)
Q:'X ""
Q:'$G(TEXT) X
Q $$TXDT1^BIUTL5(X)
;
;
;----------
INACTRE(DFN,BICODE) ;EP
;---> Return Reason for Inactive.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - BICODE (opt) If BICODE=1 return Code rather than text.
;
Q:'$G(DFN) ""
N X,Y,Z S X=$P($G(^BIP(DFN,0)),U,16)
Q:(X="") ""
S Y=$P($G(^DD(9002084,.16,0)),U,3)
S Z=$P($P(Y,X_":",2),";")
S:Z="" Z="Not Recorded"
Q Z
;
;
;----------
INACTUSR(DFN,Z) ;EP
;---> Return User who made this Patient Inactive.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - Z (opt) If Z=1 return IEN of user.
;
Q:'$G(DFN) ""
N X S X=$P($G(^BIP(DFN,0)),U,23)
Q:$G(Z) X
Q $$PERSON(X)
;
;
;----------
INACTREG(DFN,DUZ2) ;EP
;---> Return 1 if patient does not have an Active Chart in
;---> RPMS Patient Registration at this site DUZ(2).
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - DUZ2 (req) IEN of site DUZ(2) to check for Active Chart.
;
Q:'$G(DFN) 1
Q:'$G(DUZ2) 1
Q:'$D(^AUPNPAT(DFN,41,DUZ2,0)) 1
;
;********** PATCH 1, SEP 21,2006, IHS/CMI/MWR
;---> Correct test for Active Chart at site DUZ2.
;Q:$P($D(^AUPNPAT(DFN,41,DUZ2,0)),"^",3) 1
Q:$P(^AUPNPAT(DFN,41,DUZ2,0),"^",3) 1
;**********
;
Q 0
;
;
;----------
ENTERED(DFN,BIA,BIT) ;EP
;---> Return date this patient was entered.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - BIA (opt) If BIA="", return Date Entered.
; If BIA=1, return 1 if Automatically entered during Scan.
; 3 - BIT (opt) If BIT=1, return text of Date or Auto field.
;
Q:'$G(DFN) ""
Q:'$D(^BIP(DFN,0)) ""
N X,Y
S Y=$S($G(BIA):22,1:21)
S X=$P(^BIP(DFN,0),U,Y)
Q:$G(BIA) $S($G(BIT):$S(X:"Automatically",1:"Manually"),1:X)
Q:'$G(BIT) X
Q $$TXDT1^BIUTL5(X)
;
;
;----------
MOVEDLOC(DFN) ;EP
;---> Return Location where patient moved is receiving treatment elsewhere.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
;
Q:'$G(DFN) ""
Q $P($G(^BIP(DFN,0)),U,12)
;
;
;----------
LASTLET(DFN,TEXT) ;EP
;---> Return Fileman date of the last letter sent to this patient.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - TEXT (opt) If TEXT=1, return text of date.
;
Q:'$G(DFN) 0
Q:'$D(^DPT(DFN,0)) "None"
Q:'$D(^BIP(DFN,0)) "Not in Register"
N X S X=$P(^BIP(DFN,0),U,14)
Q:'X "None"
Q:'$G(TEXT) X
Q $$TXDT1^BIUTL5(X)
;
;
;----------
NAMAGE(DFN) ;EP
;---> Return Patient Name concatenated with age.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
;
Q:'$G(DFN) "NO PATIENT"
Q $$NAME(DFN)_" ("_$$AGE(DFN)_"y/o)"
;
;
;----------
SSN(DFN) ;EP
;---> Return Social Security Number (SSN).
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
N X
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^DPT(DFN,0)) "Unknown"
S X=$P(^DPT(DFN,0),U,9)
Q:X']"" "Unknown"
Q X
;
;
;----------
HRCN(DFN,DUZ2,BIX) ;EP
;---> Return IHS Health Record Number.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - DUZ2 (opt) User's Site/Location IEN. If no DUZ2
; provided, function will look for DUZ(2).
; 3 - BIX (opt) If BIX=1 return HRCN with no dashes.
;
; vvv83
S:'$G(DUZ2) DUZ2=$G(DUZ(2))
Q:'$G(DFN)!('$G(DUZ2)) "No Value"
Q:'$D(^AUPNPAT(DFN,41,DUZ2,0)) "Not Here"
Q:'+$P(^AUPNPAT(DFN,41,DUZ2,0),"^",2) "No Rec#"
N Y S Y=$P(^AUPNPAT(DFN,41,DUZ2,0),"^",2)
Q:$G(BIX) Y
Q:'+Y Y
Q:'$$DASH(DUZ2) Y
I $L(Y)=7 D Q Y
.S Y=$TR("123-45-67",1234567,Y)
S Y=$E("00000",0,6-$L(Y))_Y
S Y=$TR("12-34-56",123456,Y)
Q Y
;
;
;----------
DASH(BIDUZ2) ;EP
;---> Return 1 if Site Parameter says return Chart#s with dashes.
;---> Parameters:
; 1 - BIDUZ2 (req) User's DUZ(2)
;
Q +$P($G(^BISITE(+$G(BIDUZ2),0)),U,12)
;
;
;----------
HPHONE(DFN) ;EP
;---> Return patient's home phone number.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
;
Q:'$G(DFN) "No Patient"
Q:'$D(^DPT(DFN,.13)) "Unknown"
Q:$P(^DPT(DFN,.13),U)="" "Unknown"
Q $P(^DPT(DFN,.13),U)
;
;
;********** PATCH 1, SEP 21,2006, IHS/CMI/MWR
;---> Add ability to retrieve 2nd and 3rd Street Address lines.
;----------
STREET(DFN,Z) ;EP
;---> Return patient's street address.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - Z (opt) If Z=2 return Line 2 of patient's address.
; If Z=3 return Line 3 of patient's address.
;
N X S X=$S($G(Z)=2:2,$G(Z)=3:3,1:1)
Q:'$G(DFN) "No Patient"
Q:'$D(^DPT(DFN,.11)) "Unknown"
;---> Only return "Unknown" for the first line.
Q:$P(^DPT(DFN,.11),U,X)="" $S(X=1:"Unknown",1:"")
Q $P(^DPT(DFN,.11),U,X)
;
;
;----------
CITY(DFN) ;EP
;---> Return patient's city.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
;
Q:'$G(DFN) "No Patient"
Q:'$D(^DPT(DFN,.11)) "Unknown"
Q:$P(^DPT(DFN,.11),U,4)="" "Unknown"
Q $P(^DPT(DFN,.11),U,4)
;
;
;----------
STATE(DFN) ;EP
;---> Return patient's state.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
;
Q:'$G(DFN) "No Patient"
Q:'$D(^DPT(DFN,.11)) "No State"
Q:$P(^DPT(DFN,.11),U,5)="" "No State"
Q $P(^DIC(5,$P(^DPT(DFN,.11),U,5),0),U,2)
;
;
;----------
ZIP(DFN) ;EP
;---> Return patient's zipcode.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
;
Q:'$G(DFN) "No Patient"
Q:'$D(^DPT(DFN,.11)) "No Zip"
Q:$P(^DPT(DFN,.11),U,6)="" "No Zip"
Q $P(^DPT(DFN,.11),U,6)
;
;
;----------
CTYSTZ(DFN) ;EP
;---> Return patient's city, state zip.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
;
Q:'$G(DFN) "No Patient"
Q $$CITY(DFN)_", "_$$STATE(DFN)_" "_$$ZIP(DFN)
;
;
;----------
CMGR(DFN,TEXT,ORDER) ;EP
;---> Return patient's Case Manager.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - TEXT (opt) If TEXT=1, return text of Case Manager.
; 3 - ORDER (opt) ""/0=Last,First 1=First Last
;
N Y
Q:'$G(DFN) "No Patient"
Q:'$D(^BIP(DFN,0)) "Unknown"
S Y=$P(^BIP(DFN,0),U,10)
Q:'$G(TEXT) Y
Q $$PERSON(Y,$G(ORDER))
;
;
;----------
DPRV(DFN,TEXT,ORDER) ;EP
;---> Return patient's Designated Provider.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - TEXT (opt) If TEXT=1, return text of Case Manager.
; 3 - ORDER (opt) ""/0=Last,First 1=First Last
;
N Y,Z
Q:'$G(DFN) "No Patient"
Q:'$D(^BIP(DFN,0)) "Unknown"
Q:'$L($T(^BDPAPI)) "No BDP Pkg"
D ALLDP^BDPAPI(DFN,"DESIGNATED PRIMARY PROVIDER",.Y)
S Z=$P($G(Y("DESIGNATED PRIMARY PROVIDER")),U,2)
Q:'$G(TEXT) Z
Q $$PERSON(Z,$G(ORDER))
;
;
;----------
PERSON(X,ORDER) ;EP
;---> Return person's name from File #200.
;---> Parameters:
; 1 - X (req) Person's IEN in New Person File #200.
; 2 - ORDER (opt) ""/0=Last,First 1=First Last
;
Q:'X "Unknown"
Q:'$D(^VA(200,X,0)) "Unknown"
N Y S Y=$P(^VA(200,X,0),U)
Q:'$G(ORDER) Y
Q $$FL(Y)
;
;
;----------
PARENT(DFN,BIX) ;EP
;---> Return Patient's Parent/Guardian name as stored in the
;---> Immunization database.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
; 2 - BIX (opt) If BIX=1, return text for letter address
; (return text "Parent/Guardian of" if no data).
N Y
D
.I '$G(DFN) S Y="" Q
.S Y=$P($G(^BIP(DFN,0)),U,9)
;---> If no Parent/Guardian in Immunization, check Patient Reg.
;S:Y="" Y=?
Q:'$G(BIX) Y
Q:Y="" "Parent/Guardian of"
Q Y_", for"
;
;
;----------
INELIG(BIDFN) ;EP
;---> Return 1 if patient is Ineligible in RPMS Patient Registration.
;---> Parameters:
; 1 - BIDFN (req) Patient's IEN (DFN).
;
Q:'$G(BIDFN) 0
Q:$P($G(^AUPNPAT(BIDFN,11)),"^",12)="I" 1
Q 0
;
;
;----------
CONSENT(BIDFN) ;EP
;---> Return 1 if patient or guardian consented to participation in the state
;---> registry.
;---> Parameters:
; 1 - BIDFN (req) Patient's IEN (DFN).
;
Q:'$G(BIDFN) ""
Q $P($G(^BIP(BIDFN,0)),"^",24)
BIUTL1 ;IHS/CMI/MWR - UTIL: PATIENT DEMOGRAPHICS; MAY 10, 2010
+1 ;;8.5;IMMUNIZATION;**2**;MAY 15,2012
+2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
+3 ;; RETRIEVE PATIENTS FOR DUE LISTS & LETTERS.
+4 ;; PATCH 2: Add YY option to DOBF. DOBF
+5 ;
+6 ;----------
NAME(DFN,ORDER) ;EP
+1 ;---> Return text of Patient Name.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ; 2 - ORDER (opt) ""/0=Last,First 2=First Only
+5 ; 1=First Last 3=Last Only
+6 ;
+7 IF '$GET(DFN)
QUIT "NO PATIENT"
+8 IF '$DATA(^DPT(DFN,0))
QUIT "Unknown"
+9 NEW X
SET X=$PIECE(^DPT(DFN,0),U)
+10 IF '$GET(ORDER)
QUIT X
+11 SET X=$$FL(X)
+12 IF ORDER=1
QUIT X
+13 IF ORDER=2
QUIT $PIECE(X," ")
+14 IF ORDER=3
QUIT $PIECE(X," ",2)
+15 QUIT "UNKNOWN ORDER"
+16 ;
+17 ;
+18 ;----------
FL(X) ;EP
+1 ;---> Switch First and Last Names.
+2 QUIT $PIECE($PIECE(X,",",2)," ")_" "_$PIECE(X,",")
+3 ;
+4 ;
+5 ;----------
DOB(DFN) ;EP
+1 ;---> Return Patient's Date of Birth in Fileman format.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ;
+5 IF '$GET(DFN)
QUIT "NO PATIENT"
+6 IF '$PIECE($GET(^DPT(DFN,0)),U,3)
QUIT "NOT ENTERED"
+7 QUIT $PIECE(^DPT(DFN,0),U,3)
+8 ;
+9 ;
+10 ;********** PATCH 2, v8.5, MAY 15,2012, IHS/CMI/MWR
+11 ;---> Add BIYY option/parameter to DOBF
+12 ;----------
DOBF(DFN,BIDT,BINOA,BISL,BIADT,BIYY) ;EP
+1 ;---> Date of Birth formatted "09-Sep-1994 (35 Months)"
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ; 2 - BIDT (opt) Date on which Age should be calculated.
+5 ; 3 - BINOA (opt) 1=No age (don't append age).
+6 ; 4 - BISL (opt) 1=Slash Date Format: MM/DD/YYYY
+7 ; 5 - BIADT (opt) 1=Append "on BIDT" to age.
+8 ; 6 - BIYY (opt) 1=2-digit year.
+9 ;
+10 NEW X,Y
+11 SET X=$$DOB($GET(DFN))
+12 IF 'X
QUIT X
+13 SET X=$SELECT($GET(BISL):$$SLDT2^BIUTL5(X,+$GET(BIYY)),1:$$TXDT1^BIUTL5(X))
+14 IF $GET(BINOA)
QUIT X
+15 SET Y=$$AGEF(DFN,$GET(BIDT))
+16 IF Y["DECEASED"
SET Y="DECEASED"
+17 SET X=X_" ("_Y
+18 IF $GET(BIADT)
IF $GET(BIDT)
SET X=X_" on "_$$SLDT2^BIUTL5(BIDT,+$GET(BIYY))
+19 SET X=X_")"
+20 QUIT X
+21 ;**********
+22 ;
+23 ;
+24 ;----------
AGE(DFN,BIZ,BIDT) ;EP
+1 ;---> Return Patient's Age.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) IEN in PATIENT File.
+4 ; 2 - BIZ (opt) BIZ=1,2,3 1=years, 2=months, 3=days.
+5 ; 2 will be assumed if not passed.
+6 ; 3 - BIDT (opt) Date on which Age should be calculated.
+7 ;
+8 NEW BIDOB,X,X1,X2
IF $GET(BIZ)=""
SET BIZ=2
+9 IF '$GET(DFN)
QUIT "NO PATIENT"
+10 SET BIDOB=$$DOB(DFN)
+11 IF 'BIDOB
QUIT "Unknown"
+12 IF '$GET(BIDT)&($$DECEASED(DFN))
Begin DoDot:1
+13 SET X="DECEASED: "_$$TXDT1^BIUTL5(+^DPT(DFN,.35))
End DoDot:1
QUIT X
+14 IF '$GET(DT)
SET DT=$$DT^XLFDT
+15 IF '$GET(BIDT)
SET BIDT=DT
+16 IF BIDT<BIDOB
QUIT "NOT BORN"
+17 ;
+18 ;---> Age in Years.
+19 NEW BIAGEY,BIAGEM,BID1,BID2,BIM1,BIM2,BIY1,BIY2
+20 SET BIM1=$EXTRACT(BIDOB,4,7)
SET BIM2=$EXTRACT(BIDT,4,7)
+21 SET BIY1=$EXTRACT(BIDOB,1,3)
SET BIY2=$EXTRACT(BIDT,1,3)
+22 SET BIAGEY=BIY2-BIY1
IF BIM2<BIM1
SET BIAGEY=BIAGEY-1
+23 IF BIAGEY<1
SET BIAGEY="<1"
+24 IF BIZ=1
QUIT BIAGEY
+25 ;
+26 ;---> Age in Months.
+27 SET BID1=$EXTRACT(BIM1,3,4)
SET BIM1=$EXTRACT(BIM1,1,2)
+28 SET BID2=$EXTRACT(BIM2,3,4)
SET BIM2=$EXTRACT(BIM2,1,2)
+29 SET BIAGEM=12*BIAGEY
+30 IF BIM2=BIM1&(BID2<BID1)
SET BIAGEM=BIAGEM+12
+31 IF BIM2>BIM1
SET BIAGEM=BIAGEM+BIM2-BIM1
+32 IF BIM2<BIM1
SET BIAGEM=BIAGEM+BIM2+(12-BIM1)
+33 IF BID2<BID1
SET BIAGEM=BIAGEM-1
+34 IF BIZ=2
QUIT BIAGEM
+35 ;
+36 ;---> Age in Days.
+37 SET X1=BIDT
SET X2=BIDOB
+38 DO ^%DTC
+39 QUIT X
+40 ;
+41 ;
+42 ;----------
AGEF(DFN,BIDT) ;EP
+1 ;---> Age formatted "35 Months" or "23 Years"
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ; 2 - BIDT (opt) Date on which Age should be calculated.
+5 ;
+6 NEW Y
+7 SET Y=$$AGE(DFN,2,$GET(BIDT))
+8 IF Y["DECEASED"
QUIT Y
+9 IF Y["NOT BORN"
QUIT Y
+10 ;
+11 ;---> If over 60 months, return years.
+12 IF Y>60
SET Y=$$AGE(DFN,1,$GET(BIDT))
QUIT Y_$SELECT(Y=1:"year",1:" yrs")
+13 ;
+14 ;---> If under 1 month return days.
+15 IF Y<1
SET Y=$$AGE(DFN,3,$GET(BIDT))
QUIT Y_$SELECT(Y=1:" day",1:" days")
+16 ;
+17 ;---> Return months
+18 QUIT Y_$SELECT(Y=1:" mth",1:" mths")
+19 ;
+20 ;
+21 ;----------
DECEASED(DFN,BIDT) ;EP
+1 ;---> Return 1 if patient is deceased, 0 if not deceased.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ; 2 - BIDT (opt) If BIDT=1 return Date of Death (Fileman format).
+5 ;
+6 IF '$GET(DFN)
QUIT 0
+7 NEW X
SET X=+$GET(^DPT(DFN,.35))
+8 IF 'X
QUIT 0
+9 IF '$GET(BIDT)
QUIT 1
+10 QUIT X
+11 ;
+12 ;
+13 ;----------
SEX(DFN,PRON) ;EP
+1 ;---> Return "F" is patient is female, "M" if male.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ; 2 - PRON (opt) Pronoun: 1=he/she, 2=him/her,3=his,her
+5 ;
+6 IF '$GET(DFN)
QUIT ""
+7 IF '$DATA(^DPT(DFN,0))
QUIT ""
+8 NEW X
SET X=$PIECE(^DPT(DFN,0),U,2)
+9 IF '$GET(PRON)
QUIT X
+10 IF PRON=1
QUIT $SELECT(X="F":"she",1:"he")
+11 IF PRON=2
QUIT $SELECT(X="F":"her",1:"him")
+12 IF PRON=3
QUIT $SELECT(X="F":"her",1:"his")
+13 QUIT X
+14 ;
+15 ;
+16 ;----------
SEXW(DFN) ;EP
+1 ;---> Return Patient sex: "Female"/"Male".
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ;
+5 IF $$SEX(DFN)="M"
QUIT "Male"
+6 IF $$SEX(DFN)="F"
QUIT "Female"
+7 QUIT "Unknown"
+8 ;
+9 ;
+10 ;----------
ACTIVE(DFN) ;PEP - Return Patient's Active Status in Immunization Package.
+1 ;---> Return text of Patient's Active Status.
+2 ;---> $$ACTIVE^BIUTL1(DFN) will return values of either:
+3 ;---> "Deceased","Inactive", or "Active".
+4 ;---> Parameters:
+5 ; 1 - DFN (req) Patient's IEN (DFN).
+6 ;
+7 NEW X
+8 SET X=$$DECEASED(DFN)
+9 IF X>0
QUIT "Deceased"
+10 SET X=$$INACT(DFN)
+11 IF X
QUIT "Inactive"
+12 IF X]""
QUIT X
+13 QUIT "Active"
+14 ;
+15 ;
+16 ;----------
INACT(DFN,TEXT) ;PEP - Return date this patient became Inactive in Immunization.
+1 ;---> Return date this patient became Inactive.
+2 ;---> $$INACT^BIUTL1(DFN) will return values of either:
+3 ;---> "NO PATIENT","UNKNOWN", "NOT IN REGISTER", DATE INACTIVE, or null.
+4 ;
+5 ;---> NOTE: If $$INACT^BIUTL1(DFN)="" then the Patient is Active.
+6 ;
+7 ;---> Parameters:
+8 ; 1 - DFN (req) Patient's IEN (DFN).
+9 ; 2 - TEXT (opt) If TEXT=1, return text of date.
+10 ;
+11 IF '$GET(DFN)
QUIT "NO PATIENT"
+12 IF '$DATA(^DPT(DFN,0))
QUIT "UNKNOWN"
+13 IF '$DATA(^BIP(DFN,0))
QUIT "NOT IN REGISTER"
+14 NEW X
SET X=$PIECE(^BIP(DFN,0),U,8)
+15 IF 'X
QUIT ""
+16 IF '$GET(TEXT)
QUIT X
+17 QUIT $$TXDT1^BIUTL5(X)
+18 ;
+19 ;
+20 ;----------
INACTRE(DFN,BICODE) ;EP
+1 ;---> Return Reason for Inactive.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ; 2 - BICODE (opt) If BICODE=1 return Code rather than text.
+5 ;
+6 IF '$GET(DFN)
QUIT ""
+7 NEW X,Y,Z
SET X=$PIECE($GET(^BIP(DFN,0)),U,16)
+8 IF (X="")
QUIT ""
+9 SET Y=$PIECE($GET(^DD(9002084,.16,0)),U,3)
+10 SET Z=$PIECE($PIECE(Y,X_":",2),";")
+11 IF Z=""
SET Z="Not Recorded"
+12 QUIT Z
+13 ;
+14 ;
+15 ;----------
INACTUSR(DFN,Z) ;EP
+1 ;---> Return User who made this Patient Inactive.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ; 2 - Z (opt) If Z=1 return IEN of user.
+5 ;
+6 IF '$GET(DFN)
QUIT ""
+7 NEW X
SET X=$PIECE($GET(^BIP(DFN,0)),U,23)
+8 IF $GET(Z)
QUIT X
+9 QUIT $$PERSON(X)
+10 ;
+11 ;
+12 ;----------
INACTREG(DFN,DUZ2) ;EP
+1 ;---> Return 1 if patient does not have an Active Chart in
+2 ;---> RPMS Patient Registration at this site DUZ(2).
+3 ;---> Parameters:
+4 ; 1 - DFN (req) Patient's IEN (DFN).
+5 ; 2 - DUZ2 (req) IEN of site DUZ(2) to check for Active Chart.
+6 ;
+7 IF '$GET(DFN)
QUIT 1
+8 IF '$GET(DUZ2)
QUIT 1
+9 IF '$DATA(^AUPNPAT(DFN,41,DUZ2,0))
QUIT 1
+10 ;
+11 ;********** PATCH 1, SEP 21,2006, IHS/CMI/MWR
+12 ;---> Correct test for Active Chart at site DUZ2.
+13 ;Q:$P($D(^AUPNPAT(DFN,41,DUZ2,0)),"^",3) 1
+14 IF $PIECE(^AUPNPAT(DFN,41,DUZ2,0),"^",3)
QUIT 1
+15 ;**********
+16 ;
+17 QUIT 0
+18 ;
+19 ;
+20 ;----------
ENTERED(DFN,BIA,BIT) ;EP
+1 ;---> Return date this patient was entered.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ; 2 - BIA (opt) If BIA="", return Date Entered.
+5 ; If BIA=1, return 1 if Automatically entered during Scan.
+6 ; 3 - BIT (opt) If BIT=1, return text of Date or Auto field.
+7 ;
+8 IF '$GET(DFN)
QUIT ""
+9 IF '$DATA(^BIP(DFN,0))
QUIT ""
+10 NEW X,Y
+11 SET Y=$SELECT($GET(BIA):22,1:21)
+12 SET X=$PIECE(^BIP(DFN,0),U,Y)
+13 IF $GET(BIA)
QUIT $SELECT($GET(BIT):$SELECT(X:"Automatically",1:"Manually"),1:X)
+14 IF '$GET(BIT)
QUIT X
+15 QUIT $$TXDT1^BIUTL5(X)
+16 ;
+17 ;
+18 ;----------
MOVEDLOC(DFN) ;EP
+1 ;---> Return Location where patient moved is receiving treatment elsewhere.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ;
+5 IF '$GET(DFN)
QUIT ""
+6 QUIT $PIECE($GET(^BIP(DFN,0)),U,12)
+7 ;
+8 ;
+9 ;----------
LASTLET(DFN,TEXT) ;EP
+1 ;---> Return Fileman date of the last letter sent to this patient.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ; 2 - TEXT (opt) If TEXT=1, return text of date.
+5 ;
+6 IF '$GET(DFN)
QUIT 0
+7 IF '$DATA(^DPT(DFN,0))
QUIT "None"
+8 IF '$DATA(^BIP(DFN,0))
QUIT "Not in Register"
+9 NEW X
SET X=$PIECE(^BIP(DFN,0),U,14)
+10 IF 'X
QUIT "None"
+11 IF '$GET(TEXT)
QUIT X
+12 QUIT $$TXDT1^BIUTL5(X)
+13 ;
+14 ;
+15 ;----------
NAMAGE(DFN) ;EP
+1 ;---> Return Patient Name concatenated with age.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ;
+5 IF '$GET(DFN)
QUIT "NO PATIENT"
+6 QUIT $$NAME(DFN)_" ("_$$AGE(DFN)_"y/o)"
+7 ;
+8 ;
+9 ;----------
SSN(DFN) ;EP
+1 ;---> Return Social Security Number (SSN).
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 NEW X
+5 IF '$GET(DFN)
QUIT "NO PATIENT"
+6 IF '$DATA(^DPT(DFN,0))
QUIT "Unknown"
+7 SET X=$PIECE(^DPT(DFN,0),U,9)
+8 IF X']""
QUIT "Unknown"
+9 QUIT X
+10 ;
+11 ;
+12 ;----------
HRCN(DFN,DUZ2,BIX) ;EP
+1 ;---> Return IHS Health Record Number.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ; 2 - DUZ2 (opt) User's Site/Location IEN. If no DUZ2
+5 ; provided, function will look for DUZ(2).
+6 ; 3 - BIX (opt) If BIX=1 return HRCN with no dashes.
+7 ;
+8 ; vvv83
+9 IF '$GET(DUZ2)
SET DUZ2=$GET(DUZ(2))
+10 IF '$GET(DFN)!('$GET(DUZ2))
QUIT "No Value"
+11 IF '$DATA(^AUPNPAT(DFN,41,DUZ2,0))
QUIT "Not Here"
+12 IF '+$PIECE(^AUPNPAT(DFN,41,DUZ2,0),"^",2)
QUIT "No Rec#"
+13 NEW Y
SET Y=$PIECE(^AUPNPAT(DFN,41,DUZ2,0),"^",2)
+14 IF $GET(BIX)
QUIT Y
+15 IF '+Y
QUIT Y
+16 IF '$$DASH(DUZ2)
QUIT Y
+17 IF $LENGTH(Y)=7
Begin DoDot:1
+18 SET Y=$TRANSLATE("123-45-67",1234567,Y)
End DoDot:1
QUIT Y
+19 SET Y=$EXTRACT("00000",0,6-$LENGTH(Y))_Y
+20 SET Y=$TRANSLATE("12-34-56",123456,Y)
+21 QUIT Y
+22 ;
+23 ;
+24 ;----------
DASH(BIDUZ2) ;EP
+1 ;---> Return 1 if Site Parameter says return Chart#s with dashes.
+2 ;---> Parameters:
+3 ; 1 - BIDUZ2 (req) User's DUZ(2)
+4 ;
+5 QUIT +$PIECE($GET(^BISITE(+$GET(BIDUZ2),0)),U,12)
+6 ;
+7 ;
+8 ;----------
HPHONE(DFN) ;EP
+1 ;---> Return patient's home phone number.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ;
+5 IF '$GET(DFN)
QUIT "No Patient"
+6 IF '$DATA(^DPT(DFN,.13))
QUIT "Unknown"
+7 IF $PIECE(^DPT(DFN,.13),U)=""
QUIT "Unknown"
+8 QUIT $PIECE(^DPT(DFN,.13),U)
+9 ;
+10 ;
+11 ;********** PATCH 1, SEP 21,2006, IHS/CMI/MWR
+12 ;---> Add ability to retrieve 2nd and 3rd Street Address lines.
+13 ;----------
STREET(DFN,Z) ;EP
+1 ;---> Return patient's street address.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ; 2 - Z (opt) If Z=2 return Line 2 of patient's address.
+5 ; If Z=3 return Line 3 of patient's address.
+6 ;
+7 NEW X
SET X=$SELECT($GET(Z)=2:2,$GET(Z)=3:3,1:1)
+8 IF '$GET(DFN)
QUIT "No Patient"
+9 IF '$DATA(^DPT(DFN,.11))
QUIT "Unknown"
+10 ;---> Only return "Unknown" for the first line.
+11 IF $PIECE(^DPT(DFN,.11),U,X)=""
QUIT $SELECT(X=1:"Unknown",1:"")
+12 QUIT $PIECE(^DPT(DFN,.11),U,X)
+13 ;
+14 ;
+15 ;----------
CITY(DFN) ;EP
+1 ;---> Return patient's city.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ;
+5 IF '$GET(DFN)
QUIT "No Patient"
+6 IF '$DATA(^DPT(DFN,.11))
QUIT "Unknown"
+7 IF $PIECE(^DPT(DFN,.11),U,4)=""
QUIT "Unknown"
+8 QUIT $PIECE(^DPT(DFN,.11),U,4)
+9 ;
+10 ;
+11 ;----------
STATE(DFN) ;EP
+1 ;---> Return patient's state.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ;
+5 IF '$GET(DFN)
QUIT "No Patient"
+6 IF '$DATA(^DPT(DFN,.11))
QUIT "No State"
+7 IF $PIECE(^DPT(DFN,.11),U,5)=""
QUIT "No State"
+8 QUIT $PIECE(^DIC(5,$PIECE(^DPT(DFN,.11),U,5),0),U,2)
+9 ;
+10 ;
+11 ;----------
ZIP(DFN) ;EP
+1 ;---> Return patient's zipcode.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ;
+5 IF '$GET(DFN)
QUIT "No Patient"
+6 IF '$DATA(^DPT(DFN,.11))
QUIT "No Zip"
+7 IF $PIECE(^DPT(DFN,.11),U,6)=""
QUIT "No Zip"
+8 QUIT $PIECE(^DPT(DFN,.11),U,6)
+9 ;
+10 ;
+11 ;----------
CTYSTZ(DFN) ;EP
+1 ;---> Return patient's city, state zip.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ;
+5 IF '$GET(DFN)
QUIT "No Patient"
+6 QUIT $$CITY(DFN)_", "_$$STATE(DFN)_" "_$$ZIP(DFN)
+7 ;
+8 ;
+9 ;----------
CMGR(DFN,TEXT,ORDER) ;EP
+1 ;---> Return patient's Case Manager.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ; 2 - TEXT (opt) If TEXT=1, return text of Case Manager.
+5 ; 3 - ORDER (opt) ""/0=Last,First 1=First Last
+6 ;
+7 NEW Y
+8 IF '$GET(DFN)
QUIT "No Patient"
+9 IF '$DATA(^BIP(DFN,0))
QUIT "Unknown"
+10 SET Y=$PIECE(^BIP(DFN,0),U,10)
+11 IF '$GET(TEXT)
QUIT Y
+12 QUIT $$PERSON(Y,$GET(ORDER))
+13 ;
+14 ;
+15 ;----------
DPRV(DFN,TEXT,ORDER) ;EP
+1 ;---> Return patient's Designated Provider.
+2 ;---> Parameters:
+3 ; 1 - DFN (req) Patient's IEN (DFN).
+4 ; 2 - TEXT (opt) If TEXT=1, return text of Case Manager.
+5 ; 3 - ORDER (opt) ""/0=Last,First 1=First Last
+6 ;
+7 NEW Y,Z
+8 IF '$GET(DFN)
QUIT "No Patient"
+9 IF '$DATA(^BIP(DFN,0))
QUIT "Unknown"
+10 IF '$LENGTH($TEXT(^BDPAPI))
QUIT "No BDP Pkg"
+11 DO ALLDP^BDPAPI(DFN,"DESIGNATED PRIMARY PROVIDER",.Y)
+12 SET Z=$PIECE($GET(Y("DESIGNATED PRIMARY PROVIDER")),U,2)
+13 IF '$GET(TEXT)
QUIT Z
+14 QUIT $$PERSON(Z,$GET(ORDER))
+15 ;
+16 ;
+17 ;----------
PERSON(X,ORDER) ;EP
+1 ;---> Return person's name from File #200.
+2 ;---> Parameters:
+3 ; 1 - X (req) Person's IEN in New Person File #200.
+4 ; 2 - ORDER (opt) ""/0=Last,First 1=First Last
+5 ;
+6 IF 'X
QUIT "Unknown"
+7 IF '$DATA(^VA(200,X,0))
QUIT "Unknown"
+8 NEW Y
SET Y=$PIECE(^VA(200,X,0),U)
+9 IF '$GET(ORDER)
QUIT Y
+10 QUIT $$FL(Y)
+11 ;
+12 ;
+13 ;----------
PARENT(DFN,BIX) ;EP
+1 ;---> Return Patient's Parent/Guardian name as stored in the
+2 ;---> Immunization database.
+3 ;---> Parameters:
+4 ; 1 - DFN (req) Patient's IEN (DFN).
+5 ; 2 - BIX (opt) If BIX=1, return text for letter address
+6 ; (return text "Parent/Guardian of" if no data).
+7 NEW Y
+8 Begin DoDot:1
+9 IF '$GET(DFN)
SET Y=""
QUIT
+10 SET Y=$PIECE($GET(^BIP(DFN,0)),U,9)
End DoDot:1
+11 ;---> If no Parent/Guardian in Immunization, check Patient Reg.
+12 ;S:Y="" Y=?
+13 IF '$GET(BIX)
QUIT Y
+14 IF Y=""
QUIT "Parent/Guardian of"
+15 QUIT Y_", for"
+16 ;
+17 ;
+18 ;----------
INELIG(BIDFN) ;EP
+1 ;---> Return 1 if patient is Ineligible in RPMS Patient Registration.
+2 ;---> Parameters:
+3 ; 1 - BIDFN (req) Patient's IEN (DFN).
+4 ;
+5 IF '$GET(BIDFN)
QUIT 0
+6 IF $PIECE($GET(^AUPNPAT(BIDFN,11)),"^",12)="I"
QUIT 1
+7 QUIT 0
+8 ;
+9 ;
+10 ;----------
CONSENT(BIDFN) ;EP
+1 ;---> Return 1 if patient or guardian consented to participation in the state
+2 ;---> registry.
+3 ;---> Parameters:
+4 ; 1 - BIDFN (req) Patient's IEN (DFN).
+5 ;
+6 IF '$GET(BIDFN)
QUIT ""
+7 QUIT $PIECE($GET(^BIP(BIDFN,0)),"^",24)
