DIUTL ;GFT/GFT - TIMSON'S UTILITIES;24JAN2013
;;22.2;VA FileMan;**10,19,21**;Jan 05, 2016;Build 4
;;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.
;
;
NAKED(DIUTLREF) ;The argument is evaluated and returned, while keeping the naked reference as it was!
N DIUTLNKD ;THIS WILL BE THE NAME OF THE NAKED
X "I $ZREFERENCE=""""" I S DIUTLNKD="^TMP(""DI DUMMY"",0)"
E S DIUTLNKD=$NA(^(0))
X "S DIUTLREF="_DIUTLREF
D Q DIUTLREF
.I $D(@DIUTLNKD)
;
;
DATE(Y) ;**CCO/NI RETURN A DATE
;I Y X ^DD("DD")
Q $$FMTE^DILIBF(Y,"1U")
;
;
NOWINT() ;INTERNAL VERSION OF NOW
N %,%I,%H,%M,%D,%Y,X
D NOW^%DTC Q %
;
;
NOW() ;EXTERNAL NOW
N X S X=$$NOWINT Q $$DATE(X-(X#.0001))
;
;
WP(DIRF,DIWL,DIWR,DIWPUT) ;Write out WP field (if any) stored at DIRF, or put it in DIWPUT array
N DIWF,Z,A1,D,X,DIW,DIWT,DN,I,DIWI,DIWTC,DIWX
K ^UTILITY($J,"W")
S DIWF=$E("W",'$D(DIWPUT))_"|" 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
I $G(DIWPUT)]"" D Q 1
.K @DIWPUT M @DIWPUT=^UTILITY($J,"W")
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 EN^DIVR(DI,DIFLD)
;D ^%ZISC
Q
;
CHKPT(DIFILE,DIDA,DIUTLMSG,DIFLG) ;check if any entries points to this entry(DIDA) in file (DIFILE)
;INPUT Required: DIFILE=file number, DIDA=ien of record, DIMSG=closed global root or local array
;INPUT Optional: DIFLG=output format 1: detailed 0: text (default)
;OUTPUT text: DIUTLMSG(0)=line count, DIUTLSMG(#)="Entry 'ien' in 'file name' ('file #') refers to it."
;OUTPUT detailed: DIUTLSMG(pointer from file #, pointer from ien, dd/subdd #, field #)=""
;ICR #6876
Q:$G(DIUTLMSG)=""!'$G(DIFILE)!'$G(DIDA)
Q:$G(^DIC(DIFILE,0))=""
K @DIUTLMSG,^TMP("DIUTL",$J) ;p21
N C,GFTIEN,GFTRCR,I,J,L,PUT,X,Y
S @DIUTLMSG@(0)=0,DIFLG=$G(DIFLG),X=$NA(^TMP("DIUTL",$J))
D DEPEND^DIDGFTPT(DIFILE,DIDA,X,"M1")
S X=$$GET1^DIQ(DIFILE,DIDA,.01) I X="" S X="NON-EXISTENT ENTRY # "_DIDA
S I=0
F S I=$O(^TMP("DIUTL",$J,DIFILE,DIDA,I)) Q:'I D Q:'$D(I)
.S Y=$P($G(^DIC(I,0)),U),J=0
.F S J=$O(^TMP("DIUTL",$J,DIFILE,DIDA,I,J)) Q:'J D
..I 'DIFLG S C=@DIUTLMSG@(0)+1,@DIUTLMSG@(0)=C,@DIUTLMSG@(C)="Entry "_J_" in "_Y_" ("_I_") refers to it." Q
..S L=""
..F S L=$O(^TMP("DIUTL",$J,DIFILE,DIDA,I,J,L)) Q:L="" S C=@DIUTLMSG@(0)+1,@DIUTLMSG@(0)=C,@DIUTLMSG@(I,J,$P(L,","),$P(L,",",2))=""
..Q
.Q
K ^TMP("DIUTL",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIUTL 3635 printed Sep 23, 2025@20:30:49 Page 2
DIUTL ;GFT/GFT - TIMSON'S UTILITIES;24JAN2013
+1 ;;22.2;VA FileMan;**10,19,21**;Jan 05, 2016;Build 4
+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 ;
NAKED(DIUTLREF) ;The argument is evaluated and returned, while keeping the naked reference as it was!
+1 ;THIS WILL BE THE NAME OF THE NAKED
NEW DIUTLNKD
+2 XECUTE "I $ZREFERENCE="""""
IF $TEST
SET DIUTLNKD="^TMP(""DI DUMMY"",0)"
+3 IF '$TEST
SET DIUTLNKD=$NAME(^(0))
+4 XECUTE "S DIUTLREF="_DIUTLREF
+5 Begin DoDot:1
+6 IF $DATA(@DIUTLNKD)
End DoDot:1
QUIT DIUTLREF
+7 ;
+8 ;
DATE(Y) ;**CCO/NI RETURN A DATE
+1 ;I Y X ^DD("DD")
+2 QUIT $$FMTE^DILIBF(Y,"1U")
+3 ;
+4 ;
NOWINT() ;INTERNAL VERSION OF NOW
+1 NEW %,%I,%H,%M,%D,%Y,X
+2 DO NOW^%DTC
QUIT %
+3 ;
+4 ;
NOW() ;EXTERNAL NOW
+1 NEW X
SET X=$$NOWINT
QUIT $$DATE(X-(X#.0001))
+2 ;
+3 ;
WP(DIRF,DIWL,DIWR,DIWPUT) ;Write out WP field (if any) stored at DIRF, or put it in DIWPUT array
+1 NEW DIWF,Z,A1,D,X,DIW,DIWT,DN,I,DIWI,DIWTC,DIWX
+2 KILL ^UTILITY($JOB,"W")
+3 SET DIWF=$EXTRACT("W",'$DATA(DIWPUT))_"|"
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 IF $GET(DIWPUT)]""
Begin DoDot:1
+6 KILL @DIWPUT
MERGE @DIWPUT=^UTILITY($JOB,"W")
End DoDot:1
QUIT 1
+7 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 EN^DIVR(DI,DIFLD)
+14 ;D ^%ZISC
+15 QUIT
+16 ;
CHKPT(DIFILE,DIDA,DIUTLMSG,DIFLG) ;check if any entries points to this entry(DIDA) in file (DIFILE)
+1 ;INPUT Required: DIFILE=file number, DIDA=ien of record, DIMSG=closed global root or local array
+2 ;INPUT Optional: DIFLG=output format 1: detailed 0: text (default)
+3 ;OUTPUT text: DIUTLMSG(0)=line count, DIUTLSMG(#)="Entry 'ien' in 'file name' ('file #') refers to it."
+4 ;OUTPUT detailed: DIUTLSMG(pointer from file #, pointer from ien, dd/subdd #, field #)=""
+5 ;ICR #6876
+6 if $GET(DIUTLMSG)=""!'$GET(DIFILE)!'$GET(DIDA)
QUIT
+7 if $GET(^DIC(DIFILE,0))=""
QUIT
+8 ;p21
KILL @DIUTLMSG,^TMP("DIUTL",$JOB)
+9 NEW C,GFTIEN,GFTRCR,I,J,L,PUT,X,Y
+10 SET @DIUTLMSG@(0)=0
SET DIFLG=$GET(DIFLG)
SET X=$NAME(^TMP("DIUTL",$JOB))
+11 DO DEPEND^DIDGFTPT(DIFILE,DIDA,X,"M1")
+12 SET X=$$GET1^DIQ(DIFILE,DIDA,.01)
IF X=""
SET X="NON-EXISTENT ENTRY # "_DIDA
+13 SET I=0
+14 FOR
SET I=$ORDER(^TMP("DIUTL",$JOB,DIFILE,DIDA,I))
if 'I
QUIT
Begin DoDot:1
+15 SET Y=$PIECE($GET(^DIC(I,0)),U)
SET J=0
+16 FOR
SET J=$ORDER(^TMP("DIUTL",$JOB,DIFILE,DIDA,I,J))
if 'J
QUIT
Begin DoDot:2
+17 IF 'DIFLG
SET C=@DIUTLMSG@(0)+1
SET @DIUTLMSG@(0)=C
SET @DIUTLMSG@(C)="Entry "_J_" in "_Y_" ("_I_") refers to it."
QUIT
+18 SET L=""
+19 FOR
SET L=$ORDER(^TMP("DIUTL",$JOB,DIFILE,DIDA,I,J,L))
if L=""
QUIT
SET C=@DIUTLMSG@(0)+1
SET @DIUTLMSG@(0)=C
SET @DIUTLMSG@(I,J,$PIECE(L,","),$PIECE(L,",",2))=""
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
if '$DATA(I)
QUIT
+22 KILL ^TMP("DIUTL",$JOB)
+23 QUIT
