- 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 Jan 18, 2025@03:55:41 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