DIVU ;SFISC/DCM-VERIFY FIELDS UTILITIES ;8/1/95 1:02 PM
;;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.
;
Q
DE(FI,FD,N,G,S) ;
Q:'$D(^DD($G(FI),0)) I $G(FD) Q:'$D(^(FD,0))
I $G(G)']"" S G="DE"
N Z,X,Y,%,H,D,I,J,V,K
I $G(^DIC(FI,0))]"" S I(0)=^(0,"GL"),J(0)=+FI,V=0
E D IJ(FI)
S Y=I(0),X=V,H="",Z=0
I +$G(S),V S S=$S('$P(S,U,2):V,1:$P(S,U,2)) S Z=S,X=X-S F %=0:1 S Y=Y_"D"_%_","_I(%+1)_"," I %=(S-1) Q
L S D="D" S D=D_Z S Y=Y_D,H=H_"S "_D_"=0 F ",%="S "_D_"=$O("_Y_"))" I V>1 S @G@(Z)=%,H=H_"X "_G_"("_(Z)_")"
E S H=H_%
S H=H_" Q:"_D_"'>0 "
S X=X-1,Z=Z+1
L1 I X<0 D Q
.I $G(N)]"",$G(FD)]"" D S H=H_" X "_G_"(99)",@G=H,@G@(99)=Y Q
. . N DN,%,%N,%P,%4,Q
. . S Q=";",%=^DD(FI,FD,0),%(2)=$G(^(2)),%4=$P(%,U,4),%N=$P(%4,Q),%P=$P(%4,Q,2)
. . I FD=.001,%P="" S Y="S "_N_"=D"_V Q
. . I %P=" " D CAL Q
. . I $G(%P)]"" S Y=Y_","_%N_")"
. . I %P S DN="$P(",%P="),U,"_%P_")"
. . I $E(%P)="E" S DN="$E(",%P="),"_$E(%P,2,9)_")"
. . I $G(DN)="" Q
. . S Y="S "_N_"="_DN_"$G("_Y_%P
. . I %(2)]"",$P(%,U,2)["O",$P(%,U,2)'["D" S Y=Y_",Y="_N_" "_%(2)_" S "_N_"=Y"
. . Q
. S @G=H Q
S Y=Y_","_I(V-X)_"," G L
;
CAL S Y=$P(%,U,5,99)_" S "_N_"=X" Q
Q
IJ(FI) ;set I( and J( and V=level
Q:'$D(^DD($G(FI),0))
N X,Y,S,Q,F S X=0,(S,Y)=FI,Q="""" F Q:'$D(^DD(Y,0,"UP")) S X=X+1,Y=^("UP")
S V=X I X'=0 F X=X:-1 S Y=$G(^DD(S,0,"UP")) Q:'Y S F=$O(^DD(Y,"SB",S,0)) Q:'F S I(X)=$P($P($G(^DD(Y,F,0)),U,4),";"),K(X)=$O(^DD(S,0,"NM","")),J(X)=S,S=Y S:I(X)'=+I(X) I(X)=Q_I(X)_Q
S I(0)=$G(^DIC(S,0,"GL")),J(0)=S
Q
DA(Z) ;convert D0,D1... to DA()
N A,B,C,D K Z
F A=0:1 S D="D"_A Q:'$D(@D)
S C=0,A=A-1 F B=A:-1:0 S Z(B)=@("D"_C),C=C+1
S Z=Z(0) K Z(0)
Q
DIBT(X,%,S) ;lookup sort template, return template's IEN
N DIC,Y
S X=$E(X,2,$L(X)-1),DIC="^DIBT(",DIC("S")="I $P(^(0),U,4)="_S,DIC(0)="ZM" D ^DIC
S %=+Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIVU 2125 printed Dec 13, 2024@02:54:51 Page 2
DIVU ;SFISC/DCM-VERIFY FIELDS UTILITIES ;8/1/95 1:02 PM
+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 ;
+7 QUIT
DE(FI,FD,N,G,S) ;
+1 if '$DATA(^DD($GET(FI),0))
QUIT
IF $GET(FD)
if '$DATA(^(FD,0))
QUIT
+2 IF $GET(G)']""
SET G="DE"
+3 NEW Z,X,Y,%,H,D,I,J,V,K
+4 IF $GET(^DIC(FI,0))]""
SET I(0)=^(0,"GL")
SET J(0)=+FI
SET V=0
+5 IF '$TEST
DO IJ(FI)
+6 SET Y=I(0)
SET X=V
SET H=""
SET Z=0
+7 IF +$GET(S)
IF V
SET S=$SELECT('$PIECE(S,U,2):V,1:$PIECE(S,U,2))
SET Z=S
SET X=X-S
FOR %=0:1
SET Y=Y_"D"_%_","_I(%+1)_","
IF %=(S-1)
QUIT
L SET D="D"
SET D=D_Z
SET Y=Y_D
SET H=H_"S "_D_"=0 F "
SET %="S "_D_"=$O("_Y_"))"
IF V>1
SET @G@(Z)=%
SET H=H_"X "_G_"("_(Z)_")"
+1 IF '$TEST
SET H=H_%
+2 SET H=H_" Q:"_D_"'>0 "
+3 SET X=X-1
SET Z=Z+1
L1 IF X<0
Begin DoDot:1
+1 IF $GET(N)]""
IF $GET(FD)]""
Begin DoDot:2
+2 NEW DN,%,%N,%P,%4,Q
+3 SET Q=";"
SET %=^DD(FI,FD,0)
SET %(2)=$GET(^(2))
SET %4=$PIECE(%,U,4)
SET %N=$PIECE(%4,Q)
SET %P=$PIECE(%4,Q,2)
+4 IF FD=.001
IF %P=""
SET Y="S "_N_"=D"_V
QUIT
+5 IF %P=" "
DO CAL
QUIT
+6 IF $GET(%P)]""
SET Y=Y_","_%N_")"
+7 IF %P
SET DN="$P("
SET %P="),U,"_%P_")"
+8 IF $EXTRACT(%P)="E"
SET DN="$E("
SET %P="),"_$EXTRACT(%P,2,9)_")"
+9 IF $GET(DN)=""
QUIT
+10 SET Y="S "_N_"="_DN_"$G("_Y_%P
+11 IF %(2)]""
IF $PIECE(%,U,2)["O"
IF $PIECE(%,U,2)'["D"
SET Y=Y_",Y="_N_" "_%(2)_" S "_N_"=Y"
+12 QUIT
End DoDot:2
SET H=H_" X "_G_"(99)"
SET @G=H
SET @G@(99)=Y
QUIT
+13 SET @G=H
QUIT
End DoDot:1
QUIT
+14 SET Y=Y_","_I(V-X)_","
GOTO L
+15 ;
CAL SET Y=$PIECE(%,U,5,99)_" S "_N_"=X"
QUIT
+1 QUIT
IJ(FI) ;set I( and J( and V=level
+1 if '$DATA(^DD($GET(FI),0))
QUIT
+2 NEW X,Y,S,Q,F
SET X=0
SET (S,Y)=FI
SET Q=""""
FOR
if '$DATA(^DD(Y,0,"UP"))
QUIT
SET X=X+1
SET Y=^("UP")
+3 SET V=X
IF X'=0
FOR X=X:-1
SET Y=$GET(^DD(S,0,"UP"))
if 'Y
QUIT
SET F=$ORDER(^DD(Y,"SB",S,0))
if 'F
QUIT
SET I(X)=$PIECE($PIECE($GET(^DD(Y,F,0)),U,4),";")
SET K(X)=$ORDER(^DD(S,0,"NM",""))
SET J(X)=S
SET S=Y
if I(X)'=+I(X)
SET I(X)=Q_I(X)_Q
+4 SET I(0)=$GET(^DIC(S,0,"GL"))
SET J(0)=S
+5 QUIT
DA(Z) ;convert D0,D1... to DA()
+1 NEW A,B,C,D
KILL Z
+2 FOR A=0:1
SET D="D"_A
if '$DATA(@D)
QUIT
+3 SET C=0
SET A=A-1
FOR B=A:-1:0
SET Z(B)=@("D"_C)
SET C=C+1
+4 SET Z=Z(0)
KILL Z(0)
+5 QUIT
DIBT(X,%,S) ;lookup sort template, return template's IEN
+1 NEW DIC,Y
+2 SET X=$EXTRACT(X,2,$LENGTH(X)-1)
SET DIC="^DIBT("
SET DIC("S")="I $P(^(0),U,4)="_S
SET DIC(0)="ZM"
DO ^DIC
+3 SET %=+Y
+4 QUIT
