- DIFROM0 ;SFISC/XAK-GATHER PCS TO SEND ;2:59 PM 25 Sep 1998
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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 - 9999) : ",DIR("B")=^DD("ROU"),DIR(0)="NA^2000:9999"
- 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
- DIFROM0 ;SFISC/XAK-GATHER PCS TO SEND ;2:59 PM 25 Sep 1998
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 SET %=2
- SET DIT=0
- SET DIH=""
- +4 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
- +5 WRITE !
- SET DIR(0)="YA"
- SET DIR("??")="^D ^DIFROMH"
- SET DIR("B")="YES"
- +6 ;NOTE: I removed 9.8 (ROUTINE FILE) from this list for V19 but none of the supporting code. (tkw)
- +7 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
- +8 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 SET DIR("A")="Maximum Routine Size (2000 - 9999) : "
- SET DIR("B")=^DD("ROU")
- SET DIR(0)="NA^2000:9999"
- +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
