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

BWUTL1.m

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