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

BWUTL5.m

Go to the documentation of this file. 
  1. BWUTL5 ;IHS/ANMC/MWR/HJT - UTIL: ACC#, TITLES, SL/TX DATES;15-Feb-2003 22:14;PLS
  1.  ;;2.0;WOMEN'S HEALTH;**5,8**;MAY 16, 1996
  1.  ;Modified for Y2k Compliance  5/14/1999  IHS/DSD/HJT
  1.  ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
  1.  ;;  UTILITY: SETVARS, GENERATE ACCESSION#, MENUT, TITLE, CENTERT,
  1.  ;;  COPYLET, UPPERCASE XREF, CDC, SL/TX DATES.
  1.  ;
  1.  ;
  1. SETVARS ;EP
  1.  D XBKVAR
  1.  S:'$D(IOF) IOF="#"
  1.  S:'$D(BWPOP) BWPOP=0
  1.  Q
  1.  ;**************
  1.  ;---> XBKVAR INCORPORATED HERE FOR VA COMPATIBILITY.
  1. XBKVAR ;SET MINIMUM KERNEL VARIABLES;
  1.  ; FROM ;;2.5;XB;;MAR 20, 1991
  1.  ; FROM ;IHS/DSD/JCM 7/6/92 Added Set of DUZ("AG")
  1.  ;
  1.  S U="^"
  1.  I '$D(DUZ(2)),$D(^AUTTSITE(1,0)) S DUZ(2)=+^(0)
  1.  I '$D(DUZ(2)),$D(^AUTTLOC("SITE")) S DUZ(2)=+^(0)
  1.  I '$D(DUZ("AG")) S DUZ("AG")=$S($P($G(^XMB(1,0)),"^",8)]"":$P(^XMB(1,0),"^",8),1:"I") ;IHS/DSD/JCM 7/6/92
  1.  S:'($D(DUZ)#2) DUZ=0 S:'($D(DUZ(0))#2) DUZ(0)="" S:'($D(DUZ(2))#2) DUZ(2)=0
  1.  I '$D(DT) D NOW^%DTC S DT=X
  1.  S:'$D(DTIME) DTIME=999
  1.  K %,%H,%I
  1.  Q
  1.  ;**************
  1.  ;
  1.  ;
  1. ACCSSN(PCDTYPE) ;EP
  1.  ;---> GENERATE ACCESSION# FOR BW PROCEDURE FILE ENTRY.
  1.  ;---> REQUIRED VARIABLE: PCDTYPE=IEN OF PROCEDURE TYPE (#9002086.2)
  1.  N A,C,L,N,P,X
  1.  Q:'$D(PCDTYPE) ""
  1.  Q:'$D(^BWPN(PCDTYPE,0)) ""
  1.  S X=^BWPN(PCDTYPE,0)          ;X=0-NODE OF PROC TYPE
  1.  S P=$P(X,U,4)                 ;P=PREFIX
  1.  S L=$P(X,U,6)                 ;L=LAST ASSIGNED ACCESSION# FOR THIS PROC
  1.  S A=$P(L,"-")                 ;A=ACC YEAR
  1.  S C=$P(L,"-",2)               ;C=COUNTER
  1.  D NOW^%DTC S N=$E(%I(3),2,3)  ;N=YEAR NOW: 94
  1.  I A'=N S C=0
  1.  F  L +^BWPN(PCDTYPE,0):1 Q:$T
  1.  F  S C=C+1 S R=P_N_"-"_C Q:'$D(^BWPCD("B",R))
  1.  S $P(^BWPN(PCDTYPE,0),U,6)=N_"-"_C
  1.  L -^BWPN(PCDTYPE,0)
  1.  Q R  ;R=RESULT(NEW ACCESSION#)
  1.  ;
  1.  ;---> DISPLAY MENU TITLE FROM BW MENU OPTIONS.
  1.  ;---> REQUIRED VARIABLES: TITLE=TEXT TO BE CENTERED AND DISPLAYED.
  1.  ;--->                     DUZ(2)=CURRENT LOCATION TO BE DISPLAYED.
  1.  N BWTTAB,BWFAC,BWUNL,I
  1.  S:'$D(TITLE) TITLE="* NO TITLE SUPPLIED *"
  1.  S TITLE="*  "_TITLE_"  *"
  1.  S BWTTAB=39-($L(TITLE)/2)
  1.  W:$D(IOF) @IOF
  1.  W !?3,"WOMEN'S HEALTH:"
  1.  W ?BWTTAB,TITLE
  1.  W ?60,$E($$INSTTX^BWUTL6(DUZ(2)),1,20)
  1.  S BWUNL="" F I=1:1:$L(TITLE) S BWUNL=BWUNL_"="
  1.  W !?BWTTAB,BWUNL
  1.  Q
  1.  ;
  1. TITLE(TITLE) ;EP
  1.  ;---> DISPLAY A TITLE.
  1.  ;---> REQUIRED VARIABLES: TITLE=TEXT TO BE CENTERED AND DISPLAYED.
  1.  N BWTTAB
  1.  S:'$D(TITLE) TITLE="* NO TITLE SUPPLIED *"
  1.  S TITLE="* * *  WOMEN'S HEALTH: "_TITLE_"  * * *"
  1.  S BWTTAB=39-($L(TITLE)/2)
  1.  W:$D(IOF) @IOF
  1.  W !?BWTTAB,TITLE,!!
  1.  Q
  1.  ;
  1. CENTERT(TEXT) ;EP
  1.  ;---> ADD LEADING SPACES TO CENTER TEXT.
  1.  S:'$D(TEXT) TEXT="* NO TEXT SUPPLIED *"
  1.  N I
  1.  F I=1:1:(39-($L(TEXT)/2)) S TEXT=" "_TEXT
  1.  Q
  1.  ;
  1. UPPER() ;EP
  1.  S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1.  Q X
  1.  ;
  1. COPYLET ;EP
  1.  ;---> COPY TEXT OF GENERIC SAMPLE LETTER TO ONE OR MORE BW PURPOSES.
  1.  ;---> EDIT NEXT LINE TO INCLUDE IENS OF BW PURPOSES TO BE CHANGED.
  1.  ;F DA=15,16,18,19 D
  1.  S DA=0
  1.  F  S DA=$O(^BWNOTP(DA)) Q:'DA  D
  1.  .K ^BWNOTP(DA,1)
  1.  .S N=0
  1.  .F  S N=$O(^BWLET(1,1,N)) Q:'N  D
  1.  ..S ^BWNOTP(DA,1,N,0)=^BWLET(1,1,N,0)
  1.  .S ^BWNOTP(DA,1,0)=^BWLET(1,1,0)
  1.  Q
  1.  ;
  1.  ;
  1. UPXREF(X,BWGBL) ;EP
  1.  ;---> SET UPPERCASE XREF FOR X.  CALLED FROM MUMPS XREFS ON MIXED CASE
  1.  ;---> FIELDS WHERE AN ALL UPPERCASE LOOKUP IS NEEDED.
  1.  ;---> REQUIRED VARIABLES: BWGBL=GLOBAL ROOT OF FILE, X=TEXT TO BE
  1.  ;---> CROSSREFERENCED IN ALL UPPERCASE, DA=IEN.
  1.  Q:'$D(BWGBL)!('$D(X))
  1.  N BWX S BWX=X,X=$$UPPER
  1.  S @(BWGBL_"""U"",$E(X,1,30),DA)")=""
  1.  S X=BWX K BWGBL
  1.  Q
  1.  ;
  1. KUPXREF(X,BWGBL) ;EP
  1.  ;---> KILL UPPERCASE XREF FOR X.  CALLED FROM MUMPS XREFS ON MIXED CASE
  1.  ;---> FIELDS WHERE AN ALL UPPERCASE LOOKUP IS NEEDED.
  1.  ;---> REQUIRED VARIABLES: BWGBL=GLOBAL ROOT OF FILE, X=TEXT TO BE
  1.  ;---> CROSSREFERENCED IN ALL UPPERCASE, DA=IEN.
  1.  Q:'$D(BWGBL)!('$D(X))
  1.  N BWX S BWX=X,X=$$UPPER
  1.  K @(BWGBL_"""U"",$E(X,1,30),DA)")
  1.  S X=BWX K BWGBL
  1.  Q
  1.  ;
  1. CDC(SITE) ;EP
  1.  ;---> RETURN 1 IF THIS SITE IS EXPORTING DATA TO CDC.
  1.  Q:'$G(SITE) ""
  1.  Q:'$D(^BWSITE(SITE,0)) ""
  1.  Q $P(^BWSITE(SITE,0),U,12)
  1.  ;
  1. AGENCY(SITE) ;EP
  1.  ;---> RETURN TYPE OF AGENCY ("i"=IHS, "s"=STATE, "v"=VA, ETC.).
  1.  ;---> REQUIRED VARIABLE: SITE=DUZ(2)
  1.  ;---> IF SITE NOT PASSED OR PARAMETER NOT SET, IT DEFAULTS TO IHS.
  1.  Q:'$G(SITE) "i"
  1.  Q:'$D(^BWSITE(SITE,0)) "i"
  1.  Q $P(^BWSITE(SITE,0),U,15)
  1.  ;
  1. PNLAB(SITE) ;EP
  1.  ;---> RETURN TEXT FOR PATIENT NUMBER: "Chart#: " OR "   SSN: ".
  1.  I $$AGENCY(SITE)="i" Q "Chart#: "
  1.  Q "   SSN: "
  1.  ;
  1. PNLB(SITE) ;EP
  1.  ;---> RETURN UPPERCASE TEXT FOR PATIENT NUMBER, NO COLON/SPACES.
  1.  I $$AGENCY(SITE)="i" Q "CHART#"
  1.  Q "SSN"
  1.  ;
  1. CDCID(DFN,SITE) ;EP
  1.  ;---> GENERATE A UNIQUE PATIENT INDENTIFIER FOR CDC MDE EXPORT.
  1.  Q:'$$CDC(SITE) ""
  1.  ;---> QUIT IF ONE ALREADY EXISTS FOR THIS PATIENT.
  1.  I $D(^BWP(DFN,0)) Q:$P(^(0),U,20)]"" ""
  1.  N I,Y,Z
  1.  ;---> TAKE FIRST 4 CHARS OF LAST NAME (EXCHG PUNCTUATION FOR ZEROS).
  1.  S Y=$E($P($$NAME^BWUTL1(DFN),","),1,4)
  1.  S Y=$TR(Y," '-.,","00000")
  1.  F I=1:1:(4-$L(Y)) S Y=Y_0
  1.  ;---> TAKE FIRST INITIAL.
  1.  S Z=$E($P($$NAME^BWUTL1(DFN),",",2)) S:Z="" Z=0
  1.  ;---> CONCATENATE IN REVERSE ORDER.
  1.  S Y=$E(Y,4)_$E(Y,3)_$E(Y,2)_$E(Y)_Z
  1.  ;---> CONCATENATE FILEMAN DATE OF BIRTH.
  1.  S Y=Y_$E($$DOB^BWUTL1(DFN),2,7)
  1.  ;---> CONCATENATE LAST 4 DIGITS OF SSN (OR 9999 IF NO SSN).
  1.  S I=$E($$SSN^BWUTL1(DFN),6,9) S:'+I I=9999
  1.  Q Y_I
  1.  ;
  1. CDCEXP(IEN,SITE) ;EP
  1.  ;---> RETURNS 1 IF THIS PROCEDURE AT THIS SITE SHOULD BE FLAGGED FOR
  1.  ;---> EXPORT TO CDC.  IEN=IEN IN BW PROCEDURE TYPE FILE #9002086.2.
  1.  Q:'$G(IEN) ""
  1.  ;---> QUIT IF SITE NOT EXPORTING MDE'S TO CDC.
  1.  Q:'$$CDC(SITE) ""
  1.  Q:'$D(^BWPN(IEN)) ""
  1.  ;---> QUIT IF PROCEDURE SHOULD NOT BE EXPORTED.
  1.  Q:'$P(^BWPN(IEN,0),U,13) ""
  1.  Q 1
  1.  ;
  1. SLDT2(DATE) ;EP
  1.  ;---> CONVERT FILEMAN INTERNAL DATE TO "SLASH" FORMAT: MM/DD/YY.
  1.  ;---> DATE=DATE IN FILEMAN FORMAT.
  1.  Q:'$G(DATE) "NO DATE"
  1.  S DATE=$P(DATE,".")
  1.  Q:$L(DATE)'=7 DATE
  1.  Q:'$E(DATE,4,5) $E(DATE,1,3)+1700
  1.  ;Begin Y2k fix    5/14/1999  IHS/DSD/HJT
  1.  ;Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_$E(DATE,2,3)
  1.  Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_($E(DATE,1,3)+1700)  ;Y2000
  1.  ;Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3)
  1.  Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_($E(DATE,1,3)+1700)  ;Y2000
  1.  ;End Y2k fix
  1.  ;
  1.  ;
  1. SLDT1(DATE) ;EP
  1.  ;---> CONVERT FILEMAN INTERNAL DATE TO "SLASH" FORMAT: MM/DD/YY
  1.  ;---> PLUS TIME.
  1.  N Y
  1.  Q:'$D(DATE) "unknown"
  1.  S Y=DATE,DATE=$P(DATE,".")
  1.  Q:'DATE "NO DATE"
  1.  Q:$L(DATE)'=7 DATE
  1.  Q:'$E(DATE,4,5) $E(DATE,1,3)+1700
  1.  ;Begin Y2k fix
  1.  ;Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_$E(DATE,2,3)
  1.  Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_($E(DATE,1,3)+1700)  ;Y2000
  1.  D DD^%DT S:Y["@" Y=" @ "_$P($P(Y,"@",2),":",1,2)
  1.  ;Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3)_Y
  1.  Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_($E(DATE,1,3)+1700)_Y  ;Y2000
  1.  ;End Y2k fix
  1.  ;
  1. TXDT(DATE) ;EP
  1.  ;---> CONVERT FILEMAN INTERNAL DATE TO "TEXT" FORMAT: MMM DD,YYYY.
  1.  N Y
  1.  Q:'$D(DATE) "UNKNOWN"
  1.  S Y=DATE D DD^%DT
  1.  I Y[", " S Y=$P(Y,", ")_","_$P(Y,", ",2)
  1.  I Y["@" S Y=$P(Y,"@")_"  "_$P($P(Y,"@",2),":",1,2)
  1.  Q Y