- DIVU ;SFISC/DCM-VERIFY FIELDS UTILITIES ;8/1/95 1:02 PM
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
- DIVU ;SFISC/DCM-VERIFY FIELDS UTILITIES ;8/1/95 1:02 PM
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 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
