DGPT501.m

DGPT501 ;ALB/MTC - Set up process 501 transmission ; 8/27/03 10:05am

 ;;5.3;Registration;**64,164,529,729,1015**;Aug 13, 1993;Build 21

 ;

EN ;

 N ERROR

 S DGPTEDFL=0

PARSE ; Set up record string, parse record

 S DGPTSTR=^TMP("AEDIT",$J,NODE,SEQ)

 D SET^DGPT501P

DATE ;

 S DGPTMDT=$E(DGPTSTR,31,40),(X,DGPTMDTS)=$$FMDT^DGPT101($E(DGPTMDT,1,6))_"."_$E(DGPTMDT,7,10) S %DT="XT" D ^%DT K %DT I Y<0 S DGPTERC=505 D ERR G:DGPTEDFL EXIT G ELAPS

 D DD^%DT S DGPTMDT=$E(Y,5,6)_"-"_$E(Y,1,3)_"-"_$E(Y,9,12)_" "_$S($P(Y,"@",2)]"":$E($P(Y,"@",2),1,5),1:"00:00")

 I DGPTMDT'?1.2N1"-"3U1"-"4N1" "2N1":"2N S DGPTERC=505 D ERR G:DGPTEDFL EXIT G TSPEC

 I DGPTMDTS<DGPTDTS S DGPTERC=537 D ERR G:DGPTEDFL EXIT

 I DGPTMDTS>DGPTDDS S DGPTERC=540 D ERR G:DGPTEDFL EXIT

ELAPS ;

 S DGPTERC=0 S X1=DGPTMDTS D 501^DGPTAE03 I DGPTERC D ERR G:DGPTEDFL EXIT

TSPEC ;

 N DGPTMSC1

 I DGPTMSC'?2AN S DGPTERC=506 D ERR G:DGPTEDFL EXIT G LEAV

 S DGPTSP1=$E(DGPTMSC,1),DGPTSP2=$E(DGPTMSC,2),DGPTERC=0

 D CHECK^DGPTAE02 I DGPTERC S DGPTERC=506 D ERR G:DGPTEDFL EXIT G LEAV

 ;-- Active treating specialty edit check

 I $E(DGPTMSC,1)=0!($E(DGPTMSC,1)=" ") S DGPTMSC=$E(DGPTMSC,2)

 ; DGPTMSC  := ptf code (alpha-numeric) value (file:42.4,field:7)

 ; DGPTMSC1 := dinum value (ien, file:42.4,field:001)

 S DGPTMSC1=+$O(^DIC(42.4,"C",DGPTMSC,0))

 ;-- If not active treat spec, set flag to print error msg during

 ;-- PTF close-out error display at WRER^DGPTAEE

 I '$$ACTIVE^DGACT(42.4,DGPTMSC1,DGPTMDTS) S DGPTERC=506,DGPTSER(DGPTMDTS_501)=1 D ERR G:DGPTEDFL EXIT

LEAV ;

 I DGPTMPD'?1.3N S DGPTERC=508 D ERR G:DGPTEDFL EXIT

SPINL ;

 D SP^DGPTAE03 I DGPTERC D ERR G:DGPTEDFL EXIT

LOCCDR ;

 I DGPTMLR'?6N S DGPTERC=575 D ERR G:DGPTEDFL EXIT G LOCTRS

 ;

LOCTRS ;

 I DGPTMLC'?2AN&(DGPTMLC'="  ") S DGPTERC=576 D ERR G:DGPTEDFL EXIT G DIAG

 I DGPTMLC="  "&(DGPTMLR="000000") G DIAG

 S DGPTSP1=$E(DGPTMLC,1),DGPTSP2=$E(DGPTMLC,2),DGPTERC=0

 D CHECK^DGPTAE02 I DGPTERC S DGPTERC=576 D ERR G:DGPTEDFL EXIT

DIAG ;

 D ^DGPT50DI G:DGPTEDFL EXIT

BSTAT ;

 I "12345 "'[DGPTMBS S DGPTERC=515 D ERR G:DGPTEDFL EXIT

FY92 ;

 I DGPTDDS<2911001 G GOOD

LEG ; Legionnaires disease

 S DGPTERC=0 D LEG^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT

SUI ; Suicide indicator

 S DGPTERC=0 D SUI^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT

DRUG ; Drug indicator

 S DGPTERC=0 D DRUG^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT

AXES ;Axis 4 and 5

 I '$P($G(^DIC(42.4,+DGPTMSC1,0)),U,4) S (DGPTMXIV,DGPTMXV1,DGPTMXV2)=" " G SERVC

 S DGPTERC=0 D AXIV^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT

 S DGPTERC=0 D AXV1^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT

 S DGPTERC=0 D AXV2^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT

SERVC ; Service connected indicator

 S DGPTERC=0 D SRVC^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT

GOOD ;

 W:'$D(ERROR) "."

EXIT ;

 K DGPTMD1,DGPTMD2,DGPTMD3,DGPTMD4,DGPTMD5,DGPTMDT,DGPTMDTS,DGPTMLC,DGPTMLD,DGPTMLR,DGPTMPD,DGPTMSC,DGPTMSI,DGPTMSR,DGPTMXX,DGPTSTR,DGPTS,DGPTSP1,DGPTSP2

 K DGPTMLG,DGPTMSU,DGPTMDG,DGPTMXIV,DGPTMXV1,DGPTMXV2,DGPT50SR,DGPTMBS

 Q

ERR ;

 D WRTERR^DGPTAE(DGPTERC,NODE,SEQ)

 S ERROR=1

 Q

DGPT501   ;ALB/MTC - Set up process 501 transmission ; 8/27/03 10:05am

 +1       ;;5.3;Registration;**64,164,529,729,1015**;Aug 13, 1993;Build 21

 +2       ;

EN        ;

 +1        NEW ERROR

 +2        SET DGPTEDFL=0

PARSE     ; Set up record string, parse record

 +1        SET DGPTSTR=^TMP("AEDIT",$JOB,NODE,SEQ)

 +2        DO SET^DGPT501P

DATE      ;

 +1        SET DGPTMDT=$EXTRACT(DGPTSTR,31,40)

           SET (X,DGPTMDTS)=$$FMDT^DGPT101($EXTRACT(DGPTMDT,1,6))_"."_$EXTRACT(DGPTMDT,7,10)

           SET %DT="XT"

           DO ^%DT

           KILL %DT

           IF Y<0

               SET DGPTERC=505

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

               GOTO ELAPS

 +2        DO DD^%DT

           SET DGPTMDT=$EXTRACT(Y,5,6)_"-"_$EXTRACT(Y,1,3)_"-"_$EXTRACT(Y,9,12)_" "_$SELECT($PIECE(Y,"@",2)]"":$EXTRACT($PIECE(Y,"@",2),1,5),1:"00:00")

 +3        IF DGPTMDT'?1.2N1"-"3U1"-"4N1" "2N1":"2N

               SET DGPTERC=505

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

               GOTO TSPEC

 +4        IF DGPTMDTS<DGPTDTS

               SET DGPTERC=537

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

 +5        IF DGPTMDTS>DGPTDDS

               SET DGPTERC=540

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

ELAPS     ;

 +1        SET DGPTERC=0

           SET X1=DGPTMDTS

           DO 501^DGPTAE03

           IF DGPTERC

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

TSPEC     ;

 +1        NEW DGPTMSC1

 +2        IF DGPTMSC'?2AN

               SET DGPTERC=506

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

               GOTO LEAV

 +3        SET DGPTSP1=$EXTRACT(DGPTMSC,1)

           SET DGPTSP2=$EXTRACT(DGPTMSC,2)

           SET DGPTERC=0

 +4        DO CHECK^DGPTAE02

           IF DGPTERC

               SET DGPTERC=506

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

               GOTO LEAV

 +5       ;-- Active treating specialty edit check

 +6        IF $EXTRACT(DGPTMSC,1)=0!($EXTRACT(DGPTMSC,1)=" ")

               SET DGPTMSC=$EXTRACT(DGPTMSC,2)

 +7       ; DGPTMSC  := ptf code (alpha-numeric) value (file:42.4,field:7)

 +8       ; DGPTMSC1 := dinum value (ien, file:42.4,field:001)

 +9        SET DGPTMSC1=+$ORDER(^DIC(42.4,"C",DGPTMSC,0))

 +10      ;-- If not active treat spec, set flag to print error msg during

 +11      ;-- PTF close-out error display at WRER^DGPTAEE

 +12       IF '$$ACTIVE^DGACT(42.4,DGPTMSC1,DGPTMDTS)

               SET DGPTERC=506

               SET DGPTSER(DGPTMDTS_501)=1

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

LEAV      ;

 +1        IF DGPTMPD'?1.3N

               SET DGPTERC=508

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

SPINL     ;

 +1        DO SP^DGPTAE03

           IF DGPTERC

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

LOCCDR    ;

 +1        IF DGPTMLR'?6N

               SET DGPTERC=575

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

               GOTO LOCTRS

 +2       ;

LOCTRS    ;

 +1        IF DGPTMLC'?2AN&(DGPTMLC'="  ")

               SET DGPTERC=576

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

               GOTO DIAG

 +2        IF DGPTMLC="  "&(DGPTMLR="000000")

               GOTO DIAG

 +3        SET DGPTSP1=$EXTRACT(DGPTMLC,1)

           SET DGPTSP2=$EXTRACT(DGPTMLC,2)

           SET DGPTERC=0

 +4        DO CHECK^DGPTAE02

           IF DGPTERC

               SET DGPTERC=576

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

DIAG      ;

 +1        DO ^DGPT50DI

           IF DGPTEDFL

               GOTO EXIT

BSTAT     ;

 +1        IF "12345 "'[DGPTMBS

               SET DGPTERC=515

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

FY92      ;

 +1        IF DGPTDDS<2911001

               GOTO GOOD

LEG       ; Legionnaires disease

 +1        SET DGPTERC=0

           DO LEG^DGPT50MS

           IF DGPTERC

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

SUI       ; Suicide indicator

 +1        SET DGPTERC=0

           DO SUI^DGPT50MS

           IF DGPTERC

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

DRUG      ; Drug indicator

 +1        SET DGPTERC=0

           DO DRUG^DGPT50MS

           IF DGPTERC

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

AXES      ;Axis 4 and 5

 +1        IF '$PIECE($GET(^DIC(42.4,+DGPTMSC1,0)),U,4)

               SET (DGPTMXIV,DGPTMXV1,DGPTMXV2)=" "

               GOTO SERVC

 +2        SET DGPTERC=0

           DO AXIV^DGPT50MS

           IF DGPTERC

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

 +3        SET DGPTERC=0

           DO AXV1^DGPT50MS

           IF DGPTERC

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

 +4        SET DGPTERC=0

           DO AXV2^DGPT50MS

           IF DGPTERC

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

SERVC     ; Service connected indicator

 +1        SET DGPTERC=0

           DO SRVC^DGPT50MS

           IF DGPTERC

               DO ERR

               IF DGPTEDFL

                   GOTO EXIT

GOOD      ;

 +1        IF '$DATA(ERROR)

               WRITE "."

EXIT      ;

 +1        KILL DGPTMD1,DGPTMD2,DGPTMD3,DGPTMD4,DGPTMD5,DGPTMDT,DGPTMDTS,DGPTMLC,DGPTMLD,DGPTMLR,DGPTMPD,DGPTMSC,DGPTMSI,DGPTMSR,DGPTMXX,DGPTSTR,DGPTS,DGPTSP1,DGPTSP2

 +2        KILL DGPTMLG,DGPTMSU,DGPTMDG,DGPTMXIV,DGPTMXV1,DGPTMXV2,DGPT50SR,DGPTMBS

 +3        QUIT 

ERR       ;

 +1        DO WRTERR^DGPTAE(DGPTERC,NODE,SEQ)

 +2        SET ERROR=1

 +3        QUIT