- 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
