DIRCR ;SFISC/GFT-DELETE THIS LINE AND SAVE AS '%RCR'*** ;12:18 PM 20 Apr 1993
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;Per VHA Directive 10-93-142, this routine should not be modified.
%RCR ;GFT/SF
;
STORLIST ;
D INIT
O S %D=$O(%RCR(%D)) G CALL:%D=""
I $D(@%D)#2 S @(%E_")="_%D) G O:$D(@%D)=1
S %X=%D_"(" D %XY G O
;
CALL S %E=%RCR K %RCR,%X,%Y D @%E
S %E="^UTILITY(""%RCR"",$J,"_^UTILITY("%RCR",$J)_",%D",^($J)=^($J)-1,%D=0,%X=%E_","
G S %D=$O(@(%E_")")) I %D="" K %D,%E,%X,%Y,^($J,^UTILITY("%RCR",$J)+1) Q
I $D(^(%D))#2 S @%D=^(%D) G G:$D(^(%D))=1
S %Y=%D_"(" D %XY G G
;
;
XY(%X,%Y) ;
%XY ;
N %A,%B,%Q,%Z
S %A=$$R(%X),%Q=""""""
I $P(%A,"(",2)]"",$E(%A,$L(%A))'="," S:$L($P(%A,"(",2),",")>1 %Q=$P(%A,",",$L(%A,",")),$P(%A,",",$L(%A,","))="" S:%Q="""""" %Q=$P(%A,"(",2),$P(%A,"(",2)=""
S %Z=%A_%Q_")",%B=$L(%A)+1
F S %Z=$Q(@%Z) Q:$P(%Z,%A)]""!(%Z="") S @(%Y_$E(%Z,%B,255))=@%Z
Q
R(%R) ;
N %C,%F,%G,%I,%R1,%R2
S %R1=$P(%R,"(")_"(" I $E(%R1)="^" S %R2=$P($Q(@(%R1_""""")")),"(")_"(" S:$P(%R2,"(")]"" %R1=%R2
S %R2=$P($E(%R,1,($L(%R)-($E(%R,$L(%R))=")"))),"(",2,99)
S %C=$L(%R2,","),%F=1 F %I=1:1:%C S %G=$P(%R2,",",%F,%I) Q:%G="" I ($L(%G,"(")=$L(%G,")")&($L(%G,"""")#2))!(($L(%G,"""")#2)&($E(%G)="""")&($E(%G,$L(%G))="""")) S %G=$$S(%G),$P(%R2,",",%F,%I)=%G,%F=%F+$L(%G,","),%I=%F-1
Q %R1_%R2
S(%Z) ;
I $G(%Z)']"" Q ""
I $E(%Z)'="""",$L(%Z,"E")=2,+$P(%Z,"E")=$P(%Z,"E"),+$P(%Z,"E",2)=$P(%Z,"E",2) Q +%Z
I +%Z=%Z Q %Z
I %Z="""""" Q ""
I $E(%Z)'?1A,"%$+@"'[$E(%Z) Q %Z
I "+$"[$E(%Z) X "S %Z="_%Z Q $$Q(%Z)
I $D(@%Z) Q $$Q(@%Z)
Q %Z
Q(%Z) ;
S %Z(%Z)="",%Z=$Q(%Z("")) Q $E(%Z,4,$L(%Z)-1)
;
INIT I $D(^UTILITY("%RCR",$J))[0 S ^UTILITY("%RCR",$J)=0
S ^($J)=^($J)+1,%D="%Z",%E="^UTILITY(""%RCR"",$J,"_^($J)_",%D",%Y=%E_","
K ^($J,^($J))
Q
OS ;
S $P(^%ZOSF("OS"),"^",2)=DITZS
K DITZS S ZTREQ="@"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIRCR 2149 printed Apr 09, 2024@21:56:07 Page 2
DIRCR ;SFISC/GFT-DELETE THIS LINE AND SAVE AS '%RCR'*** ;12:18 PM 20 Apr 1993
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;Per VHA Directive 10-93-142, this routine should not be modified.
%RCR ;GFT/SF
+1 ;
STORLIST ;
+1 DO INIT
O SET %D=$ORDER(%RCR(%D))
if %D=""
GOTO CALL
+1 IF $DATA(@%D)#2
SET @(%E_")="_%D)
if $DATA(@%D)=1
GOTO O
+2 SET %X=%D_"("
DO %XY
GOTO O
+3 ;
CALL SET %E=%RCR
KILL %RCR,%X,%Y
DO @%E
+1 SET %E="^UTILITY(""%RCR"",$J,"_^UTILITY("%RCR",$JOB)_",%D"
SET ^($JOB)=^($JOB)-1
SET %D=0
SET %X=%E_","
G SET %D=$ORDER(@(%E_")"))
IF %D=""
KILL %D,%E,%X,%Y,^($JOB,^UTILITY("%RCR",$JOB)+1)
QUIT
+1 IF $DATA(^(%D))#2
SET @%D=^(%D)
if $DATA(^(%D))=1
GOTO G
+2 SET %Y=%D_"("
DO %XY
GOTO G
+3 ;
+4 ;
XY(%X,%Y) ;
%XY ;
+1 NEW %A,%B,%Q,%Z
+2 SET %A=$$R(%X)
SET %Q=""""""
+3 IF $PIECE(%A,"(",2)]""
IF $EXTRACT(%A,$LENGTH(%A))'=","
if $LENGTH($PIECE(%A,"(",2),",")>1
SET %Q=$PIECE(%A,",",$LENGTH(%A,","))
SET $PIECE(%A,",",$LENGTH(%A,","))=""
if %Q=""""""
SET %Q=$PIECE(%A,"(",2)
SET $PIECE(%A,"(",2)=""
+4 SET %Z=%A_%Q_")"
SET %B=$LENGTH(%A)+1
+5 FOR
SET %Z=$QUERY(@%Z)
if $PIECE(%Z,%A)]""!(%Z="")
QUIT
SET @(%Y_$EXTRACT(%Z,%B,255))=@%Z
+6 QUIT
R(%R) ;
+1 NEW %C,%F,%G,%I,%R1,%R2
+2 SET %R1=$PIECE(%R,"(")_"("
IF $EXTRACT(%R1)="^"
SET %R2=$PIECE($QUERY(@(%R1_""""")")),"(")_"("
if $PIECE(%R2,"(")]""
SET %R1=%R2
+3 SET %R2=$PIECE($EXTRACT(%R,1,($LENGTH(%R)-($EXTRACT(%R,$LENGTH(%R))=")"))),"(",2,99)
+4 SET %C=$LENGTH(%R2,",")
SET %F=1
FOR %I=1:1:%C
SET %G=$PIECE(%R2,",",%F,%I)
if %G=""
QUIT
IF ($LENGTH(%G,"(")=$LENGTH(%G,")")&($LENGTH(%G,"""")#2))!(($LENGTH(%G,"""")#2)&($EXTRACT(%G)="""")&($EXTRACT(%G,$LENGTH(%G))=""""))
SET %G=$$S(%G)
SET $PIECE(%R2,",",%F,%I)=%G
SET %F=%F+$LENGTH(%G,",")
SET %I=%F-1
+5 QUIT %R1_%R2
S(%Z) ;
+1 IF $GET(%Z)']""
QUIT ""
+2 IF $EXTRACT(%Z)'=""""
IF $LENGTH(%Z,"E")=2
IF +$PIECE(%Z,"E")=$PIECE(%Z,"E")
IF +$PIECE(%Z,"E",2)=$PIECE(%Z,"E",2)
QUIT +%Z
+3 IF +%Z=%Z
QUIT %Z
+4 IF %Z=""""""
QUIT ""
+5 IF $EXTRACT(%Z)'?1A
IF "%$+@"'[$EXTRACT(%Z)
QUIT %Z
+6 IF "+$"[$EXTRACT(%Z)
XECUTE "S %Z="_%Z
QUIT $$Q(%Z)
+7 IF $DATA(@%Z)
QUIT $$Q(@%Z)
+8 QUIT %Z
Q(%Z) ;
+1 SET %Z(%Z)=""
SET %Z=$QUERY(%Z(""))
QUIT $EXTRACT(%Z,4,$LENGTH(%Z)-1)
+2 ;
INIT IF $DATA(^UTILITY("%RCR",$JOB))[0
SET ^UTILITY("%RCR",$JOB)=0
+1 SET ^($JOB)=^($JOB)+1
SET %D="%Z"
SET %E="^UTILITY(""%RCR"",$J,"_^($JOB)_",%D"
SET %Y=%E_","
+2 KILL ^($JOB,^($JOB))
+3 QUIT
OS ;
+1 SET $PIECE(^%ZOSF("OS"),"^",2)=DITZS
+2 KILL DITZS
SET ZTREQ="@"
+3 QUIT
