DIFROMS5 ;SCISC/DCL-DIFROM SERVER PROCESS TEMPLATES OUT ;5APR2003
;;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.
;
Q
;
EDEOUT ;EXTENDED DATABASE ELEMENTS OUT
N DIFRDSV,DIFRF,DIFRGBL,DIFRSEC,DIFRTRT
I $G(DIFRIEN)>0 G EDE
N DIFRIENX,DIFRIENZ
S DIFRIENX=$O(@DIFRLST@(0)),DIFRIENZ=$D(@DIFRLST@(DIFRIENX,0))#2,DIFRIENX=0
F S DIFRIENX=$O(@DIFRLST@(DIFRIENX)) Q:DIFRIENX'>0 D
.I DIFRIENZ S DIFRIEN=+@DIFRLST@(DIFRIENX,0) S:DIFRIEN'>0 DIFRIEN=DIFRIENX D EDE Q
.S DIFRIEN=+@DIFRLST@(DIFRIENX) S:DIFRIEN'>0 DIFRIEN=DIFRIENX D EDE Q
Q
EDE ;
; DIFRTRT=FULL ROOT IN DIST ARRAY
; DIFRDSV=0TH NODE OF TEMPLATE
; :.401, .4, .402
; :TEMPL NAME^DATE CREATED^READ^FILENR^DUZ^WRITE^DATE LAST USED
; :.403
; :FORM NAME^READ^WRITE^DUZ^DATE CREATED^DATA LAST USED^^FILE^
; :.84
; :DIALOG NUMBER^TYPE^INTERNAL PARM^PACKAGE FILE (pointer)
; DIFRSEC=FILE SECURITY 1=EXPORT SECURITY,0=NO FILE SECURITY
; DIFRIEN=TEMPLATE'S INTERNAL ENTRY NUMBER
; :.5 (FUNCTIONS)
S DIFRTRT=$NA(@DIFRTA@(DIFRFILE,DIFRIEN))
S DIFRGBL=$$ROOT^DILFD(DIFRFILE,"",1)
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; For stand alone FileMan only - KIDS will do the Merge
; v v v v v v v v v v v v v v v v v v v v v v v v v v v v v v v v v
;
I $G(DIFRSTNA) S DIFRGBL=$$ROOT^DILFD(DIFRFILE,"",1) M @DIFRTRT=@DIFRGBL@(DIFRIEN)
;
; ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I DIFRFILE=.5 Q ;no processing necessary
S DIFRDSV=$G(@DIFRTRT@(0)),DIFRF=$P(DIFRDSV,U,$S(DIFRFILE=.403:8,1:4))
I DIFRDSV="" D Q
.N DIFRERR S DIFRERR(1)=DIFRFNAM,DIFRERR(2)=DIFRIEN
.D BLD^DIALOG(9516,.DIFRERR)
.Q
I DIFRFILE=.84 G DIALOG
S DIFRSEC=DIFRFLG'["S"
I DIFRFILE=.403 G T403
Q:'$D(@DIFRTRT@(0)) K ^("RD"),^("AB") K:DIFRFILE=.401 ^(1)
S $P(@DIFRTRT@(0),U,5)="" S:'DIFRSEC ^(0)=$P(DIFRDSV,U,1,2)_U_U_DIFRF_U_U_U_U_$P(DIFRDSV,U,8,9)
Q
;
T403 ;PROCESS FORMS AND EACH BLOCK IT CONTAINES
S $P(DIFRDSV,U,4)="",$P(DIFRDSV,U,6)="" S:'DIFRSEC $P(DIFRDSV,U,2,3)=U
S @DIFRTRT@(0)=DIFRDSV
D T404
K @DIFRTRT@("AY"),@DIFRTRT@(40,"B"),^("C")
N X
S X=0
F S X=$O(@DIFRTRT@(40,X)) Q:X'>0 K @DIFRTRT@(40,X,40,"AC"),^("B")
Q
;
T404 ;PROCESS BLOCKS
; :.404
; :BLOCK NAME^
N DIFR1,DIFR2,D1,D2
S D1=0
F S D1=$O(@DIFRTRT@(40,D1)) Q:'D1 I $D(^(D1,0)) S DIFR1=+$P(^(0),U,2) D
.I $D(^DIST(.404,DIFR1,0)) D
..S $P(@DIFRTRT@(40,D1,0),U,2)=$P(^DIST(.404,DIFR1,0),U) ;SEND PAGE'S HEADER BLOCK NAME, instead of NUMBER POINTER
..M @DIFRTA@(.404,DIFR1)=^DIST(.404,DIFR1)
..K @DIFRTA@(.404,DIFR1,40,"B"),^("C"),^("D")
..Q
.S D2=0
.F S D2=$O(@DIFRTRT@(40,D1,40,D2)) Q:'D2 I $D(^(D2,0)) S DIFR2=+^(0) D
..I $D(^DIST(.404,DIFR2)) D
...S $P(@DIFRTRT@(40,D1,40,D2,0),U)=$P(^DIST(.404,DIFR2,0),U) ;SEND THE BLOCK NAME, instead of NUMBER POINTER
...M @DIFRTA@(.404,DIFR2)=^DIST(.404,DIFR2)
...K @DIFRTA@(.404,DIFR2,40,"B"),^("C"),^("D")
...Q
..Q
.Q
Q
;
DIALOG ;
Q:'$D(@DIFRTRT@(0)) K ^(3,"B") K @DIFRTRT@(4,"B") ;GFT -- USED TO KILL ^(4) SO TRANSLATIONS WOULD NOT BE TRANSPORTED!
Q:$G(DIFRF)'>0
S:DIFRF DIFRF=$P($G(^DIC(9.4,DIFRF,0)),"^"),$P(@DIFRTRT@(0),"^",4)=DIFRF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFROMS5 3571 printed Apr 09, 2024@21:46:19 Page 2
DIFROMS5 ;SCISC/DCL-DIFROM SERVER PROCESS TEMPLATES OUT ;5APR2003
+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 ;
+7 QUIT
+8 ;
EDEOUT ;EXTENDED DATABASE ELEMENTS OUT
+1 NEW DIFRDSV,DIFRF,DIFRGBL,DIFRSEC,DIFRTRT
+2 IF $GET(DIFRIEN)>0
GOTO EDE
+3 NEW DIFRIENX,DIFRIENZ
+4 SET DIFRIENX=$ORDER(@DIFRLST@(0))
SET DIFRIENZ=$DATA(@DIFRLST@(DIFRIENX,0))#2
SET DIFRIENX=0
+5 FOR
SET DIFRIENX=$ORDER(@DIFRLST@(DIFRIENX))
if DIFRIENX'>0
QUIT
Begin DoDot:1
+6 IF DIFRIENZ
SET DIFRIEN=+@DIFRLST@(DIFRIENX,0)
if DIFRIEN'>0
SET DIFRIEN=DIFRIENX
DO EDE
QUIT
+7 SET DIFRIEN=+@DIFRLST@(DIFRIENX)
if DIFRIEN'>0
SET DIFRIEN=DIFRIENX
DO EDE
QUIT
End DoDot:1
+8 QUIT
EDE ;
+1 ; DIFRTRT=FULL ROOT IN DIST ARRAY
+2 ; DIFRDSV=0TH NODE OF TEMPLATE
+3 ; :.401, .4, .402
+4 ; :TEMPL NAME^DATE CREATED^READ^FILENR^DUZ^WRITE^DATE LAST USED
+5 ; :.403
+6 ; :FORM NAME^READ^WRITE^DUZ^DATE CREATED^DATA LAST USED^^FILE^
+7 ; :.84
+8 ; :DIALOG NUMBER^TYPE^INTERNAL PARM^PACKAGE FILE (pointer)
+9 ; DIFRSEC=FILE SECURITY 1=EXPORT SECURITY,0=NO FILE SECURITY
+10 ; DIFRIEN=TEMPLATE'S INTERNAL ENTRY NUMBER
+11 ; :.5 (FUNCTIONS)
+12 SET DIFRTRT=$NAME(@DIFRTA@(DIFRFILE,DIFRIEN))
+13 SET DIFRGBL=$$ROOT^DILFD(DIFRFILE,"",1)
+14 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+15 ;
+16 ; For stand alone FileMan only - KIDS will do the Merge
+17 ; v v v v v v v v v v v v v v v v v v v v v v v v v v v v v v v v v
+18 ;
+19 IF $GET(DIFRSTNA)
SET DIFRGBL=$$ROOT^DILFD(DIFRFILE,"",1)
MERGE @DIFRTRT=@DIFRGBL@(DIFRIEN)
+20 ;
+21 ; ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^
+22 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+23 ;no processing necessary
IF DIFRFILE=.5
QUIT
+24 SET DIFRDSV=$GET(@DIFRTRT@(0))
SET DIFRF=$PIECE(DIFRDSV,U,$SELECT(DIFRFILE=.403:8,1:4))
+25 IF DIFRDSV=""
Begin DoDot:1
+26 NEW DIFRERR
SET DIFRERR(1)=DIFRFNAM
SET DIFRERR(2)=DIFRIEN
+27 DO BLD^DIALOG(9516,.DIFRERR)
+28 QUIT
End DoDot:1
QUIT
+29 IF DIFRFILE=.84
GOTO DIALOG
+30 SET DIFRSEC=DIFRFLG'["S"
+31 IF DIFRFILE=.403
GOTO T403
+32 if '$DATA(@DIFRTRT@(0))
QUIT
KILL ^("RD"),^("AB")
if DIFRFILE=.401
KILL ^(1)
+33 SET $PIECE(@DIFRTRT@(0),U,5)=""
if 'DIFRSEC
SET ^(0)=$PIECE(DIFRDSV,U,1,2)_U_U_DIFRF_U_U_U_U_$PIECE(DIFRDSV,U,8,9)
+34 QUIT
+35 ;
T403 ;PROCESS FORMS AND EACH BLOCK IT CONTAINES
+1 SET $PIECE(DIFRDSV,U,4)=""
SET $PIECE(DIFRDSV,U,6)=""
if 'DIFRSEC
SET $PIECE(DIFRDSV,U,2,3)=U
+2 SET @DIFRTRT@(0)=DIFRDSV
+3 DO T404
+4 KILL @DIFRTRT@("AY"),@DIFRTRT@(40,"B"),^("C")
+5 NEW X
+6 SET X=0
+7 FOR
SET X=$ORDER(@DIFRTRT@(40,X))
if X'>0
QUIT
KILL @DIFRTRT@(40,X,40,"AC"),^("B")
+8 QUIT
+9 ;
T404 ;PROCESS BLOCKS
+1 ; :.404
+2 ; :BLOCK NAME^
+3 NEW DIFR1,DIFR2,D1,D2
+4 SET D1=0
+5 FOR
SET D1=$ORDER(@DIFRTRT@(40,D1))
if 'D1
QUIT
IF $DATA(^(D1,0))
SET DIFR1=+$PIECE(^(0),U,2)
Begin DoDot:1
+6 IF $DATA(^DIST(.404,DIFR1,0))
Begin DoDot:2
+7 ;SEND PAGE'S HEADER BLOCK NAME, instead of NUMBER POINTER
SET $PIECE(@DIFRTRT@(40,D1,0),U,2)=$PIECE(^DIST(.404,DIFR1,0),U)
+8 MERGE @DIFRTA@(.404,DIFR1)=^DIST(.404,DIFR1)
+9 KILL @DIFRTA@(.404,DIFR1,40,"B"),^("C"),^("D")
+10 QUIT
End DoDot:2
+11 SET D2=0
+12 FOR
SET D2=$ORDER(@DIFRTRT@(40,D1,40,D2))
if 'D2
QUIT
IF $DATA(^(D2,0))
SET DIFR2=+^(0)
Begin DoDot:2
+13 IF $DATA(^DIST(.404,DIFR2))
Begin DoDot:3
+14 ;SEND THE BLOCK NAME, instead of NUMBER POINTER
SET $PIECE(@DIFRTRT@(40,D1,40,D2,0),U)=$PIECE(^DIST(.404,DIFR2,0),U)
+15 MERGE @DIFRTA@(.404,DIFR2)=^DIST(.404,DIFR2)
+16 KILL @DIFRTA@(.404,DIFR2,40,"B"),^("C"),^("D")
+17 QUIT
End DoDot:3
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT
+21 ;
DIALOG ;
+1 ;GFT -- USED TO KILL ^(4) SO TRANSLATIONS WOULD NOT BE TRANSPORTED!
if '$DATA(@DIFRTRT@(0))
QUIT
KILL ^(3,"B")
KILL @DIFRTRT@(4,"B")
+2 if $GET(DIFRF)'>0
QUIT
+3 if DIFRF
SET DIFRF=$PIECE($GET(^DIC(9.4,DIFRF,0)),"^")
SET $PIECE(@DIFRTRT@(0),"^",4)=DIFRF
+4 QUIT
