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

BIUTL5.m

Go to the documentation of this file. 
  1. BIUTL5 ;IHS/CMI/MWR - UTIL: MENU TITLS, DATE FORMAT; MAY 10, 2010
  1.  ;;8.5;IMMUNIZATION;**8**;MAR 15,2014
  1.  ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
  1.  ;;  UTILITY: SETVARS, MENUT, TITLE, CENTERT, COPYLET,
  1.  ;;           UPPERCASE XREFS, DATE FORMATS, PADS/SPACES.
  1.  ;;  PATCH 4: Call to add a leading zero left of the decimal point. LEADZ+0
  1.  ;;  PATCH 5: Ensure that only one leading zero is displayed. LEADZ+8
  1.  ;;  PATCH 7: Changes to accommodate new TCH Forecaster. TCHFMDT+0, FMTCHDT+0
  1.  ;;  PATCH 8: New date format linelabels for TCH Forecaster.  IMMSDT+9
  1.  ;
  1.  ;
  1.  ;----------
  1. SETVARS ;EP
  1.  ;---> Set standard variables.
  1.  D ^XBKVAR
  1.  S:'$D(IOF) IOF="#"
  1.  Q
  1.  ;
  1.  ;
  1.  ;----------
  1.  ;---> Display menu title from BI Menu options.
  1.  ;---> REQUIRED VARIABLES: TITLE=TEXT TO BE CENTERED AND DISPLAYED.
  1.  ;--->                     DUZ(2)=CURRENT LOCATION TO BE DISPLAYED.
  1.  N BITTAB,BIFAC,BIUNL,I
  1.  S:'$D(TITLE) TITLE="* NO TITLE SUPPLIED *"
  1.  S TITLE="*  "_TITLE_"  *"
  1.  S BITTAB=39-($L(TITLE)/2)
  1.  W:$D(IOF) @IOF
  1.  W !?3,"IMMUNIZATION v"_$$VER^BILOGO
  1.  W ?BITTAB,TITLE
  1.  W ?53,"Site: ",$E($$INSTTX^BIUTL6(DUZ(2)),1,20)
  1.  S BIUNL="" F I=1:1:$L(TITLE) S BIUNL=BIUNL_"="
  1.  S BIUNL=$$SP(BITTAB)_BIUNL
  1.  S BIUNL=$$PAD(.BIUNL,53)_"User: "_$E($$PERSON^BIUTL1($G(DUZ)),1,20)
  1.  W !,BIUNL
  1.  Q
  1.  ;
  1.  ;
  1.  ;----------
  1. TITLE(BITL,BIONE) ;EP
  1.  ;---> Clear screen and display BITL (Immunization_version# prepended).
  1.  ;---> Parameters:
  1.  ;     1 - BITL  (req) Text to be centered and displayed.
  1.  ;     2 - BIONE (opt) If BIONE=1 then return only ONE linefeed after title.
  1.  ;
  1.  S:'$D(BITL) BITL="NO BITL SUPPLIED"
  1.  S BITL="*  "_BITL_"  *" D CENTERT(.BITL)
  1.  W:$D(IOF) @IOF
  1.  W " "_$$LMVER^BILOGO,!,BITL,!
  1.  W:'$G(BIONE) !
  1.  Q
  1.  ;
  1.  ;
  1.  ;----------
  1. CENTERT(TEXT,X) ;EP
  1.  ;---> Pad TEXT with leading spaces to center in 80 columns.
  1.  ;---> Parameters:
  1.  ;     1 - TEXT (req) Text to be centered.
  1.  ;     2 - X    (opt) Columns to adjust to the right.
  1.  ;
  1.  S:$G(TEXT)="" TEXT="* NO TEXT SUPPLIED *"
  1.  S:'$G(X) X=39
  1.  N I
  1.  F I=1:1:(X-($L(TEXT)/2)) S TEXT=" "_TEXT
  1.  Q
  1.  ;
  1.  ;
  1.  ;----------
  1. UPPER(X,L) ;EP
  1.  ;---> Translate X to all uppercase.
  1.  ;---> Parameters:
  1.  ;     1 - X  (req) Value to be translated into all uppercase.
  1.  ;     2 - L  (opt) If L=1, translate to all lowercase.
  1.  ;
  1.  I $G(L) S X=$TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") Q X
  1.  S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1.  Q X
  1.  ;
  1.  ;
  1.  ;----------
  1. UPXREF(X,BIGBL,Z) ;EP
  1.  ;---> Set uppercase xref for X.  Called from M xrefs on mixed case
  1.  ;---> fields where an all uppercase lookup is needed.
  1.  ;---> Parameters:
  1.  ;     1 - X     (req) The value that should be xrefed in uppercase.
  1.  ;     2 - BIGBL (req) The global root of the file.
  1.  ;
  1.  ;---> Variables:
  1.  ;     1 - DA    (req) IEN of the entry being xrefed.
  1.  S:$G(Z)="" Z="U"
  1.  Q:'$D(BIGBL)  Q:$G(X)=""  Q:'$G(DA)
  1.  S @(BIGBL_"""""_Z_"""",$E($$UPPER(X),1,30),DA)")=""
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1.  ;----------
  1. KUPXREF(X,BIGBL) ;EP
  1.  ;---> Kill uppercase xref for X.  Called from M xrefs on mixed case
  1.  ;---> fields where an all uppercase lookup is needed.
  1.  ;---> Parameters:
  1.  ;     1 - X     (req) The value that should be xrefed in uppercase.
  1.  ;     2 - BIGBL (req) The global root of the file.
  1.  ;
  1.  ;---> Variables:
  1.  ;     1 - DA    (req) IEN of the entry being xrefed.
  1.  ;
  1.  Q:'$D(BIGBL)  Q:$G(X)=""  Q:'$G(DA)
  1.  K @(BIGBL_"""U"",$E($$UPPER(X),1,30),DA)")
  1.  Q
  1.  ;
  1.  ;
  1.  ;----------
  1. SLDT2(DATE,YY) ;EP
  1.  ;---> Convert Fileman Internal Date to "slash" format: MM/DD/YYYY.
  1.  ;---> Parameters:
  1.  ;     1 - DATE (req) The date in Fileman format.
  1.  ;     2 - YY   (opt) If YY=1, return 2-digit year: MM/DD/YY.
  1.  ;
  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.  Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_$E(DATE,2,3)
  1.  Q:($G(YY)=1) $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(($E(DATE,1,3)+1700),3,4)
  1.  Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_($E(DATE,1,3)+1700)
  1.  ;
  1.  ;
  1.  ;----------
  1. SLDT1(DATE) ;EP
  1.  ;---> CONVERT FILEMAN INTERNAL DATE TO "SLASH" FORMAT:
  1.  ;---> MM/DD/YYYY @TIME
  1.  N Y,BITIME S BITIME=""
  1.  Q:'$D(DATE) "NO DATE"
  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.  Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_$E(DATE,2,3)
  1.  D DD^%DT
  1.  S:Y["@" BITIME=" @ "_$P($P(Y,"@",2),":",1,2)
  1.  Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_($E(DATE,1,3)+1700)_BITIME
  1.  ;
  1.  ;
  1.  ;----------
  1. NOSLDT(DATE) ;EP
  1.  ;---> CONVERT FILEMAN INTERNAL DATE TO "NO SLASH" FORMAT: MMDDYYYY.
  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,6,7)_($E(DATE,1,3)+1700)
  1.  ;
  1.  ;
  1.  ;----------
  1. IMMSDT(DATE) ;EP
  1.  ;---> Convert Immserve Date (format MMDDYYYY) TO FILEMAN
  1.  ;---> Internal format.
  1.  ;---> NOTE: This code is copied into routine ^BIPATUP1 for speed.
  1.  ;---> Any changes here should also be made to the call in ^BIPATUP1.
  1.  Q:'$G(DATE) "NO DATE"
  1.  Q ($E(DATE,5,9)-1700)_$E(DATE,1,2)_$E(DATE,3,4)
  1.  ;
  1.  ;
  1.  ;********** PATCH 8, v8.5, MAR 15,2014, IHS/CMI/MWR
  1.  ;---> Next two linelabels are new to accommodate TCH Forecaster.
  1.  ;
  1.  ;----------
  1. TCHFMDT(DATE) ;EP
  1.  ;---> Convert TCH Date (format YYYYMMDD) TO FILEMAN Internal format.
  1.  Q:'$G(DATE) "NO DATE"
  1.  Q ($E(DATE,1,4)-1700)_$E(DATE,5,6)_$E(DATE,7,8)
  1.  ;
  1.  ;
  1.  ;----------
  1. FMTCHDT(DATE) ;EP
  1.  ;---> Convert FILEMAN Date to TCH (format YYYYMMDD).
  1.  Q:'$G(DATE) "NO DATE"
  1.  Q ($E(DATE,1,3)+1700)_$E(DATE,4,5)_$E(DATE,6,7)
  1.  ;**********
  1.  ;
  1.  ;
  1.  ;----------
  1. TXDT1(DATE,TIME) ;EP
  1.  ;---> Return external date in format: DD-Mmm-YYYY@HH:MM, from Fileman
  1.  ;---> internal YYYMMDD.HHMM
  1.  ;---> Parameters:
  1.  ;     1 - DATE  (req) Internal Fileman date.
  1.  ;     2 - TIME  (opt)
  1.  ;
  1.  Q:'$G(DATE) "NO DATE"
  1.  N X,Y,Z
  1.  S X="Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec"
  1.  S Y=$E(DATE,6,7)_"-"_$P(X,U,$E(DATE,4,5))_"-"_($E(DATE,1,3)+1700)
  1.  S:'$E(DATE,6,7) Y=$E(Y,4,99)
  1.  S:'$E(DATE,4,5) Y=$E(DATE,1,3)+1700
  1.  Q:'$G(TIME) Y
  1.  S Z=$P(DATE,".",2)
  1.  Q:'Z Y
  1.  Q Y_" @"_$E(Z,1,2)_":"_$$PAD($E(Z,3,4),2,"0")
  1.  ;
  1.  ;
  1.  ;----------
  1. TXDT(DATE) ;EP
  1.  ;---> Return external date in format: MMM DD,YYYY
  1.  ;---> Parameters:
  1.  ;     1 - DATE  (req) Internal Fileman date (DT).
  1.  ;
  1.  N X,Y
  1.  Q:'$D(DATE) "NO DATE"
  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
  1.  ;
  1.  ;
  1.  ;----------
  1. NOW() ;EP
  1.  ;---> Return Current Date and Time in external format.
  1.  N %H,X,Y,Z
  1.  S %H=$H
  1.  D YX^%DTC
  1.  I Y["@" S Y=$P($P(Y,"@",2),":",1,2)
  1.  S Z=$$TXDT1(X)
  1.  S:Y]"" Z=Z_" @"_Y
  1.  Q Z
  1.  ;
  1.  ;
  1.  ;----------
  1. PAD(D,L,C) ;EP
  1.  ;---> Pad the length of data to a total of L characters
  1.  ;---> by adding spaces to the end of the data.
  1.  ;     Example: S X=$$PAD("MIKE",7)  X="MIKE   " (Added 3 spaces.)
  1.  ;---> Parameters:
  1.  ;     1 - D  (req) Data to be padded.
  1.  ;     2 - L  (req) Total length of resulting data.
  1.  ;     3 - C  (opt) Character to pad with (default=space).
  1.  ;
  1.  Q:'$D(D) ""
  1.  S:'$G(L) L=$L(D)
  1.  S:$G(C)="" C=" "
  1.  Q $E(D_$$REPEAT^XLFSTR(C,L),1,L)
  1.  ;
  1.  ;
  1.  ;----------
  1. SP(N,C) ;EP
  1.  ;---> Return N spaces or other character.
  1.  ;     Example: S X=$$SP(5)_X  Pads the front of X with 5 spaces.
  1.  ;---> Parameters:
  1.  ;     1 - N  (req) Number of spaces to be returned as extrinsic var.
  1.  ;     2 - C  (opt) Character to pad with (default=space).
  1.  ;
  1.  Q:$G(N)<1 ""
  1.  S:$G(C)="" C=" "
  1.  Q $$PAD(C,N,C)
  1.  ;
  1.  ;
  1.  ;----------
  1. STRIP(X) ;EP
  1.  ;---> Strip any punctuation characters from the beginning of X,
  1.  ;---> including spaces.
  1.  ;---> Parameters:
  1.  ;     1 - X  (req) String of characters.
  1.  ;
  1.  Q:$G(X)="" ""
  1.  F  Q:$E(X)'?1P  S X=$E(X,2,99)
  1.  Q X
  1.  ;
  1.  ;
  1.  ;----------
  1. COPYLET ;EP
  1.  ;---> COPY TEXT OF GENERIC SAMPLE LETTER TO ONE OR MORE BI PURPOSES.
  1.  ;---> EDIT NEXT LINE TO INCLUDE IENS OF BI PURPOSES TO BE CHANGED.
  1.  ;F DA=15,16,18,19 D
  1.  S DA=0
  1.  F  S DA=$O(^BINOTP(DA)) Q:'DA  D
  1.  .K ^BINOTP(DA,1)
  1.  .S N=0
  1.  .F  S N=$O(^BILET(1,1,N)) Q:'N  D
  1.  ..S ^BINOTP(DA,1,N,0)=^BILET(1,1,N,0)
  1.  .S ^BINOTP(DA,1,0)=^BILET(1,1,0)
  1.  Q
  1.  ;
  1.  ;
  1.  ;********** PATCH 4, v8.5, DEC 01,2012, IHS/CMI/MWR
  1.  ;---> New call to add leading zero.
  1.  ;----------
  1. LEADZ(X) ;EP
  1.  ;---> Add a leading zero left of the decimal point if this value is
  1.  ;---> less than 1 and greater than -1 and not equal to zero.
  1.  ;---> Parameters:
  1.  ;     1 - X  (req) Number to be evaulated and given a leading zero.
  1.  ;
  1.  Q:(+X=0) X
  1.  ;
  1.  ;********** PATCH 5, v8.5, JUL 01,2013, IHS/CMI/MWR
  1.  ;---> Ensure that only one leading zero is displayed.
  1.  Q:($E(X,1)=0) X
  1.  ;**********
  1.  I ((X<1)&(X>0)) S X="0"_X
  1.  I ((X>-1)&(X<0)) S X="-0"_-X
  1.  Q X
  1.  ;**********