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

CIAU.m

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