Routine: DIFGA1

DIFGA1 ;SFISC/XAK,DCM-FILEGRAM TEMPLATES ;2/27/99  12:35

 ;;22.0;VA FileMan;;Mar 30, 1999;

 ;Per VHA Directive 10-93-142, this routine should not be modified.

Q W:$D(DTOUT) $C(7)

 K Y,C,L,DM,DQI,DA,DICOMP,DICOMPX,I,J,S,DIL,DK

 K D,DIFG,DC,DICS,DP,DU,DXS,DL,DJ,DINS,DIFGLINK

 K DIAXLOC,DIAXMSG,DIAXGL,DIAXF,^UTILITY("DIFG",$J),DJ1,DIAXEF,DIAXDL,DIAXDI,DIAXFILE,DIAXFNO

 K DIAXDICA,DIAXNP,DIAXZ,DIAXDK,DTOUT,DUOUT,DIRUT

 D:$D(DIAX) Q1^DIAXMS

INIT K ^UTILITY("DIFG",$J)

 S (L,DL)=1,(I(0),DI)=DIC,(DK,J(0))=+$P(@(DI_"0)"),U,2)

 S DINS="",(DC,DJ,C,C(0),DIL)=0 Q:'$D(DIAX)

INET K DIC

 S DIC=1,DIC(0)="AEQZ",DIC("S")="I Y'<2,+Y'="_DK_" S DIFILE=+Y,DIAC=""RD"" D ^DIAC I %",DIC("A")="DESTINATION FILE: " D ^DIC Q:Y'>0

 S (DIAXF,DIAXFILE,DIAXFNO,DIAXDL(DL),DIAXDK(DK))=+Y,DIAXGL=$E(^DIC(+Y,0,"GL"),2,99),DIAXEF=Y(0,0),DIAXLOC(DIAXFILE)=""

DIFGA1    ;SFISC/XAK,DCM-FILEGRAM TEMPLATES ;2/27/99  12:35

 +1       ;;22.0;VA FileMan;;Mar 30, 1999;

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

Q          IF $DATA(DTOUT)

               WRITE $CHAR(7)

 +1        KILL Y,C,L,DM,DQI,DA,DICOMP,DICOMPX,I,J,S,DIL,DK

 +2        KILL D,DIFG,DC,DICS,DP,DU,DXS,DL,DJ,DINS,DIFGLINK

 +3        KILL DIAXLOC,DIAXMSG,DIAXGL,DIAXF,^UTILITY("DIFG",$JOB),DJ1,DIAXEF,DIAXDL,DIAXDI,DIAXFILE,DIAXFNO

 +4        KILL DIAXDICA,DIAXNP,DIAXZ,DIAXDK,DTOUT,DUOUT,DIRUT

 +5        IF $DATA(DIAX)

               DO Q1^DIAXMS

 +6        QUIT

 +7       ;

INIT       KILL ^UTILITY("DIFG",$JOB)

 +1        SET (L,DL)=1

           SET (I(0),DI)=DIC

           SET (DK,J(0))=+$PIECE(@(DI_"0)"),U,2)

 +2        SET DINS=""

           SET (DC,DJ,C,C(0),DIL)=0

           IF '$DATA(DIAX)

               QUIT

 +3       ;

INET       KILL DIC

 +1        SET DIC=1

           SET DIC(0)="AEQZ"

           SET DIC("S")="I Y'<2,+Y'="_DK_" S DIFILE=+Y,DIAC=""RD"" D ^DIAC I %"

           SET DIC("A")="DESTINATION FILE: "

           DO ^DIC

           IF Y'>0

               QUIT

 +2        SET (DIAXF,DIAXFILE,DIAXFNO,DIAXDL(DL),DIAXDK(DK))=+Y

           SET DIAXGL=$EXTRACT(^DIC(+Y,0,"GL"),2,99)

           SET DIAXEF=Y(0,0)

           SET DIAXLOC(DIAXFILE)=""

 +3        QUIT

DIFGA1.m