Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DIUTL

DIUTL.m

Go to the documentation of this file.
  1. DIUTL ;GFT/GFT - TIMSON'S UTILITIES;24JAN2013
  1. ;;22.2;VA FileMan;**10,19,21**;Jan 05, 2016;Build 4
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
  1. ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
  1. ;;Licensed under the terms of the Apache License, Version 2.0.
  1. ;
  1. ;
  1. NAKED(DIUTLREF) ;The argument is evaluated and returned, while keeping the naked reference as it was!
  1. N DIUTLNKD ;THIS WILL BE THE NAME OF THE NAKED
  1. X "I $ZREFERENCE=""""" I S DIUTLNKD="^TMP(""DI DUMMY"",0)"
  1. E S DIUTLNKD=$NA(^(0))
  1. X "S DIUTLREF="_DIUTLREF
  1. D Q DIUTLREF
  1. .I $D(@DIUTLNKD)
  1. ;
  1. ;
  1. DATE(Y) ;**CCO/NI RETURN A DATE
  1. ;I Y X ^DD("DD")
  1. Q $$FMTE^DILIBF(Y,"1U")
  1. ;
  1. ;
  1. NOWINT() ;INTERNAL VERSION OF NOW
  1. N %,%I,%H,%M,%D,%Y,X
  1. D NOW^%DTC Q %
  1. ;
  1. ;
  1. NOW() ;EXTERNAL NOW
  1. N X S X=$$NOWINT Q $$DATE(X-(X#.0001))
  1. ;
  1. ;
  1. WP(DIRF,DIWL,DIWR,DIWPUT) ;Write out WP field (if any) stored at DIRF, or put it in DIWPUT array
  1. N DIWF,Z,A1,D,X,DIW,DIWT,DN,I,DIWI,DIWTC,DIWX
  1. K ^UTILITY($J,"W")
  1. S DIWF=$E("W",'$D(DIWPUT))_"|" S:'$G(IOM) IOM=80 S:'$G(DIWR) DIWR=IOM S:'$G(DIWL) DIWL=1
  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
  1. I $G(DIWPUT)]"" D Q 1
  1. .K @DIWPUT M @DIWPUT=^UTILITY($J,"W")
  1. D ^DIWW
  1. QWP I $G(DN)'=0 Q 1
  1. K DIOEND Q 0
  1. ;
  1. IJ(N) ;build I & J arrays given subfile number N
  1. N A K I,J
  1. S J(0)=N,N=0
  1. 0 I $D(^DIC(J(0),0,"GL")) S I(0)=^("GL") Q
  1. S A=$G(^DD(J(0),0,"UP")) Q:A=""
  1. S I=$O(^DD(A,"SB",J(0),0)) Q:'I
  1. S I=$P($P($G(^DD(A,I,0)),U,4),";") Q:I=""
  1. I +I'=I S I=""""_I_""""
  1. F J=N:-1:0 S J(J+1)=J(J) S:J I(J+1)=I(J)
  1. S J(0)=A,I(1)=I,N=N+1 G 0
  1. ;
  1. ;
  1. DIVR(DI,DIFLD) ;verify
  1. N DIVZ,S,A,DA,DICL,V,Z,DDC,DR,N,Y,I,J,Q,W,V,T,DQI
  1. K ^UTILITY("DIVR",$J),^DD(U,$J)
  1. D IJ(DI)
  1. I '$O(@(I(0)_"0)")) Q ;File must have some entries!
  1. S S=";",Q="""",V=$O(J(""),-1),A=DI,DA=DIFLD
  1. 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)
  1. Q:DR["W"!(DR["C")
  1. F T="N","S","V","P","K","F" Q:DR[T
  1. W !!,"SINCE YOU HAVE CHANGED THE FIELD DEFINITION,",!,"EXISTING '",$P(^(0),U),"' DATA WILL NOW BE CHECKED FOR INCONSISTENCIES",!,"OK"
  1. S %=1 D YN^DICN Q:%-1
  1. ;D ^%ZIS Q:POP
  1. ;U IO WON'T WORK BECAUSE Q+3^DIVR ASKS TO STORE IN TEMPLATE
  1. D EN^DIVR(DI,DIFLD)
  1. ;D ^%ZISC
  1. Q
  1. ;
  1. 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
  1. ;INPUT Optional: DIFLG=output format 1: detailed 0: text (default)
  1. ;OUTPUT text: DIUTLMSG(0)=line count, DIUTLSMG(#)="Entry 'ien' in 'file name' ('file #') refers to it."
  1. ;OUTPUT detailed: DIUTLSMG(pointer from file #, pointer from ien, dd/subdd #, field #)=""
  1. ;ICR #6876
  1. Q:$G(DIUTLMSG)=""!'$G(DIFILE)!'$G(DIDA)
  1. Q:$G(^DIC(DIFILE,0))=""
  1. K @DIUTLMSG,^TMP("DIUTL",$J) ;p21
  1. N C,GFTIEN,GFTRCR,I,J,L,PUT,X,Y
  1. S @DIUTLMSG@(0)=0,DIFLG=$G(DIFLG),X=$NA(^TMP("DIUTL",$J))
  1. D DEPEND^DIDGFTPT(DIFILE,DIDA,X,"M1")
  1. S X=$$GET1^DIQ(DIFILE,DIDA,.01) I X="" S X="NON-EXISTENT ENTRY # "_DIDA
  1. S I=0
  1. F S I=$O(^TMP("DIUTL",$J,DIFILE,DIDA,I)) Q:'I D Q:'$D(I)
  1. .S Y=$P($G(^DIC(I,0)),U),J=0
  1. .F S J=$O(^TMP("DIUTL",$J,DIFILE,DIDA,I,J)) Q:'J D
  1. ..I 'DIFLG S C=@DIUTLMSG@(0)+1,@DIUTLMSG@(0)=C,@DIUTLMSG@(C)="Entry "_J_" in "_Y_" ("_I_") refers to it." Q
  1. ..S L=""
  1. ..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))=""
  1. ..Q
  1. .Q
  1. K ^TMP("DIUTL",$J)
  1. Q