DITMGM2A ;SFISC/EDE(OHPRD),TKW-CONTINUATION OF ^DITMGM2 ;8MAR2006
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;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.
;
FIELD ; PROCESS ONE FIELD IN ONE FILE/SUBFILE
S DITMGMPF=^UTILITY("DITMGMRG",$J,DITMGMFL,DITMGMFD)
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)
S DITMGMV=$S($P(^DD(DITMGMFL,DITMGMFD,0),U,2)["V":1,1:0)
I DITMGMV D
. N % S %=$P(^DIC(DITMGMPF,0,"GL"),U,2) I %["""" S %=$$CONVQQ^DILIBF(%)
. S DITMGMF=DITMGMF_";"_%,DITMGMT=DITMGMT_";"_% Q
S DITMGMXR="",DITMGMX=0 F DITMGML=0:0 S DITMGMX=$O(^DD(DITMGMFL,DITMGMFD,1,DITMGMX)) Q:DITMGMX'=+DITMGMX D Q:DITMGMXR'=""
. S DITMGMXR=$P(^(DITMGMX,0),U,2),DITMGMTY=$P(^(0),U,3),DITMGMTZ=$P(^(0),U,1)
. I DITMGMTY="",'DITMGMMU Q
. I DITMGMTY="",DITMGMMU,DITMGMFL'=DITMGMTZ,'$D(^DD(DITMGMTZ,0,"UP")) Q
. S DITMGMXR=""
. Q
K DA I DITMGMXR="" D NOXREF Q
Q:'$D(@(DITMGMG_""""_DITMGMXR_""","""_DITMGMF_""")"))
S DITMGMN="" F DITMGML=0:0 S DITMGMN=$O(@(DITMGMG_""""_DITMGMXR_""","""_DITMGMF_""",DITMGMN)")) Q:DITMGMN="" D ENTRY:'DITMGMMU,MULTIPLE:DITMGMMU
Q
;
MULTIPLE ; MULTIPLE WITH XREF TO FILE
N DIXR,DICNT,DIDA,DIEND,DITMGZZZ
S DITMGZZZ=DITMGMN,(DICNT,DIEND)=+$P(DITMGMGM,"DA(",2),DIDA(DICNT)=DITMGMN
S DIXR(DICNT)=DITMGMG_""""_DITMGMXR_""","""_DITMGMF_""","_DITMGMN_","
S DICNT=DICNT-1
M2 I DICNT=DIEND S DITMGMN=DITMGZZZ Q
S DIDA(DICNT)=$O(@(DIXR(DICNT+1)_+$G(DIDA(DICNT))_")"))
I 'DIDA(DICNT) S DICNT=DICNT+1 G M2
I DICNT=0 D G M2
. N DA F I=0:1:DIEND S DA(I)=DIDA(I)
. S DA=DA(0) K DA(0)
. N DIXR,DICNT,DIDA,DIEND D ENTRY
. Q
S DIXR(DICNT)=DIXR(DICNT+1)_DIDA(DICNT)_","
S DICNT=DICNT-1 G M2
;
NOXREF ; FILES WITH NO REGULAR XREF ON POINTING FIELD
I DITMGMDI,'DITMGMMU S DITMGMN=$S($D(@(DITMGMG_DITMGMF_")")):DITMGMF,1:"") D:DITMGMN ENTRY Q ; If DINUM file xref not needed
I '$D(@(DITMGMG_"0)")) W:'$D(DITMGM2("NOTALK")) !,"No Data Global: ",DITMGMG Q
IHS D SEARCH Q ;WON'T FALL THRU
W:'$D(DITMGM2("NOTALK")) !,"No REGULAR xref on ",DITMGMFL,",",DITMGMFD," Merging entries for this file will",!,"now occur via Taskman in background!"
; SETUP CALL TO TASKMAN
K DITMGMZT S:$D(ZTSK) DITMGMZT=ZTSK
K ZTSAVE F %="DITMGMG","DITMGMGM","DITMGMNO","DITMGMPC","DITMGMF","DITMGMT","DITMGMFL","DITMGMFD","DITMGMDI","DITMGMXR","DITMGMMU","DITMGMV" S ZTSAVE(%)=""
S ZTRTN="ZTM^DITMGM2",ZTDESC="PROCESS POINTER FIELD #"_DITMGMFD_" IN FILE #"_DITMGMFL_" FROM "_DITMGMF_" TO "_DITMGMT
S ZTIO="",ZTDTH=DT D ^%ZTLOAD K ZTSK
S:$D(DITMGMZT) ZTSK=DITMGMZT
K DITMGMZT
Q
;
SEARCH ; $O THRU DATA GBL
D SEARCH^DITMGM2B
Q
;
ENTRY ; PROCESS ONE FILE/SUBFILE ENTRY
D ENTRY^DITMGM2B
Q
QUOTES ;
N %P,%Q S %W1="",%Q="""" F %P=1:1:$L(%W,%Q)-1 S %W1=%W1_$P(%W,%Q,%P)_%Q_%Q
S %W1=%W1_$P(%W,%Q,$L(%W,%Q))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDITMGM2A 3112 printed Apr 09, 2024@21:51:12 Page 2
DITMGM2A ;SFISC/EDE(OHPRD),TKW-CONTINUATION OF ^DITMGM2 ;8MAR2006
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+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 ;
FIELD ; PROCESS ONE FIELD IN ONE FILE/SUBFILE
+1 SET DITMGMPF=^UTILITY("DITMGMRG",$JOB,DITMGMFL,DITMGMFD)
+2 SET DITMGMX=$PIECE(^DD(DITMGMFL,DITMGMFD,0),U,4)
SET DITMGMNO=$PIECE(DITMGMX,";",1)
SET DITMGMPC=$PIECE(DITMGMX,";",2)
SET DITMGMDI=$SELECT(DITMGMFD=.01&($PIECE(^(0),U,5,99)["DINUM"):1,1:0)
+3 SET DITMGMV=$SELECT($PIECE(^DD(DITMGMFL,DITMGMFD,0),U,2)["V":1,1:0)
+4 IF DITMGMV
Begin DoDot:1
+5 NEW %
SET %=$PIECE(^DIC(DITMGMPF,0,"GL"),U,2)
IF %[""""
SET %=$$CONVQQ^DILIBF(%)
+6 SET DITMGMF=DITMGMF_";"_%
SET DITMGMT=DITMGMT_";"_%
QUIT
End DoDot:1
+7 SET DITMGMXR=""
SET DITMGMX=0
FOR DITMGML=0:0
SET DITMGMX=$ORDER(^DD(DITMGMFL,DITMGMFD,1,DITMGMX))
if DITMGMX'=+DITMGMX
QUIT
Begin DoDot:1
+8 SET DITMGMXR=$PIECE(^(DITMGMX,0),U,2)
SET DITMGMTY=$PIECE(^(0),U,3)
SET DITMGMTZ=$PIECE(^(0),U,1)
+9 IF DITMGMTY=""
IF 'DITMGMMU
QUIT
+10 IF DITMGMTY=""
IF DITMGMMU
IF DITMGMFL'=DITMGMTZ
IF '$DATA(^DD(DITMGMTZ,0,"UP"))
QUIT
+11 SET DITMGMXR=""
+12 QUIT
End DoDot:1
if DITMGMXR'=""
QUIT
+13 KILL DA
IF DITMGMXR=""
DO NOXREF
QUIT
+14 if '$DATA(@(DITMGMG_""""_DITMGMXR_""","""_DITMGMF_""")"))
QUIT
+15 SET DITMGMN=""
FOR DITMGML=0:0
SET DITMGMN=$ORDER(@(DITMGMG_""""_DITMGMXR_""","""_DITMGMF_""",DITMGMN)"))
if DITMGMN=""
QUIT
if 'DITMGMMU
DO ENTRY
if DITMGMMU
DO MULTIPLE
+16 QUIT
+17 ;
MULTIPLE ; MULTIPLE WITH XREF TO FILE
+1 NEW DIXR,DICNT,DIDA,DIEND,DITMGZZZ
+2 SET DITMGZZZ=DITMGMN
SET (DICNT,DIEND)=+$PIECE(DITMGMGM,"DA(",2)
SET DIDA(DICNT)=DITMGMN
+3 SET DIXR(DICNT)=DITMGMG_""""_DITMGMXR_""","""_DITMGMF_""","_DITMGMN_","
+4 SET DICNT=DICNT-1
M2 IF DICNT=DIEND
SET DITMGMN=DITMGZZZ
QUIT
+1 SET DIDA(DICNT)=$ORDER(@(DIXR(DICNT+1)_+$GET(DIDA(DICNT))_")"))
+2 IF 'DIDA(DICNT)
SET DICNT=DICNT+1
GOTO M2
+3 IF DICNT=0
Begin DoDot:1
+4 NEW DA
FOR I=0:1:DIEND
SET DA(I)=DIDA(I)
+5 SET DA=DA(0)
KILL DA(0)
+6 NEW DIXR,DICNT,DIDA,DIEND
DO ENTRY
+7 QUIT
End DoDot:1
GOTO M2
+8 SET DIXR(DICNT)=DIXR(DICNT+1)_DIDA(DICNT)_","
+9 SET DICNT=DICNT-1
GOTO M2
+10 ;
NOXREF ; FILES WITH NO REGULAR XREF ON POINTING FIELD
+1 ; If DINUM file xref not needed
IF DITMGMDI
IF 'DITMGMMU
SET DITMGMN=$SELECT($DATA(@(DITMGMG_DITMGMF_")")):DITMGMF,1:"")
if DITMGMN
DO ENTRY
QUIT
+2 IF '$DATA(@(DITMGMG_"0)"))
if '$DATA(DITMGM2("NOTALK"))
WRITE !,"No Data Global: ",DITMGMG
QUIT
IHS ;WON'T FALL THRU
DO SEARCH
QUIT
+1 if '$DATA(DITMGM2("NOTALK"))
WRITE !,"No REGULAR xref on ",DITMGMFL,",",DITMGMFD," Merging entries for this file will",!,"now occur via Taskman in background!"
+2 ; SETUP CALL TO TASKMAN
+3 KILL DITMGMZT
if $DATA(ZTSK)
SET DITMGMZT=ZTSK
+4 KILL ZTSAVE
FOR %="DITMGMG","DITMGMGM","DITMGMNO","DITMGMPC","DITMGMF","DITMGMT","DITMGMFL","DITMGMFD","DITMGMDI","DITMGMXR","DITMGMMU","DITMGMV"
SET ZTSAVE(%)=""
+5 SET ZTRTN="ZTM^DITMGM2"
SET ZTDESC="PROCESS POINTER FIELD #"_DITMGMFD_" IN FILE #"_DITMGMFL_" FROM "_DITMGMF_" TO "_DITMGMT
+6 SET ZTIO=""
SET ZTDTH=DT
DO ^%ZTLOAD
KILL ZTSK
+7 if $DATA(DITMGMZT)
SET ZTSK=DITMGMZT
+8 KILL DITMGMZT
+9 QUIT
+10 ;
SEARCH ; $O THRU DATA GBL
+1 DO SEARCH^DITMGM2B
+2 QUIT
+3 ;
ENTRY ; PROCESS ONE FILE/SUBFILE ENTRY
+1 DO ENTRY^DITMGM2B
+2 QUIT
QUOTES ;
+1 NEW %P,%Q
SET %W1=""
SET %Q=""""
FOR %P=1:1:$LENGTH(%W,%Q)-1
SET %W1=%W1_$PIECE(%W,%Q,%P)_%Q_%Q
+2 SET %W1=%W1_$PIECE(%W,%Q,$LENGTH(%W,%Q))
+3 QUIT
