INHUTIL ;JSH; 6 Mar 96 13:04;Function library part 1 - VA version
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;
SOC(P1,P2,SOC,T) ;Set of Codes front end to readers
;P1,P2 same as reader
;SOC = code string
;T = type of reader (0 = scrolling, 1 = screen)
N P21,I,J,X,DIC,Y
S $P(P1,";",9)="D TRANS^UTIL("_T_")",$P(P1,";",10)=""
K ^UTILITY("UTSOC",$J)
S P21="Choose from: " F I=1:1:$L(SOC,"^") S J=$P(SOC,"^",I) S:I>1 P21=P21_", " S P21=P21_J,^UTILITY("UTSOC",$J,I,0)=$P(SOC,U,I),^UTILITY("UTSOC",$J,"B",$P(SOC,U,I),I)=""
S ^UTILITY("UTSOC",$J,0)="CHOICE^1N^"_I_"^"_I S:$G(P2)="" P2=P21
D @("^UT"_$S($G(T):"W",1:"S")_"RD(P1,P2)") K ^UTILITY("UTSOC",$J) Q X
TRANS(%E) ;input transform for reader
;%E = manipulate echo (0=no, 1=yes)
Q:$E(X)="?" X:%E $G(^%ZOSF("EON"))
S DIC="^UTILITY(""UTSOC"",$J,",DIC(0)="EM" D ^DIC K:+Y<0 X I +Y>0 S X=$P(Y,U,2)
X:%E $G(^%ZOSF("EOFF")) Q
;
CENTER(S,L) ;center text S in field of length L
S S=$J("",L-$L(S)\2)_S Q S_$J("",L-$L(S))
;
LB(X) ;Returns X with leading spaces stripped
N I,Y S Y=X F I=1:1:$L(X) S:$E(X,I)=" " Y=$E(X,I+1,$L(X)) Q:$E(X,I)'=" "
Q Y
;
TB(X) ;Returns X with trailing spaces stripped
N I,Y S Y=X F I=$L(X):-1:0 S:$E(X,I)=" " Y=$E(X,1,I-1) Q:$E(X,I)'=" "
Q Y
;
LBTB(X) ;Returns X with both leading and trailing spaces removed
Q $$LB($$TB(X))
;
NOCTRL(X) ;Returns X with all control characters removed
;Control characters are $A values from 0-31,127
Q $TR(X,$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,127))
;
CASECONV(STRING,CODE) ;Returns STRING case converted according to CODE
;CODE = U (to upper case)
;CODE = L (to lower case)
S:'$D(CODE) CODE="U"
Q:CODE="U" $TR(STRING,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Q:CODE="L" $TR(STRING,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
Q STRING
;
NAME(NAME,F) ;Returns NAME (in FileMan storage form LAST,FIRST MIDDLE)
;formatted according to format string F.
N %F,%M,%L,%N,I S %L=$P(NAME,","),%F=$P($P(NAME,",",2)," "),%M=$P($P(NAME,",",2)," ",2)
S %N="" F I=1:1:$L(F) D
. I "FML"[$E(F,I) S %N=%N_@("%"_$E(F,I)) Q
. S %N=%N_$E(F,I) Q
Q %N
;
REPLACE(STRING,ST1,ST2) ;Replace all occurrences of ST1 in STRING with ST2
;Returns modified string.
N %1,%S S %S=""
F S %1=$F(STRING,ST1) Q:'%1 S %S=%S_$E(STRING,1,%1-$L(ST1)-1)_ST2,STRING=$E(STRING,%1,999)
Q %S_STRING
;
DUP(C,L) ;Returns a string of length L made by duplicating
;character(s) in C
N %,I,S S %=L\$L(C)+1,$P(S,C,%+1)="" Q $E(S,1,L)
;
FORMAT(S,W,D) ;Formats string S into an array referenced by D with a
;maximum length of W in each array subscript
N S1,I,% S %=1 K @D
F D Q:S=""!($TR(S," ")="")
. I $L(S)'>W S @D@(%)=S,S="" Q
. F I=W:-1:1 Q:$E(S,I)=" "
. S:I=1 I=W+1 S @D@(%)=$E(S,1,I-1),%=%+1,S=$E(S,I+(I'=(W+1)),999)
Q
;
JUST(S,W,T,P) ;returns string S in a field of width W
;T = "L" for left justify, = "R" for right justify
;P = 0 for pad with spaces, 1 = pad with zeros
N %P
S $P(%P,$S('P:" ",1:"0"),W-$L(S)+1)="",%P=$G(%P)
Q:T="L" $E(S,1,W)_%P Q %P_$E(S,1,W)
;
ENV ;Set up user environment
I '$G(DUZ) S DIC="^DIC(3,",DIC(0)="QAEM" D ^DIC Q:Y<0 S DUZ=+Y
X $G(^INRHSITE(1,1)) Q
;
ACTV(BIT) ;activate/inactivate all active messages in Script Generator
; Message file #4011
;input:
; BIT - (req,pbv) 1:inactive, 0:active
N INI,P01
S P01=""
F S P01=$O(^INTHL7M("B",P01)) Q:P01="" D
.S INI=""
.F S INI=$O(^INTHL7M("B",P01,INI)) Q:'INI D
..S $P(^INTHL7M(INI,0),U,8)=BIT
..W:$X>(IOM-($L(P01)+$S(BIT:11,1:9))) !
..W P01_$S(BIT:" in",1:" ")_"active. "
Q
QS(GLB,SUB) ; return subscript - temporary replacement for $QS
; Input:
; (r) GLB - Global node
; (r) SUB - Subscript of node
N I,N,P,PO,S,X,%
I SUB<1 S GLB=$TR($P(GLB,"("),"[]","||") D Q $G(X(SUB))
. I GLB["|" S X(-1)=$P(GLB,"|",2),X(-1)=$E(X(-1),2,$L(X(-1))-1),X(0)=$P(GLB,"|",1)_$P(GLB,"|",3)
. E S X(0)=GLB
S GLB=$P(GLB,"(",2),GLB=$E(GLB,1,$L(GLB)-1)
S S=1,P=1,PO=0 F S X(S)=$P(GLB,",",P,P+PO) Q:'$L(X(S)) S %=$L(X(S),"""")#2 S:% S=S+1,P=P+1+PO,PO=0 S:'% PO=PO+1 Q:S>SUB
S GLB=$G(X(SUB)),N=$E(GLB)
I 'N,N'=0 S GLB=$E(GLB,2,$L(GLB)-1),%=0 F S %=$F(GLB,"""""",%-1) Q:'% S GLB=$E(GLB,1,%-3)_""""_$E(GLB,%,999)
Q GLB
INHUTIL ;JSH; 6 Mar 96 13:04;Function library part 1 - VA version
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;
SOC(P1,P2,SOC,T) ;Set of Codes front end to readers
+1 ;P1,P2 same as reader
+2 ;SOC = code string
+3 ;T = type of reader (0 = scrolling, 1 = screen)
+4 NEW P21,I,J,X,DIC,Y
+5 SET $PIECE(P1,";",9)="D TRANS^UTIL("_T_")"
SET $PIECE(P1,";",10)=""
+6 KILL ^UTILITY("UTSOC",$JOB)
+7 SET P21="Choose from: "
FOR I=1:1:$LENGTH(SOC,"^")
SET J=$PIECE(SOC,"^",I)
IF I>1
SET P21=P21_", "
SET P21=P21_J
SET ^UTILITY("UTSOC",$JOB,I,0)=$PIECE(SOC,U,I)
SET ^UTILITY("UTSOC",$JOB,"B",$PIECE(SOC,U,I),I)=""
+8 SET ^UTILITY("UTSOC",$JOB,0)="CHOICE^1N^"_I_"^"_I
IF $GET(P2)=""
SET P2=P21
+9 DO @("^UT"_$SELECT($GET(T):"W",1:"S")_"RD(P1,P2)")
KILL ^UTILITY("UTSOC",$JOB)
QUIT X
TRANS(%E) ;input transform for reader
+1 ;%E = manipulate echo (0=no, 1=yes)
+2 IF $EXTRACT(X)="?"
QUIT
IF %E
XECUTE $GET(^%ZOSF("EON"))
+3 SET DIC="^UTILITY(""UTSOC"",$J,"
SET DIC(0)="EM"
DO ^DIC
IF +Y<0
KILL X
IF +Y>0
SET X=$PIECE(Y,U,2)
+4 IF %E
XECUTE $GET(^%ZOSF("EOFF"))
QUIT
+5 ;
CENTER(S,L) ;center text S in field of length L
+1 SET S=$JUSTIFY("",L-$LENGTH(S)\2)_S
QUIT S_$JUSTIFY("",L-$LENGTH(S))
+2 ;
LB(X) ;Returns X with leading spaces stripped
+1 NEW I,Y
SET Y=X
FOR I=1:1:$LENGTH(X)
IF $EXTRACT(X,I)=" "
SET Y=$EXTRACT(X,I+1,$LENGTH(X))
IF $EXTRACT(X,I)'=" "
QUIT
+2 QUIT Y
+3 ;
TB(X) ;Returns X with trailing spaces stripped
+1 NEW I,Y
SET Y=X
FOR I=$LENGTH(X):-1:0
IF $EXTRACT(X,I)=" "
SET Y=$EXTRACT(X,1,I-1)
IF $EXTRACT(X,I)'=" "
QUIT
+2 QUIT Y
+3 ;
LBTB(X) ;Returns X with both leading and trailing spaces removed
+1 QUIT $$LB($$TB(X))
+2 ;
NOCTRL(X) ;Returns X with all control characters removed
+1 ;Control characters are $A values from 0-31,127
+2 QUIT $TRANSLATE(X,$CHAR(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,127))
+3 ;
CASECONV(STRING,CODE) ;Returns STRING case converted according to CODE
+1 ;CODE = U (to upper case)
+2 ;CODE = L (to lower case)
+3 IF '$DATA(CODE)
SET CODE="U"
+4 IF CODE="U"
QUIT $TRANSLATE(STRING,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+5 IF CODE="L"
QUIT $TRANSLATE(STRING,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
+6 QUIT STRING
+7 ;
NAME(NAME,F) ;Returns NAME (in FileMan storage form LAST,FIRST MIDDLE)
+1 ;formatted according to format string F.
+2 NEW %F,%M,%L,%N,I
SET %L=$PIECE(NAME,",")
SET %F=$PIECE($PIECE(NAME,",",2)," ")
SET %M=$PIECE($PIECE(NAME,",",2)," ",2)
+3 SET %N=""
FOR I=1:1:$LENGTH(F)
Begin DoDot:1
+4 IF "FML"[$EXTRACT(F,I)
SET %N=%N_@("%"_$EXTRACT(F,I))
QUIT
+5 SET %N=%N_$EXTRACT(F,I)
QUIT
End DoDot:1
+6 QUIT %N
+7 ;
REPLACE(STRING,ST1,ST2) ;Replace all occurrences of ST1 in STRING with ST2
+1 ;Returns modified string.
+2 NEW %1,%S
SET %S=""
+3 FOR
SET %1=$FIND(STRING,ST1)
IF '%1
QUIT
SET %S=%S_$EXTRACT(STRING,1,%1-$LENGTH(ST1)-1)_ST2
SET STRING=$EXTRACT(STRING,%1,999)
+4 QUIT %S_STRING
+5 ;
DUP(C,L) ;Returns a string of length L made by duplicating
+1 ;character(s) in C
+2 NEW %,I,S
SET %=L\$LENGTH(C)+1
SET $PIECE(S,C,%+1)=""
QUIT $EXTRACT(S,1,L)
+3 ;
FORMAT(S,W,D) ;Formats string S into an array referenced by D with a
+1 ;maximum length of W in each array subscript
+2 NEW S1,I,%
SET %=1
KILL @D
+3 FOR
Begin DoDot:1
+4 IF $LENGTH(S)'>W
SET @D@(%)=S
SET S=""
QUIT
+5 FOR I=W:-1:1
IF $EXTRACT(S,I)=" "
QUIT
+6 IF I=1
SET I=W+1
SET @D@(%)=$EXTRACT(S,1,I-1)
SET %=%+1
SET S=$EXTRACT(S,I+(I'=(W+1)),999)
End DoDot:1
IF S=""!($TRANSLATE(S," ")="")
QUIT
+7 QUIT
+8 ;
JUST(S,W,T,P) ;returns string S in a field of width W
+1 ;T = "L" for left justify, = "R" for right justify
+2 ;P = 0 for pad with spaces, 1 = pad with zeros
+3 NEW %P
+4 SET $PIECE(%P,$SELECT('P:" ",1:"0"),W-$LENGTH(S)+1)=""
SET %P=$GET(%P)
+5 IF T="L"
QUIT $EXTRACT(S,1,W)_%P
QUIT %P_$EXTRACT(S,1,W)
+6 ;
ENV ;Set up user environment
+1 IF '$GET(DUZ)
SET DIC="^DIC(3,"
SET DIC(0)="QAEM"
DO ^DIC
IF Y<0
QUIT
SET DUZ=+Y
+2 XECUTE $GET(^INRHSITE(1,1))
QUIT
+3 ;
ACTV(BIT) ;activate/inactivate all active messages in Script Generator
+1 ; Message file #4011
+2 ;input:
+3 ; BIT - (req,pbv) 1:inactive, 0:active
+4 NEW INI,P01
+5 SET P01=""
+6 FOR
SET P01=$ORDER(^INTHL7M("B",P01))
IF P01=""
QUIT
Begin DoDot:1
+7 SET INI=""
+8 FOR
SET INI=$ORDER(^INTHL7M("B",P01,INI))
IF 'INI
QUIT
Begin DoDot:2
+9 SET $PIECE(^INTHL7M(INI,0),U,8)=BIT
+10 IF $X>(IOM-($LENGTH(P01)+$SELECT(BIT
WRITE !
+11 WRITE P01_$SELECT(BIT:" in",1:" ")_"active. "
End DoDot:2
End DoDot:1
+12 QUIT
QS(GLB,SUB) ; return subscript - temporary replacement for $QS
+1 ; Input:
+2 ; (r) GLB - Global node
+3 ; (r) SUB - Subscript of node
+4 NEW I,N,P,PO,S,X,%
+5 IF SUB<1
SET GLB=$TRANSLATE($PIECE(GLB,"("),"[]","||")
Begin DoDot:1
+6 IF GLB["|"
SET X(-1)=$PIECE(GLB,"|",2)
SET X(-1)=$EXTRACT(X(-1),2,$LENGTH(X(-1))-1)
SET X(0)=$PIECE(GLB,"|",1)_$PIECE(GLB,"|",3)
+7 IF '$TEST
SET X(0)=GLB
End DoDot:1
QUIT $GET(X(SUB))
+8 SET GLB=$PIECE(GLB,"(",2)
SET GLB=$EXTRACT(GLB,1,$LENGTH(GLB)-1)
+9 SET S=1
SET P=1
SET PO=0
FOR
SET X(S)=$PIECE(GLB,",",P,P+PO)
IF '$LENGTH(X(S))
QUIT
SET %=$LENGTH(X(S),"""")#2
IF %
SET S=S+1
SET P=P+1+PO
SET PO=0
IF '%
SET PO=PO+1
IF S>SUB
QUIT
+10 SET GLB=$GET(X(SUB))
SET N=$EXTRACT(GLB)
+11 IF 'N
IF N'=0
SET GLB=$EXTRACT(GLB,2,$LENGTH(GLB)-1)
SET %=0
FOR
SET %=$FIND(GLB,"""""",%-1)
IF '%
QUIT
SET GLB=$EXTRACT(GLB,1,%-3)_""""_$EXTRACT(GLB,%,999)
+12 QUIT GLB
