CIAU ;MSC/IND/DKM - General purpose utilities;12-Mar-2008 14:32;DKM
;;1.2;CIA UTILITIES;**1**;Mar 20, 2007
;;Copyright 2000-2006, Medsphere Systems Corporation
;=================================================================
; Replaces delimited arguments in string, returning result
MSG(%CIATXT,%CIADLM,%CIARPL) ;EP
N %CIAZ1,%CIAZ2
I $$NEWERR^%ZTER N $ET S $ET=""
S:$G(%CIADLM)="" %CIADLM="%"
S %CIAZ2="",@$$TRAP^CIAUOS("M1^CIAU")
S:$G(%CIARPL,1) %CIATXT=$TR(%CIATXT,"~","^")
F Q:%CIATXT="" D
.S %CIAZ2=%CIAZ2_$P(%CIATXT,%CIADLM),%CIAZ1=$P(%CIATXT,%CIADLM,2),%CIATXT=$P(%CIATXT,%CIADLM,3,999)
.I %CIAZ1="" S:%CIATXT'="" %CIAZ2=%CIAZ2_%CIADLM
.E X "S %CIAZ2=%CIAZ2_("_%CIAZ1_")"
M1 Q %CIAZ2
; Case-insensitive string comparison
; Returns 0: X=Y, 1: X>Y, -1: X<Y
STRICMP(X,Y) ;EP
S X=$$UP^XLFSTR(X),Y=$$UP^XLFSTR(Y)
Q $S(X=Y:0,X]]Y:1,1:-1)
; Output an underline X bytes long
UND(X) ;EP
Q $$REPEAT^XLFSTR("-",$G(X,$G(IOM,80)))
; Truncate a string if > Y bytes long
TRUNC(X,Y) ;EP
Q $S($L(X)'>Y:X,1:$E(X,1,Y-3)_"...")
; Formatting for singular/plural
SNGPLR(CIANUM,CIASNG,CIAPLR) ;EP
N CIAZ
S CIAZ=CIASNG?.E1L.E,CIAPLR=$G(CIAPLR,CIASNG_$S(CIAZ:"s",1:"S"))
Q $S('CIANUM:$S(CIAZ:"no ",1:"NO ")_CIAPLR,CIANUM=1:"1 "_CIASNG,1:CIANUM_" "_CIAPLR)
; Convert code to external form from set of codes
SET(CIACODE,CIASET) ;EP
N CIAZ,CIAZ1
F CIAZ=1:1:$L(CIASET,";") D Q:CIAZ1'=""
.S CIAZ1=$P(CIASET,";",CIAZ),CIAZ1=$S($P(CIAZ1,":")=CIACODE:$P(CIAZ1,":",2),1:"")
Q CIAZ1
; Replace each occurrence of CIAOLD in CIASTR with CIANEW
SUBST(CIASTR,CIAOLD,CIANEW) ;EP
N CIAP,CIAL1,CIAL2
S CIANEW=$G(CIANEW),CIAP=0,CIAL1=$L(CIAOLD),CIAL2=$L(CIANEW)
F S CIAP=$F(CIASTR,CIAOLD,CIAP) Q:'CIAP D
.S CIASTR=$E(CIASTR,1,CIAP-CIAL1-1)_CIANEW_$E(CIASTR,CIAP,9999)
.S CIAP=CIAP-CIAL1+CIAL2
Q CIASTR
; Trim leading (Y=-1)/trailing (Y=1)/leading & trailing (Y=0) spaces
TRIM(X,Y) ;EP
N CIAZ1,CIAZ2
S Y=+$G(Y),CIAZ1=1,CIAZ2=$L(X)
I Y'>0 F CIAZ1=1:1 Q:$A(X,CIAZ1)'=32
I Y'<0 F CIAZ2=CIAZ2:-1 Q:$A(X,CIAZ2)'=32
Q $E(X,CIAZ1,CIAZ2)
; Format a number with commas
FMTNUM(CIANUM) ;EP
N CIAZ,CIAZ1,CIAZ2,CIAZ3
S:CIANUM<0 CIANUM=-CIANUM,CIAZ2="-"
S CIAZ3=CIANUM#1,CIANUM=CIANUM\1
F CIAZ=$L(CIANUM):-3:1 S CIAZ1=$E(CIANUM,CIAZ-2,CIAZ)_$S($D(CIAZ1):","_CIAZ1,1:"")
Q $G(CIAZ2)_$G(CIAZ1)_$S(CIAZ3:CIAZ3,1:"")
; Convert X to base Y padded to length L
BASE(X,Y,L) ;EP
Q:(Y<2)!(Y>62) ""
N CIAZ,CIAZ1
S CIAZ1="",X=$S(X<0:-X,1:X)
F S CIAZ=X#Y,X=X\Y,CIAZ1=$C($S(CIAZ<10:CIAZ+48,CIAZ<36:CIAZ+55,1:CIAZ+61))_CIAZ1 Q:'X
Q $S('$G(L):CIAZ1,1:$$REPEAT^XLFSTR(0,L-$L(CIAZ1))_$E(CIAZ1,1,L))
; Convert a string to its SOUNDEX equivalent
SOUNDEX(CIAVALUE) ;EP
N CIACODE,CIASOUND,CIAPREV,CIACHAR,CIAPOS,CIATRANS
S CIACODE="01230129022455012623019202"
S CIASOUND=$C($A(CIAVALUE)-(CIAVALUE?1L.E*32))
S CIAPREV=$E(CIACODE,$A(CIAVALUE)-64)
F CIAPOS=2:1 S CIACHAR=$E(CIAVALUE,CIAPOS) Q:","[CIACHAR D Q:$L(CIASOUND)=4
.Q:CIACHAR'?1A
.S CIATRANS=$E(CIACODE,$A(CIACHAR)-$S(CIACHAR?1U:64,1:96))
.Q:CIATRANS=CIAPREV!(CIATRANS=9)
.S CIAPREV=CIATRANS
.S:CIATRANS'=0 CIASOUND=CIASOUND_CIATRANS
Q $E(CIASOUND_"000",1,4)
; Display formatted title
TITLE(CIATTL,CIAVER,CIAFN) ;EP
I '$D(IOM) N IOM,IOF S IOM=80,IOF="#"
S CIAVER=$G(CIAVER,"1.0")
S:CIAVER CIAVER="Version "_CIAVER
U $G(IO,$I)
W @IOF,$S(IO=IO(0):$C(27,91,55,109),1:""),*13,$$ENTRY^CIAUDT(+$H_","),?(IOM-$L(CIATTL)\2),CIATTL,?(IOM-$L(CIAVER)),CIAVER,!,$S(IO=IO(0):$C(27,91,109),1:$$UND),!
W:$D(CIAFN) ?(IOM-$L(CIAFN)\2),CIAFN,!
Q
; Display required header for menus
MNUHDR(PKG,VER) ;EP
Q:$D(ZTQUEUED)
Q:$E($G(IOST),1,2)'="C-"
N X,%ZIS,IORVON,IORVOFF,MNU
S MNU=$P($G(XQY0),U,2),MNU(0)=$P($G(XQY0),U),VER=$G(VER)
S X=$$GETPKG($S($L($G(PKG)):PKG,1:MNU(0)))
I $L(X) D
.S PKG=$P(X,U,2),X=$P(X,U,3)
.I $L(X),'$L(VER) S VER=$$VERSION^XPDUTL(X)
S:VER VER="Version "_VER
S X="IORVON;IORVOFF"
D ENDR^%ZISS
U IO
W @IOF,IORVON,$$GET1^DIQ(4,DUZ(2),.01),?(IOM-$L(PKG)\2),PKG,?(IOM-$L(VER)),VER,!,IORVOFF,!?(IOM-$L(MNU)\2),MNU,!
Q
; Execute menu action, preserving menu headers
MNUEXEC(EXEC,PAUSE) ;EP
D MNUHDR()
X EXEC
R:$G(PAUSE)&'$D(ZTQUEUED) !,"Press ENTER or RETURN to continue...",PAUSE:$G(DTIME,300),!
Q
; Action for editing parameters from menu
MNUPARAM(PARAM) ;EP
D MNUEXEC("D EDITPAR^XPAREDIT($G(PARAM,$P(XQY0,U)))")
Q
; Action for editing parameter template from menu
MNUTEMPL(TMPL) ;EP
D MNUEXEC("D TEDH^XPAREDIT($G(TMPL,$P(XQY0,U)),""BA"")")
Q
; Return package reference from namespace
; Returns ien^pkg name^pkg namespace
GETPKG(NAME) ;EP
N PKG,IEN
S PKG=NAME
F S PKG=$O(^DIC(9.4,"C",PKG),-1) Q:$E(NAME,1,$L(PKG))=PKG
S IEN=$S($L(PKG):+$O(^DIC(9.4,"C",PKG,0)),1:0)
Q $S(IEN:IEN_U_$P(^DIC(9.4,IEN,0),U)_U_PKG,1:"")
; Create a unique 8.3 filename
UFN(Y) ;EP
N X
S Y=$E($G(Y),1,3),X=$$BASE($R(100)_$J_$TR($H,","),36,$S($L(Y):8,1:11))_Y
Q $E(X,1,8)_"."_$E(X,9,11)
; Return formatted SSN
SSN(X) ;EP
Q $S(X="":X,1:$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,12))
; Performs security check on patient access
DGSEC(Y) ;EP
N DIC
S DIC(0)="E"
D ^DGSEC
Q $S(Y<1:0,1:Y)
; Displays spinning icon to indicate progress
WORKING(CIAST,CIAP,CIAS) ;EP
Q:'$D(IO(0))!$D(ZTQUEUED) 0
N CIAZ
S CIAZ(0)=$I,CIAS=$G(CIAS,"|/-\"),CIAST=+$G(CIAST)
S CIAST=$S(CIAST<0:0,1:CIAST#$L(CIAS)+1)
U IO(0)
W:'$G(CIAP) *8,*$S(CIAST:$A(CIAS,CIAST),1:32)
R *CIAZ:0
U CIAZ(0)
Q CIAZ=94
; Ask for Y/N response
ASK(CIAP,CIAD,CIAZ) ;EP
S CIAD=$G(CIAD,"N")
S CIAZ=$$GETCH(CIAP_"? ","YN",,,,CIAD)
S:CIAZ="" CIAZ=$E(CIAD)
W !
Q $S(CIAZ[U:"",1:CIAZ="Y")
; Pause for user response
PAUSE(CIAP,CIAX,CIAY) ;EP
Q $$GETCH($G(CIAP,"Press RETURN or ENTER to continue..."),U,.CIAX,.CIAY)
; Single character read
GETCH(CIAP,CIAV,CIAX,CIAY,CIAT,CIAD) ;EP
N CIAZ,CIAC
W:$D(CIAX)!$D(CIAY) $$XY($G(CIAX,$X),$G(CIAY,$Y))
W $G(CIAP),$E($G(CIAD)_" "),*8
S CIAT=$G(CIAT,$G(DTIME,99999999)),CIAD=$G(CIAD,U),CIAC=""
S:$D(CIAV) CIAV=$$UP^XLFSTR(CIAV)_U
F D Q:'$L(CIAZ)
.R CIAZ#1:CIAT
.E S CIAC=CIAD Q
.W *8
.Q:'$L(CIAZ)
.S CIAZ=$$UP^XLFSTR(CIAZ)
.I $D(CIAV) D
..I CIAV[CIAZ S CIAC=CIAZ
..E W *7,*32,*8 S CIAC=""
.E S CIAC=CIAZ
W !
Q CIAC
; Position cursor
XY(DX,DY) ;EP
D:$G(IOXY)="" HOME^%ZIS
S DX=$S(+$G(DX)>0:+DX,1:0),DY=$S(+$G(DY)>0:+DY,1:0),$X=0
X IOXY
S $X=DX,$Y=DY
Q ""
; Parameterized calls to date routines
DT(CIAD,CIAX) ;EP
N %D,%P,%C,%H,%I,%X,%Y,CIAZ
D DT^DILF($G(CIAX),CIAD,.CIAZ)
W:$D(CIAZ(0)) CIAZ(0),!
Q $G(CIAZ,-1)
DTC(X1,X2) ;EP
N X3
S X2=$$DTF(X1)+X2,X1=X1\1,X3=X2\1,X2=X2-X3
S:X2<0 X3=X3-1,X2=X2+1
Q $$FMADD^XLFDT(X1,X3)+$J($$DTT(X2),0,6)
DTD(X1,X2) ;EP
Q $$FMDIFF^XLFDT(X1\1,X2\1)+($$DTF(X1)-$$DTF(X2))
DTF(X) S X=X#1*100
Q X\1*3600+(X*100#100\1*60)+(X*10000#100)/86400
DTT(X) S X=X*86400
Q X\3600*100+(X#3600/3600*60)/10000
CIAU ;MSC/IND/DKM - General purpose utilities;12-Mar-2008 14:32;DKM
+1 ;;1.2;CIA UTILITIES;**1**;Mar 20, 2007
+2 ;;Copyright 2000-2006, Medsphere Systems Corporation
+3 ;=================================================================
+4 ; Replaces delimited arguments in string, returning result
MSG(%CIATXT,%CIADLM,%CIARPL) ;EP
+1 NEW %CIAZ1,%CIAZ2
+2 IF $$NEWERR^%ZTER
NEW $ETRAP
SET $ETRAP=""
+3 IF $GET(%CIADLM)=""
SET %CIADLM="%"
+4 SET %CIAZ2=""
SET @$$TRAP^CIAUOS("M1^CIAU")
+5 IF $GET(%CIARPL,1)
SET %CIATXT=$TRANSLATE(%CIATXT,"~","^")
+6 FOR
IF %CIATXT=""
QUIT
Begin DoDot:1
+7 SET %CIAZ2=%CIAZ2_$PIECE(%CIATXT,%CIADLM)
SET %CIAZ1=$PIECE(%CIATXT,%CIADLM,2)
SET %CIATXT=$PIECE(%CIATXT,%CIADLM,3,999)
+8 IF %CIAZ1=""
IF %CIATXT'=""
SET %CIAZ2=%CIAZ2_%CIADLM
+9 IF '$TEST
XECUTE "S %CIAZ2=%CIAZ2_("_%CIAZ1_")"
End DoDot:1
M1 QUIT %CIAZ2
+1 ; Case-insensitive string comparison
+2 ; Returns 0: X=Y, 1: X>Y, -1: X<Y
STRICMP(X,Y) ;EP
+1 SET X=$$UP^XLFSTR(X)
SET Y=$$UP^XLFSTR(Y)
+2 QUIT $SELECT(X=Y:0,X]]Y:1,1:-1)
+3 ; Output an underline X bytes long
UND(X) ;EP
+1 QUIT $$REPEAT^XLFSTR("-",$GET(X,$GET(IOM,80)))
+2 ; Truncate a string if > Y bytes long
TRUNC(X,Y) ;EP
+1 QUIT $SELECT($LENGTH(X)'>Y:X,1:$EXTRACT(X,1,Y-3)_"...")
+2 ; Formatting for singular/plural
SNGPLR(CIANUM,CIASNG,CIAPLR) ;EP
+1 NEW CIAZ
+2 SET CIAZ=CIASNG?.E1L.E
SET CIAPLR=$GET(CIAPLR,CIASNG_$SELECT(CIAZ:"s",1:"S"))
+3 QUIT $SELECT('CIANUM:$SELECT(CIAZ:"no ",1:"NO ")_CIAPLR,CIANUM=1:"1 "_CIASNG,1:CIANUM_" "_CIAPLR)
+4 ; Convert code to external form from set of codes
SET(CIACODE,CIASET) ;EP
+1 NEW CIAZ,CIAZ1
+2 FOR CIAZ=1:1:$LENGTH(CIASET,";")
Begin DoDot:1
+3 SET CIAZ1=$PIECE(CIASET,";",CIAZ)
SET CIAZ1=$SELECT($PIECE(CIAZ1,":")=CIACODE:$PIECE(CIAZ1,":",2),1:"")
End DoDot:1
IF CIAZ1'=""
QUIT
+4 QUIT CIAZ1
+5 ; Replace each occurrence of CIAOLD in CIASTR with CIANEW
SUBST(CIASTR,CIAOLD,CIANEW) ;EP
+1 NEW CIAP,CIAL1,CIAL2
+2 SET CIANEW=$GET(CIANEW)
SET CIAP=0
SET CIAL1=$LENGTH(CIAOLD)
SET CIAL2=$LENGTH(CIANEW)
+3 FOR
SET CIAP=$FIND(CIASTR,CIAOLD,CIAP)
IF 'CIAP
QUIT
Begin DoDot:1
+4 SET CIASTR=$EXTRACT(CIASTR,1,CIAP-CIAL1-1)_CIANEW_$EXTRACT(CIASTR,CIAP,9999)
+5 SET CIAP=CIAP-CIAL1+CIAL2
End DoDot:1
+6 QUIT CIASTR
+7 ; Trim leading (Y=-1)/trailing (Y=1)/leading & trailing (Y=0) spaces
TRIM(X,Y) ;EP
+1 NEW CIAZ1,CIAZ2
+2 SET Y=+$GET(Y)
SET CIAZ1=1
SET CIAZ2=$LENGTH(X)
+3 IF Y'>0
FOR CIAZ1=1:1
IF $ASCII(X,CIAZ1)'=32
QUIT
+4 IF Y'<0
FOR CIAZ2=CIAZ2:-1
IF $ASCII(X,CIAZ2)'=32
QUIT
+5 QUIT $EXTRACT(X,CIAZ1,CIAZ2)
+6 ; Format a number with commas
FMTNUM(CIANUM) ;EP
+1 NEW CIAZ,CIAZ1,CIAZ2,CIAZ3
+2 IF CIANUM<0
SET CIANUM=-CIANUM
SET CIAZ2="-"
+3 SET CIAZ3=CIANUM#1
SET CIANUM=CIANUM\1
+4 FOR CIAZ=$LENGTH(CIANUM):-3:1
SET CIAZ1=$EXTRACT(CIANUM,CIAZ-2,CIAZ)_$SELECT($DATA(CIAZ1):","_CIAZ1,1:"")
+5 QUIT $GET(CIAZ2)_$GET(CIAZ1)_$SELECT(CIAZ3:CIAZ3,1:"")
+6 ; Convert X to base Y padded to length L
BASE(X,Y,L) ;EP
+1 IF (Y<2)!(Y>62)
QUIT ""
+2 NEW CIAZ,CIAZ1
+3 SET CIAZ1=""
SET X=$SELECT(X<0:-X,1:X)
+4 FOR
SET CIAZ=X#Y
SET X=X\Y
SET CIAZ1=$CHAR($SELECT(CIAZ<10:CIAZ+48,CIAZ<36:CIAZ+55,1:CIAZ+61))_CIAZ1
IF 'X
QUIT
+5 QUIT $SELECT('$GET(L):CIAZ1,1:$$REPEAT^XLFSTR(0,L-$LENGTH(CIAZ1))_$EXTRACT(CIAZ1,1,L))
+6 ; Convert a string to its SOUNDEX equivalent
SOUNDEX(CIAVALUE) ;EP
+1 NEW CIACODE,CIASOUND,CIAPREV,CIACHAR,CIAPOS,CIATRANS
+2 SET CIACODE="01230129022455012623019202"
+3 SET CIASOUND=$CHAR($ASCII(CIAVALUE)-(CIAVALUE?1L.E*32))
+4 SET CIAPREV=$EXTRACT(CIACODE,$ASCII(CIAVALUE)-64)
+5 FOR CIAPOS=2:1
SET CIACHAR=$EXTRACT(CIAVALUE,CIAPOS)
IF ","[CIACHAR
QUIT
Begin DoDot:1
+6 IF CIACHAR'?1A
QUIT
+7 SET CIATRANS=$EXTRACT(CIACODE,$ASCII(CIACHAR)-$SELECT(CIACHAR?1U:64,1:96))
+8 IF CIATRANS=CIAPREV!(CIATRANS=9)
QUIT
+9 SET CIAPREV=CIATRANS
+10 IF CIATRANS'=0
SET CIASOUND=CIASOUND_CIATRANS
End DoDot:1
IF $LENGTH(CIASOUND)=4
QUIT
+11 QUIT $EXTRACT(CIASOUND_"000",1,4)
+12 ; Display formatted title
TITLE(CIATTL,CIAVER,CIAFN) ;EP
+1 IF '$DATA(IOM)
NEW IOM,IOF
SET IOM=80
SET IOF="#"
+2 SET CIAVER=$GET(CIAVER,"1.0")
+3 IF CIAVER
SET CIAVER="Version "_CIAVER
+4 USE $GET(IO,$IO)
+5 WRITE @IOF,$SELECT(IO=IO(0):$CHAR(27,91,55,109),1:""),*13,$$ENTRY^CIAUDT(+$HOROLOG_","),?(IOM-$LENGTH(CIATTL)\2),CIATTL,?(IOM-$LENGTH(CIAVER)),CIAVER,!,$SELECT(IO=IO(0):$CHAR(27,91,109),1:$$UND),!
+6 IF $DATA(CIAFN)
WRITE ?(IOM-$LENGTH(CIAFN)\2),CIAFN,!
+7 QUIT
+8 ; Display required header for menus
MNUHDR(PKG,VER) ;EP
+1 IF $DATA(ZTQUEUED)
QUIT
+2 IF $EXTRACT($GET(IOST),1,2)'="C-"
QUIT
+3 NEW X,%ZIS,IORVON,IORVOFF,MNU
+4 SET MNU=$PIECE($GET(XQY0),U,2)
SET MNU(0)=$PIECE($GET(XQY0),U)
SET VER=$GET(VER)
+5 SET X=$$GETPKG($SELECT($LENGTH($GET(PKG)):PKG,1:MNU(0)))
+6 IF $LENGTH(X)
Begin DoDot:1
+7 SET PKG=$PIECE(X,U,2)
SET X=$PIECE(X,U,3)
+8 IF $LENGTH(X)
IF '$LENGTH(VER)
SET VER=$$VERSION^XPDUTL(X)
End DoDot:1
+9 IF VER
SET VER="Version "_VER
+10 SET X="IORVON;IORVOFF"
+11 DO ENDR^%ZISS
+12 USE IO
+13 WRITE @IOF,IORVON,$$GET1^DIQ(4,DUZ(2),.01),?(IOM-$LENGTH(PKG)\2),PKG,?(IOM-$LENGTH(VER)),VER,!,IORVOFF,!?(IOM-$LENGTH(MNU)\2),MNU,!
+14 QUIT
+15 ; Execute menu action, preserving menu headers
MNUEXEC(EXEC,PAUSE) ;EP
+1 DO MNUHDR()
+2 XECUTE EXEC
+3 IF $GET(PAUSE)&'$DATA(ZTQUEUED)
READ !,"Press ENTER or RETURN to continue...",PAUSE:$GET(DTIME,300),!
+4 QUIT
+5 ; Action for editing parameters from menu
MNUPARAM(PARAM) ;EP
+1 DO MNUEXEC("D EDITPAR^XPAREDIT($G(PARAM,$P(XQY0,U)))")
+2 QUIT
+3 ; Action for editing parameter template from menu
MNUTEMPL(TMPL) ;EP
+1 DO MNUEXEC("D TEDH^XPAREDIT($G(TMPL,$P(XQY0,U)),""BA"")")
+2 QUIT
+3 ; Return package reference from namespace
+4 ; Returns ien^pkg name^pkg namespace
GETPKG(NAME) ;EP
+1 NEW PKG,IEN
+2 SET PKG=NAME
+3 FOR
SET PKG=$ORDER(^DIC(9.4,"C",PKG),-1)
IF $EXTRACT(NAME,1,$LENGTH(PKG))=PKG
QUIT
+4 SET IEN=$SELECT($LENGTH(PKG):+$ORDER(^DIC(9.4,"C",PKG,0)),1:0)
+5 QUIT $SELECT(IEN:IEN_U_$PIECE(^DIC(9.4,IEN,0),U)_U_PKG,1:"")
+6 ; Create a unique 8.3 filename
UFN(Y) ;EP
+1 NEW X
+2 SET Y=$EXTRACT($GET(Y),1,3)
SET X=$$BASE($RANDOM(100)_$JOB_$TRANSLATE($HOROLOG,","),36,$SELECT($LENGTH(Y):8,1:11))_Y
+3 QUIT $EXTRACT(X,1,8)_"."_$EXTRACT(X,9,11)
+4 ; Return formatted SSN
SSN(X) ;EP
+1 QUIT $SELECT(X="":X,1:$EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,12))
+2 ; Performs security check on patient access
DGSEC(Y) ;EP
+1 NEW DIC
+2 SET DIC(0)="E"
+3 DO ^DGSEC
+4 QUIT $SELECT(Y<1:0,1:Y)
+5 ; Displays spinning icon to indicate progress
WORKING(CIAST,CIAP,CIAS) ;EP
+1 IF '$DATA(IO(0))!$DATA(ZTQUEUED)
QUIT 0
+2 NEW CIAZ
+3 SET CIAZ(0)=$IO
SET CIAS=$GET(CIAS,"|/-\")
SET CIAST=+$GET(CIAST)
+4 SET CIAST=$SELECT(CIAST<0:0,1:CIAST#$LENGTH(CIAS)+1)
+5 USE IO(0)
+6 IF '$GET(CIAP)
WRITE *8,*$SELECT(CIAST:$ASCII(CIAS,CIAST),1:32)
+7 READ *CIAZ:0
+8 USE CIAZ(0)
+9 QUIT CIAZ=94
+10 ; Ask for Y/N response
ASK(CIAP,CIAD,CIAZ) ;EP
+1 SET CIAD=$GET(CIAD,"N")
+2 SET CIAZ=$$GETCH(CIAP_"? ","YN",,,,CIAD)
+3 IF CIAZ=""
SET CIAZ=$EXTRACT(CIAD)
+4 WRITE !
+5 QUIT $SELECT(CIAZ[U:"",1:CIAZ="Y")
+6 ; Pause for user response
PAUSE(CIAP,CIAX,CIAY) ;EP
+1 QUIT $$GETCH($GET(CIAP,"Press RETURN or ENTER to continue..."),U,.CIAX,.CIAY)
+2 ; Single character read
GETCH(CIAP,CIAV,CIAX,CIAY,CIAT,CIAD) ;EP
+1 NEW CIAZ,CIAC
+2 IF $DATA(CIAX)!$DATA(CIAY)
WRITE $$XY($GET(CIAX,$X),$GET(CIAY,$Y))
+3 WRITE $GET(CIAP),$EXTRACT($GET(CIAD)_" "),*8
+4 SET CIAT=$GET(CIAT,$GET(DTIME,99999999))
SET CIAD=$GET(CIAD,U)
SET CIAC=""
+5 IF $DATA(CIAV)
SET CIAV=$$UP^XLFSTR(CIAV)_U
+6 FOR
Begin DoDot:1
+7 READ CIAZ#1:CIAT
+8 IF '$TEST
SET CIAC=CIAD
QUIT
+9 WRITE *8
+10 IF '$LENGTH(CIAZ)
QUIT
+11 SET CIAZ=$$UP^XLFSTR(CIAZ)
+12 IF $DATA(CIAV)
Begin DoDot:2
+13 IF CIAV[CIAZ
SET CIAC=CIAZ
+14 IF '$TEST
WRITE *7,*32,*8
SET CIAC=""
End DoDot:2
+15 IF '$TEST
SET CIAC=CIAZ
End DoDot:1
IF '$LENGTH(CIAZ)
QUIT
+16 WRITE !
+17 QUIT CIAC
+18 ; Position cursor
XY(DX,DY) ;EP
+1 IF $GET(IOXY)=""
DO HOME^%ZIS
+2 SET DX=$SELECT(+$GET(DX)>0:+DX,1:0)
SET DY=$SELECT(+$GET(DY)>0:+DY,1:0)
SET $X=0
+3 XECUTE IOXY
+4 SET $X=DX
SET $Y=DY
+5 QUIT ""
+6 ; Parameterized calls to date routines
DT(CIAD,CIAX) ;EP
+1 NEW %D,%P,%C,%H,%I,%X,%Y,CIAZ
+2 DO DT^DILF($GET(CIAX),CIAD,.CIAZ)
+3 IF $DATA(CIAZ(0))
WRITE CIAZ(0),!
+4 QUIT $GET(CIAZ,-1)
DTC(X1,X2) ;EP
+1 NEW X3
+2 SET X2=$$DTF(X1)+X2
SET X1=X1\1
SET X3=X2\1
SET X2=X2-X3
+3 IF X2<0
SET X3=X3-1
SET X2=X2+1
+4 QUIT $$FMADD^XLFDT(X1,X3)+$JUSTIFY($$DTT(X2),0,6)
DTD(X1,X2) ;EP
+1 QUIT $$FMDIFF^XLFDT(X1\1,X2\1)+($$DTF(X1)-$$DTF(X2))
DTF(X) SET X=X#1*100
+1 QUIT X\1*3600+(X*100#100\1*60)+(X*10000#100)/86400
DTT(X) SET X=X*86400
+1 QUIT X\3600*100+(X#3600/3600*60)/10000
