- BMXUTL5 ; IHS/OIT/HMW - DATE FORMAT ;
- ;;4.0;BMX;;JUN 28, 2010
- ;;Stolen from:* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
- ;; UTILITY: SETVARS, CENTERT, COPYLET,
- ;; UPPERCASE XREFS, DATE FORMATS, PADS/SPACES.
- ;
- ;
- ;----------
- SETVARS ;EP
- ;---> Set standard variables.
- D ^XBKVAR
- S:'$D(IOF) IOF="#"
- Q
- ;
- ;
- ;----------
- PHONFIX(X) ;EP
- ;---> Remove parentheses from Phone#.
- ;---> Parameters:
- ; 1 - X (req) Input Phone Number; returned without parentheses.
- ;
- Q:$G(X)=""
- S X=$TR(X,"(","")
- S X=$TR(X,")","-")
- S X=$TR(X,"/","-")
- S:X["- " X=$P(X,"- ")_"-"_$P(X,"- ",2)
- S:$E(X,4)=" " $E(X,4)="-"
- S:X["--" X=$P(X,"--")_"-"_$P(X,"--",2)
- S:X?7N X=$E(X,1,3)_"-"_$E(X,4,7)
- 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) ;EP
- ;---> Translate X to all uppercase.
- ;---> Parameters:
- ; 1 - X (req) Value to be translated into all uppercase.
- ;
- S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- Q X
- ;
- ;
- ;----------
- UPXREF(X,AGGBL) ;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 - AGGBL (req) The global root of the file.
- ;
- ;---> Variables:
- ; 1 - DA (req) IEN of the entry being xrefed.
- ;
- Q:'$D(AGGBL) Q:$G(X)="" Q:'$G(DA)
- S @(AGGBL_"""U"",$E($$UPPER(X),1,30),DA)")=""
- Q
- ;
- ;
- ;----------
- KUPXREF(X,AGGBL) ;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 - AGGBL (req) The global root of the file.
- ;
- ;---> Variables:
- ; 1 - DA (req) IEN of the entry being xrefed.
- ;
- Q:'$D(AGGBL) Q:$G(X)="" Q:'$G(DA)
- K @(AGGBL_"""U"",$E($$UPPER(X),1,30),DA)")
- Q
- ;
- ;
- ;----------
- SLDT2(DATE) ;EP
- ;---> CONVERT FILEMAN INTERNAL DATE TO "SLASH" FORMAT: MM/DD/YYYY.
- ;---> 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 $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
- 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["@" Y=" @ "_$P($P(Y,"@",2),":",1,2)
- Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_($E(DATE,1,3)+1700)_Y
- ;
- ;
- ;----------
- 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 ^AGPATUP1 for speed.
- ;---> Any changes here should also be made to the call in ^AGPATUP1.
- Q:'$G(DATE) "NO DATE"
- Q ($E(DATE,5,9)-1700)_$E(DATE,1,2)_$E(DATE,3,4)
- ;
- ;
- ;----------
- 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
- ;---> CONVERT FILEMAN INTERNAL DATE TO "TEXT" FORMAT: MMM DD,YYYY.
- N 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
- BMXUTL5 ; IHS/OIT/HMW - DATE FORMAT ;
- +1 ;;4.0;BMX;;JUN 28, 2010
- +2 ;;Stolen from:* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
- +3 ;; UTILITY: SETVARS, CENTERT, COPYLET,
- +4 ;; UPPERCASE XREFS, DATE FORMATS, PADS/SPACES.
- +5 ;
- +6 ;
- +7 ;----------
- SETVARS ;EP
- +1 ;---> Set standard variables.
- +2 DO ^XBKVAR
- +3 IF '$DATA(IOF)
- SET IOF="#"
- +4 QUIT
- +5 ;
- +6 ;
- +7 ;----------
- PHONFIX(X) ;EP
- +1 ;---> Remove parentheses from Phone#.
- +2 ;---> Parameters:
- +3 ; 1 - X (req) Input Phone Number; returned without parentheses.
- +4 ;
- +5 IF $GET(X)=""
- QUIT
- +6 SET X=$TRANSLATE(X,"(","")
- +7 SET X=$TRANSLATE(X,")","-")
- +8 SET X=$TRANSLATE(X,"/","-")
- +9 IF X["- "
- SET X=$PIECE(X,"- ")_"-"_$PIECE(X,"- ",2)
- +10 IF $EXTRACT(X,4)=" "
- SET $EXTRACT(X,4)="-"
- +11 IF X["--"
- SET X=$PIECE(X,"--")_"-"_$PIECE(X,"--",2)
- +12 IF X?7N
- SET X=$EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,7)
- +13 QUIT
- +14 ;
- +15 ;
- +16 ;----------
- 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) ;EP
- +1 ;---> Translate X to all uppercase.
- +2 ;---> Parameters:
- +3 ; 1 - X (req) Value to be translated into all uppercase.
- +4 ;
- +5 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- +6 QUIT X
- +7 ;
- +8 ;
- +9 ;----------
- UPXREF(X,AGGBL) ;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 - AGGBL (req) The global root of the file.
- +6 ;
- +7 ;---> Variables:
- +8 ; 1 - DA (req) IEN of the entry being xrefed.
- +9 ;
- +10 IF '$DATA(AGGBL)
- QUIT
- IF $GET(X)=""
- QUIT
- IF '$GET(DA)
- QUIT
- +11 SET @(AGGBL_"""U"",$E($$UPPER(X),1,30),DA)")=""
- +12 QUIT
- +13 ;
- +14 ;
- +15 ;----------
- KUPXREF(X,AGGBL) ;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 - AGGBL (req) The global root of the file.
- +6 ;
- +7 ;---> Variables:
- +8 ; 1 - DA (req) IEN of the entry being xrefed.
- +9 ;
- +10 IF '$DATA(AGGBL)
- QUIT
- IF $GET(X)=""
- QUIT
- IF '$GET(DA)
- QUIT
- +11 KILL @(AGGBL_"""U"",$E($$UPPER(X),1,30),DA)")
- +12 QUIT
- +13 ;
- +14 ;
- +15 ;----------
- SLDT2(DATE) ;EP
- +1 ;---> CONVERT FILEMAN INTERNAL DATE TO "SLASH" FORMAT: MM/DD/YYYY.
- +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 IF '$EXTRACT(DATE,4,5)
- QUIT $EXTRACT(DATE,1,3)+1700
- +7 IF '$EXTRACT(DATE,6,7)
- QUIT $EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,2,3)
- +8 QUIT $EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"/"_($EXTRACT(DATE,1,3)+1700)
- +9 ;
- +10 ;
- +11 ;----------
- SLDT1(DATE) ;EP
- +1 ;---> CONVERT FILEMAN INTERNAL DATE TO "SLASH" FORMAT:
- +2 ;---> MM/DD/YYYY @TIME
- +3 NEW Y
- +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
- IF Y["@"
- SET Y=" @ "_$PIECE($PIECE(Y,"@",2),":",1,2)
- +11 QUIT $EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"/"_($EXTRACT(DATE,1,3)+1700)_Y
- +12 ;
- +13 ;
- +14 ;----------
- 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 ^AGPATUP1 for speed.
- +4 ;---> Any changes here should also be made to the call in ^AGPATUP1.
- +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 ;----------
- 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 ;---> CONVERT FILEMAN INTERNAL DATE TO "TEXT" FORMAT: MMM DD,YYYY.
- +2 NEW Y
- +3 IF '$DATA(DATE)
- QUIT "NO DATE"
- +4 SET Y=DATE
- DO DD^%DT
- +5 IF Y[", "
- SET Y=$PIECE(Y,", ")_","_$PIECE(Y,", ",2)
- +6 IF Y["@"
- SET Y=$PIECE(Y,"@")_" "_$PIECE($PIECE(Y,"@",2),":",1,2)
- +7 QUIT Y
- +8 ;
- +9 ;
- +10 ;----------
- 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
