DIUTL.m

DIUTL ;GFT;01:02 PM  8 Apr 2001 [ 12/09/2003  4:35 PM ]

 ;;22.0;VA FileMan;**76,1002**;Mar 30, 1999

 ;

WP(DIRF,DIWL,DIWR) ;Write out WP field (if any) stored at DIRF

 N DIWF,Z,A1,D,X,DIW,DIWT,DN,I

 K ^UTILITY($J,"W")

 S DIWF="W|" S:'$G(IOM) IOM=80 S:'$G(DIWR) DIWR=IOM S:'$G(DIWL) DIWL=1

 S A1=$P($G(@DIRF@(0)),U,3) F D=0:0 S D=$O(@DIRF@(D)) Q:D>A1&A1!'D  S X=^(D,0) D ^DIWP G QWP:$G(DN)=0

 D ^DIWW

QWP I $G(DN)'=0 Q 1

 K DIOEND Q 0

 ;

IJ(N) ;build I & J arrays given subfile number N

 N A K I,J

 S J(0)=N,N=0

0 I $D(^DIC(J(0),0,"GL")) S I(0)=^("GL") Q

 S A=$G(^DD(J(0),0,"UP")) Q:A=""

 S I=$O(^DD(A,"SB",J(0),0)) Q:'I

 S I=$P($P($G(^DD(A,I,0)),U,4),";") Q:I=""

 I +I'=I S I=""""_I_""""

 F J=N:-1:0 S J(J+1)=J(J) S:J I(J+1)=I(J)

 S J(0)=A,I(1)=I,N=N+1 G 0

 ;

 ;

DIVR(DI,DIFLD) ;verify

 N DIVZ,S,A,DA,DICL,V,Z,DDC,DR,N,Y,I,J,Q,W,V,T,DQI

 K ^UTILITY("DIVR",$J),^DD(U,$J)

 D IJ(DI)

 I '$O(@(I(0)_"0)")) Q  ;File must have some entries!

 S S=";",Q="""",V=$O(J(""),-1),A=DI,DA=DIFLD

 S DR=$P(^DD(DI,DIFLD,0),U,2),Z=$P(^(0),U,3),$P(Y(0),U,4)=$P(^(0),U,4),DDC=$P(^(0),U,5,999)

 Q:DR["W"!(DR["C")

 F T="N","S","V","P","K","F" Q:DR[T

 W !!,"SINCE YOU HAVE CHANGED THE FIELD DEFINITION,",!,"EXISTING '",$P(^(0),U),"' DATA WILL NOW BE CHECKED FOR INCONSISTENCIES",!,"OK"

 S %=1 D YN^DICN Q:%-1

 ;D ^%ZIS Q:POP

 ;U IO   WON'T WORK BECAUSE Q+3^DIVR ASKS TO STORE IN TEMPLATE

 D ^DIVR

 ;D ^%ZISC

 Q

DIUTL     ;GFT;01:02 PM  8 Apr 2001 [ 12/09/2003  4:35 PM ]

 +1       ;;22.0;VA FileMan;**76,1002**;Mar 30, 1999

 +2       ;

WP(DIRF,DIWL,DIWR) ;Write out WP field (if any) stored at DIRF

 +1        NEW DIWF,Z,A1,D,X,DIW,DIWT,DN,I

 +2        KILL ^UTILITY($JOB,"W")

 +3        SET DIWF="W|"

           IF '$GET(IOM)

               SET IOM=80

           IF '$GET(DIWR)

               SET DIWR=IOM

           IF '$GET(DIWL)

               SET DIWL=1

 +4        SET A1=$PIECE($GET(@DIRF@(0)),U,3)

           FOR D=0:0

               SET D=$ORDER(@DIRF@(D))

               IF D>A1&A1!'D

                   QUIT 

               SET X=^(D,0)

               DO ^DIWP

               IF $GET(DN)=0

                   GOTO QWP

 +5        DO ^DIWW

QWP        IF $GET(DN)'=0

               QUIT 1

 +1        KILL DIOEND

           QUIT 0

 +2       ;

IJ(N)     ;build I & J arrays given subfile number N

 +1        NEW A

           KILL I,J

 +2        SET J(0)=N

           SET N=0

0          IF $DATA(^DIC(J(0),0,"GL"))

               SET I(0)=^("GL")

               QUIT 

 +1        SET A=$GET(^DD(J(0),0,"UP"))

           IF A=""

               QUIT 

 +2        SET I=$ORDER(^DD(A,"SB",J(0),0))

           IF 'I

               QUIT 

 +3        SET I=$PIECE($PIECE($GET(^DD(A,I,0)),U,4),";")

           IF I=""

               QUIT 

 +4        IF +I'=I

               SET I=""""_I_""""

 +5        FOR J=N:-1:0

               SET J(J+1)=J(J)

               IF J

                   SET I(J+1)=I(J)

 +6        SET J(0)=A

           SET I(1)=I

           SET N=N+1

           GOTO 0

 +7       ;

 +8       ;

DIVR(DI,DIFLD) ;verify

 +1        NEW DIVZ,S,A,DA,DICL,V,Z,DDC,DR,N,Y,I,J,Q,W,V,T,DQI

 +2        KILL ^UTILITY("DIVR",$JOB),^DD(U,$JOB)

 +3        DO IJ(DI)

 +4       ;File must have some entries!

           IF '$ORDER(@(I(0)_"0)"))

               QUIT 

 +5        SET S=";"

           SET Q=""""

           SET V=$ORDER(J(""),-1)

           SET A=DI

           SET DA=DIFLD

 +6        SET DR=$PIECE(^DD(DI,DIFLD,0),U,2)

           SET Z=$PIECE(^(0),U,3)

           SET $PIECE(Y(0),U,4)=$PIECE(^(0),U,4)

           SET DDC=$PIECE(^(0),U,5,999)

 +7        IF DR["W"!(DR["C")

               QUIT 

 +8        FOR T="N","S","V","P","K","F"

               IF DR[T

                   QUIT 

 +9        WRITE !!,"SINCE YOU HAVE CHANGED THE FIELD DEFINITION,",!,"EXISTING '",$PIECE(^(0),U),"' DATA WILL NOW BE CHECKED FOR INCONSISTENCIES",!,"OK"

 +10       SET %=1

           DO YN^DICN

           IF %-1

               QUIT 

 +11      ;D ^%ZIS Q:POP

 +12      ;U IO   WON'T WORK BECAUSE Q+3^DIVR ASKS TO STORE IN TEMPLATE

 +13       DO ^DIVR

 +14      ;D ^%ZISC

 +15       QUIT