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