RGUTDIC ;CAIRO/DKM - Encapsulated FileMan API;04-Sep-1998 11:26;DKM
;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
;=================================================================
; Parameterized routine to add/edit/extract an entry in a
; FileMan file. Encapsulates global structure info so no
; need to specify this directly.
; Inputs:
; %RGDIC = Global root, file number, or bookmark
; %RGCMD = n : IEN of entry to process
; 0 : Process last IEN referenced
; +n : Move down to subfile n
; - : Move up to parent file
; @n : Delete IEN #n (or last referenced if missing)
; =x;y : Lookup y at current level using options in x
; ?x;y ; Lookup y using RGUTLKP utility with options in x
; >x;y : Read fields specified in y using options in x
; <x;y : Write fields specified in y using options in x
; ~x;y : Same as <, but creates new entry
; %n : Force DINUM to n
; Outputs:
; Returns in the first piece the IEN of the entry or...
; 0 = Entry was deleted
; -1 = Entry was rejected
; -2 = Entry locked by another process
; -3 = Unexpected error
;=================================================================
ENTRY(%RGDIC,%RGCMD) ;
S %RGDIC(0)=+$G(DUZ)
N DUZ,DIC,DINUM,DIE,DIQ,DIQUIET,DIK,%RGX,%RGIEN,%RGARG,%RGN1,%RGN2,%RGZ,X,Y
N DA,DC,DD,DG,DH,DK,DL,DO,DQ,DR,DU,DV,DW,DY
S DUZ=%RGDIC(0),DUZ(0)="@",@$$TRAP^RGZOSF("ERROR^RGUTDIC"),%RGCMD=$G(%RGCMD),%RGIEN="",DIQUIET=1
; Build the bookmark if a global reference or file # passed
I %RGDIC'[U D
.S:%RGDIC'=+%RGDIC %RGDIC=+$O(^DIC("B",%RGDIC,0))
.S %RGDIC=$$ROOT^DILFD(%RGDIC)_U_U_%RGDIC
I $P(%RGDIC,U,4)="" D
.S %RGZ=U_$P(%RGDIC,U,2),%RGZ=$E(%RGZ,1,$L(%RGZ)-1),%RGZ=%RGZ_$S(%RGZ["(":")",1:"")
.S $P(%RGDIC,U,4)=$P(@%RGZ@(0),U,2)
F %RGN1=1:1:$L(%RGCMD,"|") S %RGARG=$P(%RGCMD,"|",%RGN1),%RGZ=$E(%RGARG) D Q:%RGIEN<0
.S %RGN2=$F("-+=@><~?%",%RGZ)
.S:%RGN2 %RGN2=%RGN2-1,%RGARG=$E(%RGARG,2,999)
.D DA,@%RGN2
.S:%RGIEN>0 $P(%RGDIC,U,3)=%RGIEN
S $P(%RGDIC,U)=%RGIEN
Q %RGDIC
; Set IEN
0 S:%RGARG'<0 %RGIEN=$S($D(@%RGDIC(2)@(+%RGARG)):+%RGARG,1:0),$P(%RGDIC,U,3)=%RGIEN
Q
; Move up to parent file
1 N %RGX,%RGY
S $P(%RGDIC,U,4)=$P($P(%RGDIC,U,4),"|",2,999)
S %RGY=$P(%RGDIC,U,2),%RGX=$L(%RGY,"|"),$P(%RGDIC,U,2)=$P(%RGY,"|",1,%RGX-1)
S %RGIEN=+$P(%RGY,"|",%RGX),$P(%RGDIC,U,3)=%RGIEN
D DA
Q
; Move down to subfile
2 N %RGX,%RGY,%RGZ
I $P(%RGDIC,U,3)'>0 S %RGIEN=-1 Q
S %RGY=+$P(%RGDIC,U,4)
S:%RGARG'=+%RGARG %RGARG=+$O(^DD(%RGY,"B",%RGARG,0)),%RGARG=+$P($G(^DD(%RGY,%RGARG,0)),U,2)
S %RGX=+%RGARG,%RGZ=+$O(^DD(%RGY,"SB",%RGX,0)),%RGZ=$P($P(^DD(%RGY,%RGZ,0),U,4),";"),%RGX=$P(^(0),U,2)
S:%RGZ'=+%RGZ %RGZ=""""_%RGZ_""""
S $P(%RGDIC,U,4)=%RGX_"|"_$P(%RGDIC,U,4),$P(%RGDIC,U,2)=$P(%RGDIC,U,2)_"|"_$P(%RGDIC,U,3)_","_%RGZ_","
S %RGIEN="",$P(%RGDIC,U,3)=""
D DA
Q
; Lookup an entry
3 N X,Y
I %RGARG[";" S DIC(0)=$P(%RGARG,";"),%RGARG=$P(%RGARG,";",2,999)
E S DIC(0)="XMF"
S DIC=%RGDIC(1),X=%RGARG
D ^DIC
S %RGIEN=+Y
Q
; Delete an entry
4 N X,Y
S:%RGARG DA=%RGARG
S DIK=%RGDIC(1),%RGIEN=0
D ^DIK
Q
; Extract data
5 N %RGZ,%RGZ1,%RGX,%RGY
I '%RGIEN S %RGIEN=-1 Q
S DR=""
F %RGX=2:1:$L(%RGARG,";") D
.S %RGY=$P(%RGARG,";",%RGX)
.I %RGY["=" S %RGZ=$$FLD($P(%RGY,"=",2)),%RGZ1(%RGZ,$P(%RGY,"="))="",%RGY=%RGZ
.S DR=DR_$S($L(DR):";",1:"")_%RGY
S DIC=%RGDIC(1),DIQ(0)=$P(%RGARG,";")
S:DIQ(0)="" DIQ(0)="E"
K ^UTILITY("DIQ1",$J)
D
.N X,Y
.D EN^DIQ1
F %RGX=0:0 S %RGX=$O(%RGZ1(%RGX)),%RGZ="" Q:'%RGX D
.F S %RGZ=$O(%RGZ1(%RGX,%RGZ)),%RGZ1="" Q:%RGZ="" D
..F %RGY="E","I" D
...S:$D(^UTILITY("DIQ1",$J,+$P(%RGDIC,U,4),%RGIEN,%RGX,%RGY)) %RGZ1=%RGZ1_$S($L(%RGZ1):U,1:"")_^(%RGY)
..S @%RGZ=%RGZ1
Q
; Edit existing entry
6 S DIC(0)=$P(%RGARG,";"),DIC("P")=$P($P(%RGDIC,U,4),"|"),%RGARG=$P(%RGARG,";",2,999)
I %RGIEN'>0 S %RGIEN=-1 Q
S DIE=%RGDIC(1),DR=%RGARG
L +@%RGDIC(2)@(%RGIEN):$S(DIC(0)["!":9999999,1:0)
E S %RGIEN=-2 Q
D ^DIE
L -@%RGDIC(2)@(%RGIEN)
S %RGIEN=+$G(DA)
Q
; Create new entry
7 N X,Y,DD,DO,DLAYGO
S DIC=%RGDIC(1),DIC(0)=$P(%RGARG,";")_"L",DIC("P")=$P($P(%RGDIC,U,4),"|"),Y=$P(%RGARG,";",2),%RGARG=DIC(0)_";"_$P(%RGARG,";",3,999),DLAYGO=DIC("P")\1
I +Y'=.01 S %RGIEN=-1 Q
S X=$P(Y,"/",4)
S:X="" X=$P(Y,"/",5)
X:$E(X)=U $E(X,2,999)
I $P(^DD(+DIC("P"),.01,0),U,2)["W" D
.D WP
E D ^DIC:DIC(0)'["U",FILE^DICN:DIC(0)["U"
S %RGIEN=+Y
I %RGIEN>0,$P(%RGARG,";",2,99)'="" D DA,6
K DINUM
Q
8 ; Lookup entry
N %RGOPT,%RGP,RGFN
S %RGOPT=$P(%RGARG,";"),%RGARG=$P(%RGARG,";",2,999),RGFN=+$P(%RGDIC,U,4)
S %RGP=+$P(%RGDIC,U,4),%RGP=$P($G(^DD(%RGP,.01,0)),U)
S:$L(%RGP) %RGP=%RGP_": "
S %RGIEN=$$ENTRY^RGUTLKP(%RGDIC(2),%RGOPT,%RGP,"",%RGARG,"","",$X,$Y,"","","HLP^RGUTDIC")
Q
; Force DINUM
9 S DINUM=%RGARG
Q
HLP W $G(^DD(+RGFN,.01,3)),!
Q
; Word processing field (special case of #7)
WP N %RGZ,%RGZ1
I X="@" D
.K @%RGDIC(2)
.S Y=0
E D
.S %RGZ=$G(@%RGDIC(2)@(0)),Y=$G(DINUM,1+$O(^($C(1)),-1))
.S %RGZ1=+$P(%RGZ,U,4),%RGZ=+$P(%RGZ,U,3)
.S:Y>%RGZ %RGZ=Y
.S:'$D(^(Y)) %RGZ1=%RGZ1+1
.S ^(0)=U_U_%RGZ_U_%RGZ1_U_$G(DT),^(Y,0)=X
Q:$P(^DD(+DIC("P"),.01,0),U,2)'["a"
S %RGIEN=Y
D DA,WPAUDIT^RGCODAUD(+DIC("P"),.DA,X,"")
Q
; Trap unexpected error
ERROR S $P(%RGDIC,U)=-3
Q %RGDIC
; Return field #
FLD(X) Q $S(X=+X:X,1:+$O(^DD(+$P(%RGDIC,U,4),"B",X,0)))
; Set up DA array
DA N %RGZ,%RGZ1,%RGZ2
K DA
S:'$G(%RGIEN) %RGIEN=$P(%RGDIC,U,3)
S %RGZ=$P(%RGDIC,U,2),%RGZ2=$L(%RGZ,"|"),DA=%RGIEN
F %RGZ1=2:1:%RGZ2 S DA(%RGZ2-%RGZ1+1)=+$P(%RGZ,"|",%RGZ1)
S %RGDIC(1)=U_$TR($P(%RGDIC,U,2),"|"),%RGDIC(2)=$E(%RGDIC(1),1,$L(%RGDIC(1))-1),%RGDIC(2)=%RGDIC(2)_$S(%RGDIC(2)["(":")",1:"")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGUTDIC 5860 printed Apr 09, 2024@21:39:46 Page 2
RGUTDIC ;CAIRO/DKM - Encapsulated FileMan API;04-Sep-1998 11:26;DKM
+1 ;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
+2 ;=================================================================
+3 ; Parameterized routine to add/edit/extract an entry in a
+4 ; FileMan file. Encapsulates global structure info so no
+5 ; need to specify this directly.
+6 ; Inputs:
+7 ; %RGDIC = Global root, file number, or bookmark
+8 ; %RGCMD = n : IEN of entry to process
+9 ; 0 : Process last IEN referenced
+10 ; +n : Move down to subfile n
+11 ; - : Move up to parent file
+12 ; @n : Delete IEN #n (or last referenced if missing)
+13 ; =x;y : Lookup y at current level using options in x
+14 ; ?x;y ; Lookup y using RGUTLKP utility with options in x
+15 ; >x;y : Read fields specified in y using options in x
+16 ; <x;y : Write fields specified in y using options in x
+17 ; ~x;y : Same as <, but creates new entry
+18 ; %n : Force DINUM to n
+19 ; Outputs:
+20 ; Returns in the first piece the IEN of the entry or...
+21 ; 0 = Entry was deleted
+22 ; -1 = Entry was rejected
+23 ; -2 = Entry locked by another process
+24 ; -3 = Unexpected error
+25 ;=================================================================
ENTRY(%RGDIC,%RGCMD) ;
+1 SET %RGDIC(0)=+$GET(DUZ)
+2 NEW DUZ,DIC,DINUM,DIE,DIQ,DIQUIET,DIK,%RGX,%RGIEN,%RGARG,%RGN1,%RGN2,%RGZ,X,Y
+3 NEW DA,DC,DD,DG,DH,DK,DL,DO,DQ,DR,DU,DV,DW,DY
+4 SET DUZ=%RGDIC(0)
SET DUZ(0)="@"
SET @$$TRAP^RGZOSF("ERROR^RGUTDIC")
SET %RGCMD=$GET(%RGCMD)
SET %RGIEN=""
SET DIQUIET=1
+5 ; Build the bookmark if a global reference or file # passed
+6 IF %RGDIC'[U
Begin DoDot:1
+7 if %RGDIC'=+%RGDIC
SET %RGDIC=+$ORDER(^DIC("B",%RGDIC,0))
+8 SET %RGDIC=$$ROOT^DILFD(%RGDIC)_U_U_%RGDIC
End DoDot:1
+9 IF $PIECE(%RGDIC,U,4)=""
Begin DoDot:1
+10 SET %RGZ=U_$PIECE(%RGDIC,U,2)
SET %RGZ=$EXTRACT(%RGZ,1,$LENGTH(%RGZ)-1)
SET %RGZ=%RGZ_$SELECT(%RGZ["(":")",1:"")
+11 SET $PIECE(%RGDIC,U,4)=$PIECE(@%RGZ@(0),U,2)
End DoDot:1
+12 FOR %RGN1=1:1:$LENGTH(%RGCMD,"|")
SET %RGARG=$PIECE(%RGCMD,"|",%RGN1)
SET %RGZ=$EXTRACT(%RGARG)
Begin DoDot:1
+13 SET %RGN2=$FIND("-+=@><~?%",%RGZ)
+14 if %RGN2
SET %RGN2=%RGN2-1
SET %RGARG=$EXTRACT(%RGARG,2,999)
+15 DO DA
DO @%RGN2
+16 if %RGIEN>0
SET $PIECE(%RGDIC,U,3)=%RGIEN
End DoDot:1
if %RGIEN<0
QUIT
+17 SET $PIECE(%RGDIC,U)=%RGIEN
+18 QUIT %RGDIC
+19 ; Set IEN
0 if %RGARG'<0
SET %RGIEN=$SELECT($DATA(@%RGDIC(2)@(+%RGARG)):+%RGARG,1:0)
SET $PIECE(%RGDIC,U,3)=%RGIEN
+1 QUIT
+2 ; Move up to parent file
1 NEW %RGX,%RGY
+1 SET $PIECE(%RGDIC,U,4)=$PIECE($PIECE(%RGDIC,U,4),"|",2,999)
+2 SET %RGY=$PIECE(%RGDIC,U,2)
SET %RGX=$LENGTH(%RGY,"|")
SET $PIECE(%RGDIC,U,2)=$PIECE(%RGY,"|",1,%RGX-1)
+3 SET %RGIEN=+$PIECE(%RGY,"|",%RGX)
SET $PIECE(%RGDIC,U,3)=%RGIEN
+4 DO DA
+5 QUIT
+6 ; Move down to subfile
2 NEW %RGX,%RGY,%RGZ
+1 IF $PIECE(%RGDIC,U,3)'>0
SET %RGIEN=-1
QUIT
+2 SET %RGY=+$PIECE(%RGDIC,U,4)
+3 if %RGARG'=+%RGARG
SET %RGARG=+$ORDER(^DD(%RGY,"B",%RGARG,0))
SET %RGARG=+$PIECE($GET(^DD(%RGY,%RGARG,0)),U,2)
+4 SET %RGX=+%RGARG
SET %RGZ=+$ORDER(^DD(%RGY,"SB",%RGX,0))
SET %RGZ=$PIECE($PIECE(^DD(%RGY,%RGZ,0),U,4),";")
SET %RGX=$PIECE(^(0),U,2)
+5 if %RGZ'=+%RGZ
SET %RGZ=""""_%RGZ_""""
+6 SET $PIECE(%RGDIC,U,4)=%RGX_"|"_$PIECE(%RGDIC,U,4)
SET $PIECE(%RGDIC,U,2)=$PIECE(%RGDIC,U,2)_"|"_$PIECE(%RGDIC,U,3)_","_%RGZ_","
+7 SET %RGIEN=""
SET $PIECE(%RGDIC,U,3)=""
+8 DO DA
+9 QUIT
+10 ; Lookup an entry
3 NEW X,Y
+1 IF %RGARG[";"
SET DIC(0)=$PIECE(%RGARG,";")
SET %RGARG=$PIECE(%RGARG,";",2,999)
+2 IF '$TEST
SET DIC(0)="XMF"
+3 SET DIC=%RGDIC(1)
SET X=%RGARG
+4 DO ^DIC
+5 SET %RGIEN=+Y
+6 QUIT
+7 ; Delete an entry
4 NEW X,Y
+1 if %RGARG
SET DA=%RGARG
+2 SET DIK=%RGDIC(1)
SET %RGIEN=0
+3 DO ^DIK
+4 QUIT
+5 ; Extract data
5 NEW %RGZ,%RGZ1,%RGX,%RGY
+1 IF '%RGIEN
SET %RGIEN=-1
QUIT
+2 SET DR=""
+3 FOR %RGX=2:1:$LENGTH(%RGARG,";")
Begin DoDot:1
+4 SET %RGY=$PIECE(%RGARG,";",%RGX)
+5 IF %RGY["="
SET %RGZ=$$FLD($PIECE(%RGY,"=",2))
SET %RGZ1(%RGZ,$PIECE(%RGY,"="))=""
SET %RGY=%RGZ
+6 SET DR=DR_$SELECT($LENGTH(DR):";",1:"")_%RGY
End DoDot:1
+7 SET DIC=%RGDIC(1)
SET DIQ(0)=$PIECE(%RGARG,";")
+8 if DIQ(0)=""
SET DIQ(0)="E"
+9 KILL ^UTILITY("DIQ1",$JOB)
+10 Begin DoDot:1
+11 NEW X,Y
+12 DO EN^DIQ1
End DoDot:1
+13 FOR %RGX=0:0
SET %RGX=$ORDER(%RGZ1(%RGX))
SET %RGZ=""
if '%RGX
QUIT
Begin DoDot:1
+14 FOR
SET %RGZ=$ORDER(%RGZ1(%RGX,%RGZ))
SET %RGZ1=""
if %RGZ=""
QUIT
Begin DoDot:2
+15 FOR %RGY="E","I"
Begin DoDot:3
+16 if $DATA(^UTILITY("DIQ1",$JOB,+$PIECE(%RGDIC,U,4),%RGIEN,%RGX,%RGY))
SET %RGZ1=%RGZ1_$SELECT($LENGTH(%RGZ1):U,1:"")_^(%RGY)
End DoDot:3
+17 SET @%RGZ=%RGZ1
End DoDot:2
End DoDot:1
+18 QUIT
+19 ; Edit existing entry
6 SET DIC(0)=$PIECE(%RGARG,";")
SET DIC("P")=$PIECE($PIECE(%RGDIC,U,4),"|")
SET %RGARG=$PIECE(%RGARG,";",2,999)
+1 IF %RGIEN'>0
SET %RGIEN=-1
QUIT
+2 SET DIE=%RGDIC(1)
SET DR=%RGARG
+3 LOCK +@%RGDIC(2)@(%RGIEN):$SELECT(DIC(0)["!":9999999,1:0)
+4 IF '$TEST
SET %RGIEN=-2
QUIT
+5 DO ^DIE
+6 LOCK -@%RGDIC(2)@(%RGIEN)
+7 SET %RGIEN=+$GET(DA)
+8 QUIT
+9 ; Create new entry
7 NEW X,Y,DD,DO,DLAYGO
+1 SET DIC=%RGDIC(1)
SET DIC(0)=$PIECE(%RGARG,";")_"L"
SET DIC("P")=$PIECE($PIECE(%RGDIC,U,4),"|")
SET Y=$PIECE(%RGARG,";",2)
SET %RGARG=DIC(0)_";"_$PIECE(%RGARG,";",3,999)
SET DLAYGO=DIC("P")\1
+2 IF +Y'=.01
SET %RGIEN=-1
QUIT
+3 SET X=$PIECE(Y,"/",4)
+4 if X=""
SET X=$PIECE(Y,"/",5)
+5 if $EXTRACT(X)=U
XECUTE $EXTRACT(X,2,999)
+6 IF $PIECE(^DD(+DIC("P"),.01,0),U,2)["W"
Begin DoDot:1
+7 DO WP
End DoDot:1
+8 IF '$TEST
if DIC(0)'["U"
DO ^DIC
if DIC(0)["U"
DO FILE^DICN
+9 SET %RGIEN=+Y
+10 IF %RGIEN>0
IF $PIECE(%RGARG,";",2,99)'=""
DO DA
DO 6
+11 KILL DINUM
+12 QUIT
8 ; Lookup entry
+1 NEW %RGOPT,%RGP,RGFN
+2 SET %RGOPT=$PIECE(%RGARG,";")
SET %RGARG=$PIECE(%RGARG,";",2,999)
SET RGFN=+$PIECE(%RGDIC,U,4)
+3 SET %RGP=+$PIECE(%RGDIC,U,4)
SET %RGP=$PIECE($GET(^DD(%RGP,.01,0)),U)
+4 if $LENGTH(%RGP)
SET %RGP=%RGP_": "
+5 SET %RGIEN=$$ENTRY^RGUTLKP(%RGDIC(2),%RGOPT,%RGP,"",%RGARG,"","",$X,$Y,"","","HLP^RGUTDIC")
+6 QUIT
+7 ; Force DINUM
9 SET DINUM=%RGARG
+1 QUIT
HLP WRITE $GET(^DD(+RGFN,.01,3)),!
+1 QUIT
+2 ; Word processing field (special case of #7)
WP NEW %RGZ,%RGZ1
+1 IF X="@"
Begin DoDot:1
+2 KILL @%RGDIC(2)
+3 SET Y=0
End DoDot:1
+4 IF '$TEST
Begin DoDot:1
+5 SET %RGZ=$GET(@%RGDIC(2)@(0))
SET Y=$GET(DINUM,1+$ORDER(^($CHAR(1)),-1))
+6 SET %RGZ1=+$PIECE(%RGZ,U,4)
SET %RGZ=+$PIECE(%RGZ,U,3)
+7 if Y>%RGZ
SET %RGZ=Y
+8 if '$DATA(^(Y))
SET %RGZ1=%RGZ1+1
+9 SET ^(0)=U_U_%RGZ_U_%RGZ1_U_$GET(DT)
SET ^(Y,0)=X
End DoDot:1
+10 if $PIECE(^DD(+DIC("P"),.01,0),U,2)'["a"
QUIT
+11 SET %RGIEN=Y
+12 DO DA
DO WPAUDIT^RGCODAUD(+DIC("P"),.DA,X,"")
+13 QUIT
+14 ; Trap unexpected error
ERROR SET $PIECE(%RGDIC,U)=-3
+1 QUIT %RGDIC
+2 ; Return field #
FLD(X) QUIT $SELECT(X=+X:X,1:+$ORDER(^DD(+$PIECE(%RGDIC,U,4),"B",X,0)))
+1 ; Set up DA array
DA NEW %RGZ,%RGZ1,%RGZ2
+1 KILL DA
+2 if '$GET(%RGIEN)
SET %RGIEN=$PIECE(%RGDIC,U,3)
+3 SET %RGZ=$PIECE(%RGDIC,U,2)
SET %RGZ2=$LENGTH(%RGZ,"|")
SET DA=%RGIEN
+4 FOR %RGZ1=2:1:%RGZ2
SET DA(%RGZ2-%RGZ1+1)=+$PIECE(%RGZ,"|",%RGZ1)
+5 SET %RGDIC(1)=U_$TRANSLATE($PIECE(%RGDIC,U,2),"|")
SET %RGDIC(2)=$EXTRACT(%RGDIC(1),1,$LENGTH(%RGDIC(1))-1)
SET %RGDIC(2)=%RGDIC(2)_$SELECT(%RGDIC(2)["(":")",1:"")
+6 QUIT
