DIFROM0 ;SFISC/XAK-GATHER PCS TO SEND ;31OCT2012
;;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.
;
S %=2,DIT=0,DIH=""
I DPK<0,$O(F(0))>0 K DIR S DIR(0)="Y",DIR("A")="Do you want to include all the templates and forms",DIR("B")="NO",DIR("??")="^D NOPKG^DIFROMH" D ^DIR G Q:$D(DIRUT) S DIT=Y=1
W ! S DIR(0)="YA",DIR("??")="^D ^DIFROMH",DIR("B")="YES"
;NOTE: I removed 9.8 (ROUTINE FILE) from this list for V19 but none of the supporting code. (tkw)
F DL=19,3.6,19.1,.5,9.2,8994 I $D(^DIC(DL,0)) S X=$P(^(0),U),DIR("A")="Would you like to include "_X_"S?"_$J("",17-$L(X)) D ^DIR G Q:$D(DIRUT) I Y=1 S DL(DL)=DL,DIFC=1
G:$D(F(-1))&('$D(DIFC)) Q
S W ! S DIR("A")="Would you like security codes sent along: ",DIR("B")="NO"
S DIR("??")="^D S^DIFROMH" D ^DIR G Q:$D(DIRUT) S DSEC=Y=1 K ^UTILITY("DI",$J)
M ;
S DIR("A")="Maximum Routine Size (2000 - "_^DD("ROU")_") : ",DIR("B")=^DD("ROU"),DIR(0)="NA^2000:"_^DD("ROU") ; VEN/SMH V22.2
S DIR("??")="^D M^DIFROMH" D ^DIR G Q:$D(DIRUT) S DIFRM=Y
GO W ! D WAIT^DICD
D:DPK>0 PKG^DIFROM12
D I DTL="DI" S DTL="DD" D S DTL="DM" D S DTL="DI"
.F Y=19,3.6,19.1,.5,9.8,9.2,8994 I $D(DL(Y)) S X=$S(Y=19:"OPT",Y=3.6:"BUL",Y=19.1:"SE",Y=.5:"FUN",Y=9.8:"ROU",Y=9.2:"HEL",Y=8994:"REM") D ADD,A:'Y
D SBF
K DL,DIR S DL=DRN,DRN=1 G ^DIFROM1
ADD ;
S DH=$S(DTL="XU":"DD",1:DTL)
Q:$D(^DIC(Y,0))[0!$D(DTL(Y)) Q:$P(^(0),X,1)]""!'$D(^(0,"GL"))
S Y=^("GL"),X=$S(X="ROU":"RTN",X="SE":"KEY",1:X)
Q
A F D=0:0 S D=$O(^DIC(9.4,DPK,"EX",D)) Q:D'>0 I $P(DH,$P(^(D,0),U))="" G DH
S D=$O(@(Y_"""B"",DH,0)")),%X=Y_"D,",%Y="^UTILITY(U,$J,X,D,"
G DH:D'>0,DH:D<100&(X="FUN") S Q(X)=0
D %XY^%RCR G H:X'="OPT"
S %=^UTILITY(U,$J,X,D,0),%1=+$P(%,U,12),%1=$S($D(^DIC(9.4,%1,0)):$P(^(0),U),1:""),$P(%,U,12)=%1,$P(%,U,5)=""
S %1=+$P(%,U,7),%1=$S($D(^DIC(9.2,%1,0)):$P(^(0),U),1:""),$P(%,U,7)=%1,^UTILITY(U,$J,X,D,0)=% K ^(3.96),^(10,"B"),^("C")
I $D(^UTILITY(U,$J,X,D,220)) S %=^(220),%1=$S($D(^XMB(3.6,+%,0)):$P(^(0),U),1:""),$P(%,U)=%1,%1=$S($D(^XMB(3.8,+$P(%,U,3),0)):$P(^(0),U),1:""),$P(%,U,3)=%1,^UTILITY(U,$J,X,D,220)=%
F %=0:0 S %=$O(^DIC(19,D,10,%)) Q:%'>0 I $D(^(%,0)),$D(^DIC(19,+^(0),0)) S ^UTILITY(U,$J,X,D,10,%,U)=$P(^(0),U)
H K:"BULKEY"[X ^UTILITY(U,$J,X,D,2) G:X'="HEL" DH
K ^UTILITY(U,$J,X,D,4) S $P(^(0),U,4)="" K ^(2,"B"),^UTILITY(U,$J,X,D,10,"B")
F %2=0:0 S %2=$O(^UTILITY(U,$J,X,D,10,%2)) Q:'%2 I $D(^(%2,0))#2 S %1=+^(0),%1=$S($D(^MAG(%1,0)):$P(^(0),U,1),1:"") K:%1="" ^UTILITY(U,$J,X,D,10,%2) I %1]"" S $P(^UTILITY(U,$J,X,D,10,%2,0),U,1)=%1
F %2=0:0 S %2=$O(^UTILITY(U,$J,X,D,2,%2)) G DH:%2'>0 I $D(^(%2,0))#2,$P(^(0),U,2) S %1=^(0),%=1 D HP1 Q:%<0
K %1,%2 Q
HP1 I $D(^DIC(9.2,+$P(%1,U,2),0)) S ^UTILITY(U,$J,X,D,2,%2,0)=$P(%1,U)_U_$P(^(0),U) Q
W !,$C(7),"The Help Frame, "_$P(^DIC(9.2,D,0),U)_" has the keyword "_$P(%1,U)
W !,"whose Related Frame does not exist. Shall I exclude it" D YN^DICN
K:%=1 ^UTILITY(U,$J,X,D,2,%2) Q
;
DH S DH=$O(@(Y_"""B"",DH)")) G A:DH]""&(DTL="XU"!($P(DH,DTL,1)="")) Q
;
ERM W $C(7),!!?5,"Was not able to get a message number for the network INIT",!?10,"DIFROM ABORTED!!",! Q
;
Q G Q^DIFROM11
SBF N I,II
S I=0 F S I=$O(F(I)) Q:I'>0 S II=0 F S II=$O(F(I,II)) Q:II'>0 S ^UTILITY("^",$J,"SBF",I,II)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFROM0 3507 printed Sep 23, 2025@20:24:05 Page 2
DIFROM0 ;SFISC/XAK-GATHER PCS TO SEND ;31OCT2012
+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 SET %=2
SET DIT=0
SET DIH=""
+8 IF DPK<0
IF $ORDER(F(0))>0
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you want to include all the templates and forms"
SET DIR("B")="NO"
SET DIR("??")="^D NOPKG^DIFROMH"
DO ^DIR
if $DATA(DIRUT)
GOTO Q
SET DIT=Y=1
+9 WRITE !
SET DIR(0)="YA"
SET DIR("??")="^D ^DIFROMH"
SET DIR("B")="YES"
+10 ;NOTE: I removed 9.8 (ROUTINE FILE) from this list for V19 but none of the supporting code. (tkw)
+11 FOR DL=19,3.6,19.1,.5,9.2,8994
IF $DATA(^DIC(DL,0))
SET X=$PIECE(^(0),U)
SET DIR("A")="Would you like to include "_X_"S?"_$JUSTIFY("",17-$LENGTH(X))
DO ^DIR
if $DATA(DIRUT)
GOTO Q
IF Y=1
SET DL(DL)=DL
SET DIFC=1
+12 if $DATA(F(-1))&('$DATA(DIFC))
GOTO Q
S WRITE !
SET DIR("A")="Would you like security codes sent along: "
SET DIR("B")="NO"
+1 SET DIR("??")="^D S^DIFROMH"
DO ^DIR
if $DATA(DIRUT)
GOTO Q
SET DSEC=Y=1
KILL ^UTILITY("DI",$JOB)
M ;
+1 ; VEN/SMH V22.2
SET DIR("A")="Maximum Routine Size (2000 - "_^DD("ROU")_") : "
SET DIR("B")=^DD("ROU")
SET DIR(0)="NA^2000:"_^DD("ROU")
+2 SET DIR("??")="^D M^DIFROMH"
DO ^DIR
if $DATA(DIRUT)
GOTO Q
SET DIFRM=Y
GO WRITE !
DO WAIT^DICD
+1 if DPK>0
DO PKG^DIFROM12
+2 Begin DoDot:1
+3 FOR Y=19,3.6,19.1,.5,9.8,9.2,8994
IF $DATA(DL(Y))
SET X=$SELECT(Y=19:"OPT",Y=3.6:"BUL",Y=19.1:"SE",Y=.5:"FUN",Y=9.8:"ROU",Y=9.2:"HEL",Y=8994:"REM")
DO ADD
if 'Y
DO A
End DoDot:1
IF DTL="DI"
SET DTL="DD"
Begin DoDot:1
End DoDot:1
SET DTL="DM"
Begin DoDot:1
End DoDot:1
SET DTL="DI"
+4 DO SBF
+5 KILL DL,DIR
SET DL=DRN
SET DRN=1
GOTO ^DIFROM1
ADD ;
+1 SET DH=$SELECT(DTL="XU":"DD",1:DTL)
+2 if $DATA(^DIC(Y,0))[0!$DATA(DTL(Y))
QUIT
if $PIECE(^(0),X,1)]""!'$DATA(^(0,"GL"))
QUIT
+3 SET Y=^("GL")
SET X=$SELECT(X="ROU":"RTN",X="SE":"KEY",1:X)
+4 QUIT
A FOR D=0:0
SET D=$ORDER(^DIC(9.4,DPK,"EX",D))
if D'>0
QUIT
IF $PIECE(DH,$PIECE(^(D,0),U))=""
GOTO DH
+1 SET D=$ORDER(@(Y_"""B"",DH,0)"))
SET %X=Y_"D,"
SET %Y="^UTILITY(U,$J,X,D,"
+2 if D'>0
GOTO DH
if D<100&(X="FUN")
GOTO DH
SET Q(X)=0
+3 DO %XY^%RCR
if X'="OPT"
GOTO H
+4 SET %=^UTILITY(U,$JOB,X,D,0)
SET %1=+$PIECE(%,U,12)
SET %1=$SELECT($DATA(^DIC(9.4,%1,0)):$PIECE(^(0),U),1:"")
SET $PIECE(%,U,12)=%1
SET $PIECE(%,U,5)=""
+5 SET %1=+$PIECE(%,U,7)
SET %1=$SELECT($DATA(^DIC(9.2,%1,0)):$PIECE(^(0),U),1:"")
SET $PIECE(%,U,7)=%1
SET ^UTILITY(U,$JOB,X,D,0)=%
KILL ^(3.96),^(10,"B"),^("C")
+6 IF $DATA(^UTILITY(U,$JOB,X,D,220))
SET %=^(220)
SET %1=$SELECT($DATA(^XMB(3.6,+%,0)):$PIECE(^(0),U),1:"")
SET $PIECE(%,U)=%1
SET %1=$SELECT($DATA(^XMB(3.8,+$PIECE(%,U,3),0)):$PIECE(^(0),U),1:"")
SET $PIECE(%,U,3)=%1
SET ^UTILITY(U,$JOB,X,D,220)=%
+7 FOR %=0:0
SET %=$ORDER(^DIC(19,D,10,%))
if %'>0
QUIT
IF $DATA(^(%,0))
IF $DATA(^DIC(19,+^(0),0))
SET ^UTILITY(U,$JOB,X,D,10,%,U)=$PIECE(^(0),U)
H if "BULKEY"[X
KILL ^UTILITY(U,$JOB,X,D,2)
if X'="HEL"
GOTO DH
+1 KILL ^UTILITY(U,$JOB,X,D,4)
SET $PIECE(^(0),U,4)=""
KILL ^(2,"B"),^UTILITY(U,$JOB,X,D,10,"B")
+2 FOR %2=0:0
SET %2=$ORDER(^UTILITY(U,$JOB,X,D,10,%2))
if '%2
QUIT
IF $DATA(^(%2,0))#2
SET %1=+^(0)
SET %1=$SELECT($DATA(^MAG(%1,0)):$PIECE(^(0),U,1),1:"")
if %1=""
KILL ^UTILITY(U,$JOB,X,D,10,%2)
IF %1]""
SET $PIECE(^UTILITY(U,$JOB,X,D,10,%2,0),U,1)=%1
+3 FOR %2=0:0
SET %2=$ORDER(^UTILITY(U,$JOB,X,D,2,%2))
if %2'>0
GOTO DH
IF $DATA(^(%2,0))#2
IF $PIECE(^(0),U,2)
SET %1=^(0)
SET %=1
DO HP1
if %<0
QUIT
+4 KILL %1,%2
QUIT
HP1 IF $DATA(^DIC(9.2,+$PIECE(%1,U,2),0))
SET ^UTILITY(U,$JOB,X,D,2,%2,0)=$PIECE(%1,U)_U_$PIECE(^(0),U)
QUIT
+1 WRITE !,$CHAR(7),"The Help Frame, "_$PIECE(^DIC(9.2,D,0),U)_" has the keyword "_$PIECE(%1,U)
+2 WRITE !,"whose Related Frame does not exist. Shall I exclude it"
DO YN^DICN
+3 if %=1
KILL ^UTILITY(U,$JOB,X,D,2,%2)
QUIT
+4 ;
DH SET DH=$ORDER(@(Y_"""B"",DH)"))
if DH]""&(DTL="XU"!($PIECE(DH,DTL,1)=""))
GOTO A
QUIT
+1 ;
ERM WRITE $CHAR(7),!!?5,"Was not able to get a message number for the network INIT",!?10,"DIFROM ABORTED!!",!
QUIT
+1 ;
Q GOTO Q^DIFROM11
SBF NEW I,II
+1 SET I=0
FOR
SET I=$ORDER(F(I))
if I'>0
QUIT
SET II=0
FOR
SET II=$ORDER(F(I,II))
if II'>0
QUIT
SET ^UTILITY("^",$JOB,"SBF",I,II)=""
+2 QUIT
