DGPTFVC.m

DGPTFVC ;ALB/MTC - PTF VALIDITY CHECK ; 01 MAY 91 @0800

 ;;5.3;Registration;**37,234,1015**;Aug 13, 1993;Build 21

PTF S DIC="^DGPT(",DIC(0)="MAQE",DIC("S")="I $P(^(0),U,11)=1" D ^DIC K DIC Q:Y'>0  S DGERR=-1,(PTF,J)=+Y D LOG^DGPTFTR W:DGERR'>0 !," NO ERRORS"

 K DGLOGIC,DGDD,DGERR G PTF

 Q

EN ;entry point from menu option DG PTF VALIDITY CHECK

 ;--setup vars for Austin Edits

 K ^TMP("AEDIT",$J),^TMP("AERROR",$J) S DGACNT=0

 ;

 S DIC="^DGPT(",DIC(0)="MAQE",DIC("S")="I $P(^(0),U,11)=1" D ^DIC K DIC I Y'>0 K DGACNT Q

 N DGSDFN S DGSDFN=$P(Y,U,2)

 S PTF=+Y,Y=$S($D(^DGPT(+Y,70)):+^(70),1:0) D FMT^DGPTUTL

 S:DT<2901001 DGPTFMT=1 ; needed so test sites can still validate 80col.

 S Y=1 D RTY^DGPTUTL

 S DGERR=0,DGCNT=1,J=PTF

 D SETTRAN G:DGOUT Q

 D LOG^DGPTFTR G Q:DGERR>0

 W !,"Performing Additional Edits..." D ^DGPTAE G Q:DGERR>0

XMIT K XMY S XMZ=DGXMZ,XMDUZ=.5,XMY(DUZ)="",DGJ=J,^XMB(3.9,XMZ,2,0)="3.92A^"_DGCNT-1_"^"_DGCNT-1_"^"_DT

 D ENT1^XMD

 W !,"Message Sent"

 ;

Q K DGXMZ,XMZ,XMDUN,XMY,DGOUT,DGLOGIC,DGERR,XMDUZ,DGRTY,DGRTY0,DGPTFMT,XMSUB,XMTEXT,Y,J,PTF,DGJ,DGCNT,DGACNT G EN

SETTRAN ;-- setup mailman transmission

 S DGOUT=0

 S Y=$P(^DPT(+^DGPT(+J,0),0),U,1),XMSUB=Y_"  PTF TRANSMISSION ",XMDUZ=DUZ,XMDUN=$P(^VA(200,DUZ,0),U)

 D GET^XMA2

 I $D(XMZ),(XMZ>0) S DGXMZ=XMZ K XMZ G SETQ

 W !,"*** ERROR *** Unable to create MailMan message... Try again later"

 S DGOUT=1

SETQ ;

 Q

DGPTFVC   ;ALB/MTC - PTF VALIDITY CHECK ; 01 MAY 91 @0800

 +1       ;;5.3;Registration;**37,234,1015**;Aug 13, 1993;Build 21

PTF        SET DIC="^DGPT("

           SET DIC(0)="MAQE"

           SET DIC("S")="I $P(^(0),U,11)=1"

           DO ^DIC

           KILL DIC

           IF Y'>0

               QUIT 

           SET DGERR=-1

           SET (PTF,J)=+Y

           DO LOG^DGPTFTR

           IF DGERR'>0

               WRITE !," NO ERRORS"

 +1        KILL DGLOGIC,DGDD,DGERR

           GOTO PTF

 +2        QUIT 

EN        ;entry point from menu option DG PTF VALIDITY CHECK

 +1       ;--setup vars for Austin Edits

 +2        KILL ^TMP("AEDIT",$JOB),^TMP("AERROR",$JOB)

           SET DGACNT=0

 +3       ;

 +4        SET DIC="^DGPT("

           SET DIC(0)="MAQE"

           SET DIC("S")="I $P(^(0),U,11)=1"

           DO ^DIC

           KILL DIC

           IF Y'>0

               KILL DGACNT

               QUIT 

 +5        NEW DGSDFN

           SET DGSDFN=$PIECE(Y,U,2)

 +6        SET PTF=+Y

           SET Y=$SELECT($DATA(^DGPT(+Y,70)):+^(70),1:0)

           DO FMT^DGPTUTL

 +7       ; needed so test sites can still validate 80col.

           IF DT<2901001

               SET DGPTFMT=1

 +8        SET Y=1

           DO RTY^DGPTUTL

 +9        SET DGERR=0

           SET DGCNT=1

           SET J=PTF

 +10       DO SETTRAN

           IF DGOUT

               GOTO Q

 +11       DO LOG^DGPTFTR

           IF DGERR>0

               GOTO Q

 +12       WRITE !,"Performing Additional Edits..."

           DO ^DGPTAE

           IF DGERR>0

               GOTO Q

XMIT       KILL XMY

           SET XMZ=DGXMZ

           SET XMDUZ=.5

           SET XMY(DUZ)=""

           SET DGJ=J

           SET ^XMB(3.9,XMZ,2,0)="3.92A^"_DGCNT-1_"^"_DGCNT-1_"^"_DT

 +1        DO ENT1^XMD

 +2        WRITE !,"Message Sent"

 +3       ;

Q          KILL DGXMZ,XMZ,XMDUN,XMY,DGOUT,DGLOGIC,DGERR,XMDUZ,DGRTY,DGRTY0,DGPTFMT,XMSUB,XMTEXT,Y,J,PTF,DGJ,DGCNT,DGACNT

           GOTO EN

SETTRAN   ;-- setup mailman transmission

 +1        SET DGOUT=0

 +2        SET Y=$PIECE(^DPT(+^DGPT(+J,0),0),U,1)

           SET XMSUB=Y_"  PTF TRANSMISSION "

           SET XMDUZ=DUZ

           SET XMDUN=$PIECE(^VA(200,DUZ,0),U)

 +3        DO GET^XMA2

 +4        IF $DATA(XMZ)

               IF (XMZ>0)

                   SET DGXMZ=XMZ

                   KILL XMZ

                   GOTO SETQ

 +5        WRITE !,"*** ERROR *** Unable to create MailMan message... Try again later"

 +6        SET DGOUT=1

SETQ      ;

 +1        QUIT