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

DITMGM2A.m

Go to the documentation of this file. 
  1. DITMGM2A ;SFISC/EDE(OHPRD),TKW-CONTINUATION OF ^DITMGM2 ;4/7/94  08:49 [ 04/02/2003   8:23 AM ]
  1.  ;;22.0;VA FileMan;**1001**;APR 1, 2003
  1.  ;;22.0;VA FileMan;;Mar 30, 1999
  1.  ;THIS ROUTINE CONTAINS AN IHS MODIFICATION BY IHS/ANMC/LJF 2/18/2000
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1. FIELD ; PROCESS ONE FIELD IN ONE FILE/SUBFILE
  1.  S DITMGMPF=^UTILITY("DITMGMRG",$J,DITMGMFL,DITMGMFD)
  1.  S DITMGMX=$P(^DD(DITMGMFL,DITMGMFD,0),U,4),DITMGMNO=$P(DITMGMX,";",1),DITMGMPC=$P(DITMGMX,";",2),DITMGMDI=$S(DITMGMFD=.01&($P(^(0),U,5,99)["DINUM"):1,1:0)
  1.  S DITMGMV=$S($P(^DD(DITMGMFL,DITMGMFD,0),U,2)["V":1,1:0)
  1.  I DITMGMV D
  1.  . N % S %=$P(^DIC(DITMGMPF,0,"GL"),U,2) I %["""" S %=$$CONVQQ^DILIBF(%)
  1.  . S DITMGMF=DITMGMF_";"_%,DITMGMT=DITMGMT_";"_% Q
  1.  S DITMGMXR="",DITMGMX=0 F DITMGML=0:0 S DITMGMX=$O(^DD(DITMGMFL,DITMGMFD,1,DITMGMX)) Q:DITMGMX'=+DITMGMX  D  Q:DITMGMXR'=""
  1.  . S DITMGMXR=$P(^(DITMGMX,0),U,2),DITMGMTY=$P(^(0),U,3),DITMGMTZ=$P(^(0),U,1)
  1.  . I DITMGMTY="",'DITMGMMU  Q
  1.  . I DITMGMTY="",DITMGMMU,DITMGMFL'=DITMGMTZ,'$D(^DD(DITMGMTZ,0,"UP")) Q
  1.  . S DITMGMXR=""
  1.  . Q
  1.  K DA I DITMGMXR="" D NOXREF Q
  1.  Q:'$D(@(DITMGMG_""""_DITMGMXR_""","""_DITMGMF_""")"))
  1.  S DITMGMN="" F DITMGML=0:0 S DITMGMN=$O(@(DITMGMG_""""_DITMGMXR_""","""_DITMGMF_""",DITMGMN)")) Q:DITMGMN=""  D ENTRY:'DITMGMMU,MULTIPLE:DITMGMMU
  1.  Q
  1.  ;
  1. MULTIPLE ; MULTIPLE WITH XREF TO FILE
  1.  N DIXR,DICNT,DIDA,DIEND,DITMGZZZ
  1.  S DITMGZZZ=DITMGMN,(DICNT,DIEND)=+$P(DITMGMGM,"DA(",2),DIDA(DICNT)=DITMGMN
  1.  S DIXR(DICNT)=DITMGMG_""""_DITMGMXR_""","""_DITMGMF_""","_DITMGMN_","
  1.  S DICNT=DICNT-1
  1. M2 I DICNT=DIEND S DITMGMN=DITMGZZZ Q
  1.  S DIDA(DICNT)=$O(@(DIXR(DICNT+1)_+$G(DIDA(DICNT))_")"))
  1.  I 'DIDA(DICNT) S DICNT=DICNT+1 G M2
  1.  I DICNT=0 D  G M2
  1.  . N DA F I=0:1:DIEND S DA(I)=DIDA(I)
  1.  . S DA=DA(0) K DA(0)
  1.  . N DIXR,DICNT,DIDA,DIEND D ENTRY
  1.  . Q
  1.  S DIXR(DICNT)=DIXR(DICNT+1)_DIDA(DICNT)_","
  1.  S DICNT=DICNT-1 G M2
  1.  ;
  1. NOXREF ; FILES WITH NO REGULAR XREF ON POINTING FIELD
  1.  I DITMGMDI,'DITMGMMU S DITMGMN=$S($D(@(DITMGMG_DITMGMF_")")):DITMGMF,1:"") D:DITMGMN ENTRY Q  ; If DINUM file xref not needed
  1.  I '$D(@(DITMGMG_"0)")) W:'$D(DITMGM2("NOTALK")) !,"No Data Global:  ",DITMGMG Q
  1.  ;----- BEGIN IHS MODIFICATION
  1.  ;THE LINE BELOW IS COMMENTED OUT AND REPLACED BY A NEW LINE.
  1.  ;NO BACKGROUND TASKS - NEED TO KNOW WHEN MERGE IS REALLY DONE
  1.  ;ORIGINAL MODIFICATION BY IHS/ANMC/LJF 2/18/2000
  1.  ;I '$D(^%ZTSK)!($P(@(DITMGMG_"0)"),U,4)<3001) D SEARCH Q  ; If <= 3000 search gbl
  1.  D SEARCH Q
  1.  ;----- END IHS MODIFICATION
  1.  W:'$D(DITMGM2("NOTALK")) !,"No REGULAR xref on ",DITMGMFL,",",DITMGMFD," Merging entries for this file will",!,"now occur via Taskman in background!"
  1.  ; SETUP CALL TO TASKMAN
  1.  K DITMGMZT S:$D(ZTSK) DITMGMZT=ZTSK
  1.  K ZTSAVE F %="DITMGMG","DITMGMGM","DITMGMNO","DITMGMPC","DITMGMF","DITMGMT","DITMGMFL","DITMGMFD","DITMGMDI","DITMGMXR","DITMGMMU","DITMGMV" S ZTSAVE(%)=""
  1.  S ZTRTN="ZTM^DITMGM2",ZTDESC="PROCESS POINTER FIELD #"_DITMGMFD_" IN FILE #"_DITMGMFL_" FROM "_DITMGMF_" TO "_DITMGMT
  1.  S ZTIO="",ZTDTH=DT D ^%ZTLOAD K ZTSK
  1.  S:$D(DITMGMZT) ZTSK=DITMGMZT
  1.  K DITMGMZT
  1.  Q
  1.  ;
  1.  D SEARCH^DITMGM2B
  1.  Q
  1.  ;
  1. ENTRY ; PROCESS ONE FILE/SUBFILE ENTRY
  1.  D ENTRY^DITMGM2B
  1.  Q
  1. QUOTES ;
  1.  N %P,%Q S %W1="",%Q="""" F %P=1:1:$L(%W,%Q)-1 S %W1=%W1_$P(%W,%Q,%P)_%Q_%Q
  1.  S %W1=%W1_$P(%W,%Q,$L(%W,%Q))
  1.  Q