BWUTL1 ;IHS/ANMC/MWR - UTIL: MOSTLY PATIENT DATA;11-Feb-2003 18:51;PLS
;;2.0;WOMEN'S HEALTH;**1,8**;MAY 16, 1996
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; UTILITY: PATIENT DEMOG, NEEDS, AND REGIMENS, DISPLAY PRIORITY,
;; PROCEDURE TYPE.
;; PATCHED AT LINELABELS BNEED AND REFS. IHS/ANMC/MWR 11/20/96
;
NAME(DFN) ;EP
; PATIENT NAME.
; REQ: DFN=IEN PATIENT FILE
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^DPT(DFN,0)) "UNKNOWN"
Q $P(^DPT(DFN,0),U)
;
DOB(DFN) ;EP
; RETURN PATIENT'S DATE OF BIRTH IN FILEMAN FORMAT.
; REQ: DFN=IEN PATIENT FILE
Q:'$G(DFN) "NO PATIENT"
Q:'$P(^DPT(DFN,0),U,3) "UNKNOWN"
Q $P(^DPT(DFN,0),U,3)
;
;
AGE(DFN) ;EP
; YIELD PATIENT'S AGE IN YEARS.
; REQ: DFN=IEN PATIENT FILE
N X,X1,X2
Q:'$G(DFN) "NO PATIENT"
S X2=$$DOB(DFN)
Q:'+X2 "UNKNOWN"
I $$DECEASED(DFN),'$G(BWCUTF) Q "DECEASED: "_$$SLDT2^BWUTL5(+^DPT(DFN,.35)) ;IHS/CIM/THL PATCH 8
I '$D(DT) D NOW^%DTC S DT=X
S X1=DT
D ^%DTC
Q $P(X/365.25,".")_"y/o"
;
DECEASED(DFN) ;EP
; RETURN 1 IF PATIENT IS DECEASED, 0 IF NOT DECEASED.
; REQ: DFN=IEN PATIENT FILE
Q:'$G(DFN) 0
Q:'$D(^DPT(DFN,.35)) 0
Q:'+^DPT(DFN,.35) 0
Q 1
;
SEX(DFN) ;EP
; RETURN 1 IF PATIENT IS FEMALE.
; REQ: DFN=IEN PATIENT FILE
Q:'$G(DFN) ""
Q:'$D(^DPT(DFN,0)) ""
Q:$P(^DPT(DFN,0),U,2)'="F" ""
Q 1
;
INACT(DFN) ;EP
; DATE THIS PATIENT BECAME INACTIVE
; REQ: DFN=IEN PATIENT FILE
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^DPT(DFN,0)) "UNKNOWN"
Q $P(^BWP(DFN,0),U,24)
;
AGEAT(DFN,DATE) ;EP
; YIELD PATIENT'S AGE IN YEARS AT GIVEN DATE.
; REQ: DFN =IEN PATIENT FILE
; DATE=DATE AT WHICH AGE IS DESIRED.
N X,X1,X2
Q:'$G(DFN) "NO PATIENT"
Q:'$G(DATE) "NO DATE"
S X2=$$DOB(DFN)
Q:'+X2 "UNKNOWN"
S X1=DATE
D ^%DTC
Q $P(X/365.25,".")_"y/o"
;
NAMAGE(DFN) ;EP
; PATIENT NAME CONCAT WITH AGE.
; REQ: DFN=IEN PATIENT FILE
Q:'$G(DFN) "NO PATIENT"
Q $$NAME(DFN)_" ("_$$AGE(DFN)_")"
;
SSN(DFN) ;EP
; SOCIAL SECURITY NUMBER.
; REQ: DFN=IEN PATIENT FILE
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
;
CDCID(DFN) ;EP
; CDC UNIQUE PATIENT ID.
; REQ: DFN=IEN PATIENT FILE
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^BWP(DFN,0)) "UNKNOWN"
Q $P(^BWP(DFN,0),U,20)
;
HRCN1(DFN,DUZ2) ;EP
; IHS HEALTH RECORD NUMBER, WITH NO DASHES INSERTED.
; REQUIRED VARIABLES: DFN, DUZ(2)
Q:'$G(DFN)!('$G(DUZ2)) "UNKNOWN1"
I '$D(^AUPNPAT(DFN,41,DUZ2,0)) Q "UNKNOWN2"
I '+$P(^AUPNPAT(DFN,41,DUZ2,0),"^",2) Q "UNKNOWN3"
Q $P(^AUPNPAT(DFN,41,DUZ2,0),"^",2)
;
HRCN(DFN,DUZ2) ;EP
; IHS HEALTH RECORD NUMBER. IF NOT IHS, RETURN SSN.
; REQ: DFN
; OPT: DUZ2 (SITE), IF NOT PASSED, ASSUMED =DUZ(2).
S:'$G(DUZ2) DUZ2=$G(DUZ(2))
I $$AGENCY^BWUTL5(DUZ2)'="i" Q $$SSN(DFN)
N Y S Y=$$HRCN1(DFN,DUZ2)
Q:'+Y 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
;
HPHONE(DFN) ;EP
; GET HOME PHONE#.
; REQ: DFN=IEN PATIENT FILE
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^DPT(DFN,.13)) "UNKNOWN"
Q:$P(^DPT(DFN,.13),U)="" "UNKNOWN"
Q $P(^DPT(DFN,.13),U)
;
STREET(DFN) ;EP
; GET STREET ADDRESS.
; REQ: DFN=IEN PATIENT FILE
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^DPT(DFN,.11)) "UNKNOWN"
Q:$P(^DPT(DFN,.11),U)="" "UNKNOWN"
Q $P(^DPT(DFN,.11),U)
;
CITY(DFN) ;EP
; GET CITY ADDRESS.
; REQ: DFN=IEN PATIENT FILE
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
; GET STATE ADDRESS.
; REQ: DFN=IEN PATIENT FILE
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^DPT(DFN,.11)) "UNKNOWN"
Q:$P(^DPT(DFN,.11),U,5)="" "UNKNOWN"
Q $P(^DIC(5,$P(^DPT(DFN,.11),U,5),0),U,2)
;
ZIP(DFN) ;EP
; GET ZIPCODE ADDRESS.
; REQ: DFN=IEN PATIENT FILE
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^DPT(DFN,.11)) "UNKNOWN"
Q:$P(^DPT(DFN,.11),U,6)="" "UNKNOWN"
Q $P(^DPT(DFN,.11),U,6)
;
CTYSTZ(DFN) ;EP
; GET ZIPCODE ADDRESS.
; REQ: DFN=IEN PATIENT FILE
Q:'$G(DFN) "NO PATIENT"
Q $$CITY(DFN)_", "_$$STATE(DFN)_" "_$$ZIP(DFN)
;
CURCOM(DFN) ;EP
; GET CURRENT COMMUNITY IEN (ITEM 6 ON PAGE 1 OF REGISTRATION).
; REQ: DFN=IEN PATIENT FILE
N Y
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^AUPNPAT(DFN,11)) "UNKNOWN1"
S Y=$P(^AUPNPAT(DFN,11),U,17)
Q:Y="" "UNKNOWN2"
Q:'$D(^AUTTCOM(Y,0)) "BAD POINTER"
Q Y
;
CMGR(DFN) ;EP
; YIELD PATIENT'S CASE MANAGER.
; REQ: DFN=IEN PATIENT FILE
N X
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^BWP(DFN,0)) "UNKNOWN"
S X=$P(^BWP(DFN,0),U,10)
Q $$PERSON(X)
;
PERSON(X) ;EP
; RETURN PERSON'S NAME FROM FILE #200.
Q:'X "UNKNOWN"
Q:'$D(^VA(200,X,0)) "UNKNOWN"
Q $P(^VA(200,X,0),U)
;
EDC(DFN) ;EP
; YIELD IF PATIENT IS PREGNANT, AND EDC.
; REQ: DFN=IEN PATIENT FILE
N X,Y
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^BWP(DFN,0)) "UNKNOWN"
S Y=$P(^BWP(DFN,0),U,13)
S X=$P(^BWP(DFN,0),U,14)
Q:'Y ""
S Y=" PREGNANT"
Q Y_", EDC: "_$S(X:$$SLDT2^BWUTL5(X),1:"NO DATE ")_" "
;
PAPRG(DFN,TXDT) ;EP
; YIELD PATIENT'S PAP REGIMEN AND DATE IT BEGAN.
; REQ: DFN=IEN PATIENT FILE
; OPT: TXDT=1 IF DATE SHOULD BE TEXT FORMAT.
N Y,X
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^BWP(DFN,0)) "UNKNOWN"
S Y=$P(^BWP(DFN,0),U,16)
S X=$P(^BWP(DFN,0),U,17) D Z(.X,$G(TXDT))
Q $$PAPRG1(Y)_" (began "_X_")"
;
PAPRG1(PREG) ;EP
; YIELD PATIENT'S PAP REGIMEN.
; REQ: PREG=IEN IN BW PAP REGIMEN FILE #9002086.03.
Q:'$G(PREG) "UNKNOWN"
Q:'$D(^BWPR(PREG,0)) "PAP REGIMEN MISSING"
Q $P(^BWPR(PREG,0),U)
;
CNEED(DFN,TXDT) ;PEP
; YIELD PATIENT'S CX TX NEED AND CX TX NEED DUE DATE.
; REQ: DFN=IEN PATIENT FILE
; OPT: TXDT=1 IF DATE SHOULD BE TEXT FORMAT.
N X,Y
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^BWP(DFN,0)) "UNKNOWN"
S Y=$P(^BWP(DFN,0),U,11)
Q:'Y "UNKNOWN"
Q:'$D(^BWCUR(Y,0)) "UNKNOWN"
S X=$P(^BWP(DFN,0),U,12) D Z(.X,$G(TXDT))
Q $E($P(^BWCUR(Y,0),U),1,22)_" (by "_X_")"
;
BNEED(DFN,TXDT) ;PEP
; YIELD PATIENT'S BR TX NEED AND BR TX NEED DUE DATE.
; REQ: DFN=IEN PATIENT FILE
; OPT: TXDT=1 IF DATE SHOULD BE TEXT FORMAT.
N X,Y,Z
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^BWP(DFN,0)) "UNKNOWN"
;S Y=$P(^BWP(BWDFN,0),U,18)
S Y=$P(^BWP(DFN,0),U,18) ;IHS/ANMC/MWR 11/20/96
Q:'Y "UNKNOWN"
Q:'$D(^BWMAMT(Y,0)) "UNKNOWN"
;S X=$P(^BWP(DFN,0),U,19) D Z(.X,$G(TXDT))
S X=$P(^BWP(DFN,0),U,19) D Z(.X,$G(TXDT)) ;IHS/ANMC/MWR 11/20/96
Q $E($P(^BWMAMT(Y,0),U),1,22)_" (by "_X_")"
;
DES(DFN) ;EP
; YIELD PATIENT'S STATUS AS A DES DAUGHTER: 1=YES, 0=NO.
; DFN=IEN PATIENT FILE
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^BWP(DFN,0)) "UNKNOWN"
Q:'$D(^DD(9002086,.15,0)) "^DD MISSING"
S X=$P(^BWP(DFN,0),U,15)
Q:X="" ""
Q $P($P(^DD(9002086,.15,0),X_":",2),";")
;
FAMHX(DFN) ;EP
; RETURN FAMILY HISTORY OF BREAST CANCER.
; DFN=IEN PATIENT FILE
N X
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^BWP(DFN,0)) "UNKNOWN"
Q:'$D(^DD(9002086,.23,0)) "^DD MISSING"
S X=$P(^BWP(DFN,0),U,23)
Q:X="" ""
Q $P($P(^DD(9002086,.23,0),X_":",2),";")
;
REFS(DFN) ;EP
; RETURN REFERRAL SOURCE FOR THIS PATIENT (INTO CDC PROGRAM).
; DFN=IEN PATIENT FILE
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^BWP(DFN,0)) "UNKNOWN"
Q:'$D(^DD(9002086,.22,0)) "^DD MISSING" ;IHS/ANMC/MWR 11/20/96
S X=$P(^BWP(DFN,0),U,22)
Q:X="" ""
Q $P($P(^DD(9002086,.22,0),X_":",2),";")
;
ENRLDT(DFN,TXDT) ;PEP
; YIELD PATIENT'S ENROLLMENT DATE.
; REQ: DFN=IEN PATIENT FILE
; OPT: TXDT=1 IF DATE SHOULD BE IN TEXT FORMAT.
N X
Q:'$G(DFN) "NO PATIENT"
Q:'$D(^BWP(DFN,0)) "UNKNOWN"
S X=$P(^BWP(DFN,0),U,21)
Q:'X "" D Z(.X,$G(TXDT))
Q X
;
Z(X,Z) ;EP
; SET Z = NUMERIC (1/1/95) OR TEXT (JAN 1,1995) FORMAT OF DATE.
; REQ: X=FILEMAN INTERNAL DATE FORMAT.
; OPT: Z=1 IF TEXT, 0/"" IF NUMERIC.
S X=$S($G(Z):$$TXDT^BWUTL5(X),1:$$SLDT2^BWUTL5(X))
Q
;
;
ACC(IEN) ;EP
; ACCESSION#; CONCATENATE SCREENING PAP IF IT EXISTS.
; IEN=IEN IN BW PROCEDURE FILE #9002086.1).
Q:'$G(IEN) "NO PROC"
Q:'$D(^BWPCD(IEN,0)) "NO PROC"
N X S X=$P(^BWPCD(IEN,0),U,30)
I X]"" I $D(^BWPCD(X,0)) S X=$P(^BWPCD(X,0),U),X=","_X
Q $E($P(^BWPCD(IEN,0),U)_X,1,19)
;
PRIOR() ;EP
; CALLED FROM BW NOTIF-EDITBLK-1 TO GET VALUE AND TEXT OF
; NOTIFICATION PRIORITY AND RESULT/REMINDER, FROM PURPOSE OF
; NOTIFICATION WHEN FIRST DISPLAYING SCREEN.
; REQ: DA=IEN OF NOTIFICATION.
N X
Q:'$D(DA) "UNKNOWN"
Q:'$D(^BWNOT(DA,0)) "UNKNOWN"
S X=$P(^BWNOT(DA,0),U,4)
Q:'X "UNKNOWN"
Q $$PRIOR1
;
PRIOR1() ;EP
; CALLED FROM BW NOTIF-EDITBLK-1 TO GET VALUE AND TEXT OF
; NOTIFICATION PRIORITY FROM PURPOSE OF NOTIFICATION AS AN
; ACTION WHEN EDITING PURPOSE OF NOTIFICATION. ALSO DISPLAY
; WHETHER PURPOSE IS A RESULT OR A REMINDER.
; REQ: X=IEN IN NOTIFICATION PURPOSE FILE.
N R,Y,Z
Q:'$D(X) "UNDEFINED"
Q:'X "UNKNOWN"
Q:'$D(^BWNOTP(X,0)) "UNKNOWN"
S Y=$P(^BWNOTP(X,0),U,2) D
.I 'Y S R="UNKNOWN" Q
.I '$D(^DD(9002086.404,.02,0)) S R="^DD MISSING"
.S R=$P($P(^DD(9002086.404,.02,0),Y_":",2),";")
S Z=$P(^BWNOTP(X,0),U,6)
Q:Z="" R
Q:Z R_", RESULT"
Q R_", REMINDER"
;
;
NTPROC() ;EP
; CALLED FROM BW NOTIF-EDITBLK-1(?) BLOCK TO DISPLAY PROCEDURE
; NAME, BASED ON ACCESSION# PTR, WHEN FIRST DISPLAYING SCREEN.
; REQ: X=ACCESSION# OF PROCEDURE
N X
S X=$P(^BWNOT(DA,0),U,6)
Q $$PROC
;
PROC() ;EP
; DISPLAY PROCEDURE TYPE OF THIS PROCEDURE.
; REQ: X=IEN OF PROCEDURE IN PROC FILE #9002086.1.
N BWY,BWYY,Y,Z S BWYY="INVALID ACC# OR PTR"
Q:X']"" ""
Q:'$D(^BWPCD(X,0)) BWYY
S BWY=$P(^BWPCD(X,0),U,4)
Q:'BWY BWYY
Q:'$D(^BWPN(BWY,0)) BWYY
S Z=$P(^BWPN(BWY,0),U)
; IF UNILATERAL AND LEFT/RIGHT HAS A VALUE, REPLACE "UNILATERAL"
; WITH LEFT OR RIGHT.
S Y=$P(^BWPCD(X,0),U,9)
S Y=$S(Y="l":"LEFT",Y="r":"RIGHT",1:"")
Q:Y="" Z
Q $P(Z," ")_" "_Y
;
PROC1() ;EP
; DISPLAY PROCEDURE TYPE OF THIS PROCEDURE, USING DA.
; CALLED BY BW PROC-HEADER-1, WHICH CANNOT USE X.
; REQ: DA=IEN OF PROCEDURE IN PROC FILE #9002086.1.
N X S X=DA
Q $$PROC
BWUTL1 ;IHS/ANMC/MWR - UTIL: MOSTLY PATIENT DATA;11-Feb-2003 18:51;PLS
+1 ;;2.0;WOMEN'S HEALTH;**1,8**;MAY 16, 1996
+2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; UTILITY: PATIENT DEMOG, NEEDS, AND REGIMENS, DISPLAY PRIORITY,
+4 ;; PROCEDURE TYPE.
+5 ;; PATCHED AT LINELABELS BNEED AND REFS. IHS/ANMC/MWR 11/20/96
+6 ;
NAME(DFN) ;EP
+1 ; PATIENT NAME.
+2 ; REQ: DFN=IEN PATIENT FILE
+3 IF '$GET(DFN)
QUIT "NO PATIENT"
+4 IF '$DATA(^DPT(DFN,0))
QUIT "UNKNOWN"
+5 QUIT $PIECE(^DPT(DFN,0),U)
+6 ;
DOB(DFN) ;EP
+1 ; RETURN PATIENT'S DATE OF BIRTH IN FILEMAN FORMAT.
+2 ; REQ: DFN=IEN PATIENT FILE
+3 IF '$GET(DFN)
QUIT "NO PATIENT"
+4 IF '$PIECE(^DPT(DFN,0),U,3)
QUIT "UNKNOWN"
+5 QUIT $PIECE(^DPT(DFN,0),U,3)
+6 ;
+7 ;
AGE(DFN) ;EP
+1 ; YIELD PATIENT'S AGE IN YEARS.
+2 ; REQ: DFN=IEN PATIENT FILE
+3 NEW X,X1,X2
+4 IF '$GET(DFN)
QUIT "NO PATIENT"
+5 SET X2=$$DOB(DFN)
+6 IF '+X2
QUIT "UNKNOWN"
+7 ;IHS/CIM/THL PATCH 8
IF $$DECEASED(DFN)
IF '$GET(BWCUTF)
QUIT "DECEASED: "_$$SLDT2^BWUTL5(+^DPT(DFN,.35))
+8 IF '$DATA(DT)
DO NOW^%DTC
SET DT=X
+9 SET X1=DT
+10 DO ^%DTC
+11 QUIT $PIECE(X/365.25,".")_"y/o"
+12 ;
DECEASED(DFN) ;EP
+1 ; RETURN 1 IF PATIENT IS DECEASED, 0 IF NOT DECEASED.
+2 ; REQ: DFN=IEN PATIENT FILE
+3 IF '$GET(DFN)
QUIT 0
+4 IF '$DATA(^DPT(DFN,.35))
QUIT 0
+5 IF '+^DPT(DFN,.35)
QUIT 0
+6 QUIT 1
+7 ;
SEX(DFN) ;EP
+1 ; RETURN 1 IF PATIENT IS FEMALE.
+2 ; REQ: DFN=IEN PATIENT FILE
+3 IF '$GET(DFN)
QUIT ""
+4 IF '$DATA(^DPT(DFN,0))
QUIT ""
+5 IF $PIECE(^DPT(DFN,0),U,2)'="F"
QUIT ""
+6 QUIT 1
+7 ;
INACT(DFN) ;EP
+1 ; DATE THIS PATIENT BECAME INACTIVE
+2 ; REQ: DFN=IEN PATIENT FILE
+3 IF '$GET(DFN)
QUIT "NO PATIENT"
+4 IF '$DATA(^DPT(DFN,0))
QUIT "UNKNOWN"
+5 QUIT $PIECE(^BWP(DFN,0),U,24)
+6 ;
AGEAT(DFN,DATE) ;EP
+1 ; YIELD PATIENT'S AGE IN YEARS AT GIVEN DATE.
+2 ; REQ: DFN =IEN PATIENT FILE
+3 ; DATE=DATE AT WHICH AGE IS DESIRED.
+4 NEW X,X1,X2
+5 IF '$GET(DFN)
QUIT "NO PATIENT"
+6 IF '$GET(DATE)
QUIT "NO DATE"
+7 SET X2=$$DOB(DFN)
+8 IF '+X2
QUIT "UNKNOWN"
+9 SET X1=DATE
+10 DO ^%DTC
+11 QUIT $PIECE(X/365.25,".")_"y/o"
+12 ;
NAMAGE(DFN) ;EP
+1 ; PATIENT NAME CONCAT WITH AGE.
+2 ; REQ: DFN=IEN PATIENT FILE
+3 IF '$GET(DFN)
QUIT "NO PATIENT"
+4 QUIT $$NAME(DFN)_" ("_$$AGE(DFN)_")"
+5 ;
SSN(DFN) ;EP
+1 ; SOCIAL SECURITY NUMBER.
+2 ; REQ: DFN=IEN PATIENT FILE
+3 NEW X
+4 IF '$GET(DFN)
QUIT "NO PATIENT"
+5 IF '$DATA(^DPT(DFN,0))
QUIT "UNKNOWN"
+6 SET X=$PIECE(^DPT(DFN,0),U,9)
+7 IF X']""
QUIT "UNKNOWN"
+8 QUIT X
+9 ;
CDCID(DFN) ;EP
+1 ; CDC UNIQUE PATIENT ID.
+2 ; REQ: DFN=IEN PATIENT FILE
+3 IF '$GET(DFN)
QUIT "NO PATIENT"
+4 IF '$DATA(^BWP(DFN,0))
QUIT "UNKNOWN"
+5 QUIT $PIECE(^BWP(DFN,0),U,20)
+6 ;
HRCN1(DFN,DUZ2) ;EP
+1 ; IHS HEALTH RECORD NUMBER, WITH NO DASHES INSERTED.
+2 ; REQUIRED VARIABLES: DFN, DUZ(2)
+3 IF '$GET(DFN)!('$GET(DUZ2))
QUIT "UNKNOWN1"
+4 IF '$DATA(^AUPNPAT(DFN,41,DUZ2,0))
QUIT "UNKNOWN2"
+5 IF '+$PIECE(^AUPNPAT(DFN,41,DUZ2,0),"^",2)
QUIT "UNKNOWN3"
+6 QUIT $PIECE(^AUPNPAT(DFN,41,DUZ2,0),"^",2)
+7 ;
HRCN(DFN,DUZ2) ;EP
+1 ; IHS HEALTH RECORD NUMBER. IF NOT IHS, RETURN SSN.
+2 ; REQ: DFN
+3 ; OPT: DUZ2 (SITE), IF NOT PASSED, ASSUMED =DUZ(2).
+4 IF '$GET(DUZ2)
SET DUZ2=$GET(DUZ(2))
+5 IF $$AGENCY^BWUTL5(DUZ2)'="i"
QUIT $$SSN(DFN)
+6 NEW Y
SET Y=$$HRCN1(DFN,DUZ2)
+7 IF '+Y
QUIT Y
+8 IF $LENGTH(Y)=7
Begin DoDot:1
+9 SET Y=$TRANSLATE("123-45-67",1234567,Y)
End DoDot:1
QUIT Y
+10 SET Y=$EXTRACT("00000",0,6-$LENGTH(Y))_Y
+11 SET Y=$TRANSLATE("12-34-56",123456,Y)
+12 QUIT Y
+13 ;
HPHONE(DFN) ;EP
+1 ; GET HOME PHONE#.
+2 ; REQ: DFN=IEN PATIENT FILE
+3 IF '$GET(DFN)
QUIT "NO PATIENT"
+4 IF '$DATA(^DPT(DFN,.13))
QUIT "UNKNOWN"
+5 IF $PIECE(^DPT(DFN,.13),U)=""
QUIT "UNKNOWN"
+6 QUIT $PIECE(^DPT(DFN,.13),U)
+7 ;
STREET(DFN) ;EP
+1 ; GET STREET ADDRESS.
+2 ; REQ: DFN=IEN PATIENT FILE
+3 IF '$GET(DFN)
QUIT "NO PATIENT"
+4 IF '$DATA(^DPT(DFN,.11))
QUIT "UNKNOWN"
+5 IF $PIECE(^DPT(DFN,.11),U)=""
QUIT "UNKNOWN"
+6 QUIT $PIECE(^DPT(DFN,.11),U)
+7 ;
CITY(DFN) ;EP
+1 ; GET CITY ADDRESS.
+2 ; REQ: DFN=IEN PATIENT FILE
+3 IF '$GET(DFN)
QUIT "NO PATIENT"
+4 IF '$DATA(^DPT(DFN,.11))
QUIT "UNKNOWN"
+5 IF $PIECE(^DPT(DFN,.11),U,4)=""
QUIT "UNKNOWN"
+6 QUIT $PIECE(^DPT(DFN,.11),U,4)
+7 ;
STATE(DFN) ;EP
+1 ; GET STATE ADDRESS.
+2 ; REQ: DFN=IEN PATIENT FILE
+3 IF '$GET(DFN)
QUIT "NO PATIENT"
+4 IF '$DATA(^DPT(DFN,.11))
QUIT "UNKNOWN"
+5 IF $PIECE(^DPT(DFN,.11),U,5)=""
QUIT "UNKNOWN"
+6 QUIT $PIECE(^DIC(5,$PIECE(^DPT(DFN,.11),U,5),0),U,2)
+7 ;
ZIP(DFN) ;EP
+1 ; GET ZIPCODE ADDRESS.
+2 ; REQ: DFN=IEN PATIENT FILE
+3 IF '$GET(DFN)
QUIT "NO PATIENT"
+4 IF '$DATA(^DPT(DFN,.11))
QUIT "UNKNOWN"
+5 IF $PIECE(^DPT(DFN,.11),U,6)=""
QUIT "UNKNOWN"
+6 QUIT $PIECE(^DPT(DFN,.11),U,6)
+7 ;
CTYSTZ(DFN) ;EP
+1 ; GET ZIPCODE ADDRESS.
+2 ; REQ: DFN=IEN PATIENT FILE
+3 IF '$GET(DFN)
QUIT "NO PATIENT"
+4 QUIT $$CITY(DFN)_", "_$$STATE(DFN)_" "_$$ZIP(DFN)
+5 ;
CURCOM(DFN) ;EP
+1 ; GET CURRENT COMMUNITY IEN (ITEM 6 ON PAGE 1 OF REGISTRATION).
+2 ; REQ: DFN=IEN PATIENT FILE
+3 NEW Y
+4 IF '$GET(DFN)
QUIT "NO PATIENT"
+5 IF '$DATA(^AUPNPAT(DFN,11))
QUIT "UNKNOWN1"
+6 SET Y=$PIECE(^AUPNPAT(DFN,11),U,17)
+7 IF Y=""
QUIT "UNKNOWN2"
+8 IF '$DATA(^AUTTCOM(Y,0))
QUIT "BAD POINTER"
+9 QUIT Y
+10 ;
CMGR(DFN) ;EP
+1 ; YIELD PATIENT'S CASE MANAGER.
+2 ; REQ: DFN=IEN PATIENT FILE
+3 NEW X
+4 IF '$GET(DFN)
QUIT "NO PATIENT"
+5 IF '$DATA(^BWP(DFN,0))
QUIT "UNKNOWN"
+6 SET X=$PIECE(^BWP(DFN,0),U,10)
+7 QUIT $$PERSON(X)
+8 ;
PERSON(X) ;EP
+1 ; RETURN PERSON'S NAME FROM FILE #200.
+2 IF 'X
QUIT "UNKNOWN"
+3 IF '$DATA(^VA(200,X,0))
QUIT "UNKNOWN"
+4 QUIT $PIECE(^VA(200,X,0),U)
+5 ;
EDC(DFN) ;EP
+1 ; YIELD IF PATIENT IS PREGNANT, AND EDC.
+2 ; REQ: DFN=IEN PATIENT FILE
+3 NEW X,Y
+4 IF '$GET(DFN)
QUIT "NO PATIENT"
+5 IF '$DATA(^BWP(DFN,0))
QUIT "UNKNOWN"
+6 SET Y=$PIECE(^BWP(DFN,0),U,13)
+7 SET X=$PIECE(^BWP(DFN,0),U,14)
+8 IF 'Y
QUIT ""
+9 SET Y=" PREGNANT"
+10 QUIT Y_", EDC: "_$SELECT(X:$$SLDT2^BWUTL5(X),1:"NO DATE ")_" "
+11 ;
PAPRG(DFN,TXDT) ;EP
+1 ; YIELD PATIENT'S PAP REGIMEN AND DATE IT BEGAN.
+2 ; REQ: DFN=IEN PATIENT FILE
+3 ; OPT: TXDT=1 IF DATE SHOULD BE TEXT FORMAT.
+4 NEW Y,X
+5 IF '$GET(DFN)
QUIT "NO PATIENT"
+6 IF '$DATA(^BWP(DFN,0))
QUIT "UNKNOWN"
+7 SET Y=$PIECE(^BWP(DFN,0),U,16)
+8 SET X=$PIECE(^BWP(DFN,0),U,17)
DO Z(.X,$GET(TXDT))
+9 QUIT $$PAPRG1(Y)_" (began "_X_")"
+10 ;
PAPRG1(PREG) ;EP
+1 ; YIELD PATIENT'S PAP REGIMEN.
+2 ; REQ: PREG=IEN IN BW PAP REGIMEN FILE #9002086.03.
+3 IF '$GET(PREG)
QUIT "UNKNOWN"
+4 IF '$DATA(^BWPR(PREG,0))
QUIT "PAP REGIMEN MISSING"
+5 QUIT $PIECE(^BWPR(PREG,0),U)
+6 ;
CNEED(DFN,TXDT) ;PEP
+1 ; YIELD PATIENT'S CX TX NEED AND CX TX NEED DUE DATE.
+2 ; REQ: DFN=IEN PATIENT FILE
+3 ; OPT: TXDT=1 IF DATE SHOULD BE TEXT FORMAT.
+4 NEW X,Y
+5 IF '$GET(DFN)
QUIT "NO PATIENT"
+6 IF '$DATA(^BWP(DFN,0))
QUIT "UNKNOWN"
+7 SET Y=$PIECE(^BWP(DFN,0),U,11)
+8 IF 'Y
QUIT "UNKNOWN"
+9 IF '$DATA(^BWCUR(Y,0))
QUIT "UNKNOWN"
+10 SET X=$PIECE(^BWP(DFN,0),U,12)
DO Z(.X,$GET(TXDT))
+11 QUIT $EXTRACT($PIECE(^BWCUR(Y,0),U),1,22)_" (by "_X_")"
+12 ;
BNEED(DFN,TXDT) ;PEP
+1 ; YIELD PATIENT'S BR TX NEED AND BR TX NEED DUE DATE.
+2 ; REQ: DFN=IEN PATIENT FILE
+3 ; OPT: TXDT=1 IF DATE SHOULD BE TEXT FORMAT.
+4 NEW X,Y,Z
+5 IF '$GET(DFN)
QUIT "NO PATIENT"
+6 IF '$DATA(^BWP(DFN,0))
QUIT "UNKNOWN"
+7 ;S Y=$P(^BWP(BWDFN,0),U,18)
+8 ;IHS/ANMC/MWR 11/20/96
SET Y=$PIECE(^BWP(DFN,0),U,18)
+9 IF 'Y
QUIT "UNKNOWN"
+10 IF '$DATA(^BWMAMT(Y,0))
QUIT "UNKNOWN"
+11 ;S X=$P(^BWP(DFN,0),U,19) D Z(.X,$G(TXDT))
+12 ;IHS/ANMC/MWR 11/20/96
SET X=$PIECE(^BWP(DFN,0),U,19)
DO Z(.X,$GET(TXDT))
+13 QUIT $EXTRACT($PIECE(^BWMAMT(Y,0),U),1,22)_" (by "_X_")"
+14 ;
DES(DFN) ;EP
+1 ; YIELD PATIENT'S STATUS AS A DES DAUGHTER: 1=YES, 0=NO.
+2 ; DFN=IEN PATIENT FILE
+3 IF '$GET(DFN)
QUIT "NO PATIENT"
+4 IF '$DATA(^BWP(DFN,0))
QUIT "UNKNOWN"
+5 IF '$DATA(^DD(9002086,.15,0))
QUIT "^DD MISSING"
+6 SET X=$PIECE(^BWP(DFN,0),U,15)
+7 IF X=""
QUIT ""
+8 QUIT $PIECE($PIECE(^DD(9002086,.15,0),X_":",2),";")
+9 ;
FAMHX(DFN) ;EP
+1 ; RETURN FAMILY HISTORY OF BREAST CANCER.
+2 ; DFN=IEN PATIENT FILE
+3 NEW X
+4 IF '$GET(DFN)
QUIT "NO PATIENT"
+5 IF '$DATA(^BWP(DFN,0))
QUIT "UNKNOWN"
+6 IF '$DATA(^DD(9002086,.23,0))
QUIT "^DD MISSING"
+7 SET X=$PIECE(^BWP(DFN,0),U,23)
+8 IF X=""
QUIT ""
+9 QUIT $PIECE($PIECE(^DD(9002086,.23,0),X_":",2),";")
+10 ;
REFS(DFN) ;EP
+1 ; RETURN REFERRAL SOURCE FOR THIS PATIENT (INTO CDC PROGRAM).
+2 ; DFN=IEN PATIENT FILE
+3 IF '$GET(DFN)
QUIT "NO PATIENT"
+4 IF '$DATA(^BWP(DFN,0))
QUIT "UNKNOWN"
+5 ;IHS/ANMC/MWR 11/20/96
IF '$DATA(^DD(9002086,.22,0))
QUIT "^DD MISSING"
+6 SET X=$PIECE(^BWP(DFN,0),U,22)
+7 IF X=""
QUIT ""
+8 QUIT $PIECE($PIECE(^DD(9002086,.22,0),X_":",2),";")
+9 ;
ENRLDT(DFN,TXDT) ;PEP
+1 ; YIELD PATIENT'S ENROLLMENT DATE.
+2 ; REQ: DFN=IEN PATIENT FILE
+3 ; OPT: TXDT=1 IF DATE SHOULD BE IN TEXT FORMAT.
+4 NEW X
+5 IF '$GET(DFN)
QUIT "NO PATIENT"
+6 IF '$DATA(^BWP(DFN,0))
QUIT "UNKNOWN"
+7 SET X=$PIECE(^BWP(DFN,0),U,21)
+8 IF 'X
QUIT ""
DO Z(.X,$GET(TXDT))
+9 QUIT X
+10 ;
Z(X,Z) ;EP
+1 ; SET Z = NUMERIC (1/1/95) OR TEXT (JAN 1,1995) FORMAT OF DATE.
+2 ; REQ: X=FILEMAN INTERNAL DATE FORMAT.
+3 ; OPT: Z=1 IF TEXT, 0/"" IF NUMERIC.
+4 SET X=$SELECT($GET(Z):$$TXDT^BWUTL5(X),1:$$SLDT2^BWUTL5(X))
+5 QUIT
+6 ;
+7 ;
ACC(IEN) ;EP
+1 ; ACCESSION#; CONCATENATE SCREENING PAP IF IT EXISTS.
+2 ; IEN=IEN IN BW PROCEDURE FILE #9002086.1).
+3 IF '$GET(IEN)
QUIT "NO PROC"
+4 IF '$DATA(^BWPCD(IEN,0))
QUIT "NO PROC"
+5 NEW X
SET X=$PIECE(^BWPCD(IEN,0),U,30)
+6 IF X]""
IF $DATA(^BWPCD(X,0))
SET X=$PIECE(^BWPCD(X,0),U)
SET X=","_X
+7 QUIT $EXTRACT($PIECE(^BWPCD(IEN,0),U)_X,1,19)
+8 ;
PRIOR() ;EP
+1 ; CALLED FROM BW NOTIF-EDITBLK-1 TO GET VALUE AND TEXT OF
+2 ; NOTIFICATION PRIORITY AND RESULT/REMINDER, FROM PURPOSE OF
+3 ; NOTIFICATION WHEN FIRST DISPLAYING SCREEN.
+4 ; REQ: DA=IEN OF NOTIFICATION.
+5 NEW X
+6 IF '$DATA(DA)
QUIT "UNKNOWN"
+7 IF '$DATA(^BWNOT(DA,0))
QUIT "UNKNOWN"
+8 SET X=$PIECE(^BWNOT(DA,0),U,4)
+9 IF 'X
QUIT "UNKNOWN"
+10 QUIT $$PRIOR1
+11 ;
PRIOR1() ;EP
+1 ; CALLED FROM BW NOTIF-EDITBLK-1 TO GET VALUE AND TEXT OF
+2 ; NOTIFICATION PRIORITY FROM PURPOSE OF NOTIFICATION AS AN
+3 ; ACTION WHEN EDITING PURPOSE OF NOTIFICATION. ALSO DISPLAY
+4 ; WHETHER PURPOSE IS A RESULT OR A REMINDER.
+5 ; REQ: X=IEN IN NOTIFICATION PURPOSE FILE.
+6 NEW R,Y,Z
+7 IF '$DATA(X)
QUIT "UNDEFINED"
+8 IF 'X
QUIT "UNKNOWN"
+9 IF '$DATA(^BWNOTP(X,0))
QUIT "UNKNOWN"
+10 SET Y=$PIECE(^BWNOTP(X,0),U,2)
Begin DoDot:1
+11 IF 'Y
SET R="UNKNOWN"
QUIT
+12 IF '$DATA(^DD(9002086.404,.02,0))
SET R="^DD MISSING"
+13 SET R=$PIECE($PIECE(^DD(9002086.404,.02,0),Y_":",2),";")
End DoDot:1
+14 SET Z=$PIECE(^BWNOTP(X,0),U,6)
+15 IF Z=""
QUIT R
+16 IF Z
QUIT R_", RESULT"
+17 QUIT R_", REMINDER"
+18 ;
+19 ;
NTPROC() ;EP
+1 ; CALLED FROM BW NOTIF-EDITBLK-1(?) BLOCK TO DISPLAY PROCEDURE
+2 ; NAME, BASED ON ACCESSION# PTR, WHEN FIRST DISPLAYING SCREEN.
+3 ; REQ: X=ACCESSION# OF PROCEDURE
+4 NEW X
+5 SET X=$PIECE(^BWNOT(DA,0),U,6)
+6 QUIT $$PROC
+7 ;
PROC() ;EP
+1 ; DISPLAY PROCEDURE TYPE OF THIS PROCEDURE.
+2 ; REQ: X=IEN OF PROCEDURE IN PROC FILE #9002086.1.
+3 NEW BWY,BWYY,Y,Z
SET BWYY="INVALID ACC# OR PTR"
+4 IF X']""
QUIT ""
+5 IF '$DATA(^BWPCD(X,0))
QUIT BWYY
+6 SET BWY=$PIECE(^BWPCD(X,0),U,4)
+7 IF 'BWY
QUIT BWYY
+8 IF '$DATA(^BWPN(BWY,0))
QUIT BWYY
+9 SET Z=$PIECE(^BWPN(BWY,0),U)
+10 ; IF UNILATERAL AND LEFT/RIGHT HAS A VALUE, REPLACE "UNILATERAL"
+11 ; WITH LEFT OR RIGHT.
+12 SET Y=$PIECE(^BWPCD(X,0),U,9)
+13 SET Y=$SELECT(Y="l":"LEFT",Y="r":"RIGHT",1:"")
+14 IF Y=""
QUIT Z
+15 QUIT $PIECE(Z," ")_" "_Y
+16 ;
PROC1() ;EP
+1 ; DISPLAY PROCEDURE TYPE OF THIS PROCEDURE, USING DA.
+2 ; CALLED BY BW PROC-HEADER-1, WHICH CANNOT USE X.
+3 ; REQ: DA=IEN OF PROCEDURE IN PROC FILE #9002086.1.
+4 NEW X
SET X=DA
+5 QUIT $$PROC
