DGPT535 ;ALB/MTC - Process 535 transmission ; 16 NOV 92
;;5.3;Registration;**64,164,729,1015**;Aug 13, 1993;Build 21
;
EN ;
S DGPTSTR=^TMP("AEDIT",$J,NODE,SEQ),DGPTEDFL=0
S DGPTTDT=$E(DGPTSTR,31,40),(X,DGPTTDTS)=$$FMDT^DGPT101($E(DGPTTDT,1,6))_"."_$E(DGPTTDT,7,10) S %DT="XT" D ^%DT I Y<0 S DGPTERC=505 D ERR G:DGPTEDFL EXIT G SET
D DD^%DT S DGPTTDT=$E(Y,5,6)_"-"_$E(Y,1,3)_"-"_$E(Y,8,11)_" "_$S($P(Y,"@",2)]"":$E($P(Y,"@",2),1,5),1:"00:00")
SET ;
S DGPTTLR=$E(DGPTSTR,41,46),DGPTTLC=$E(DGPTSTR,47,48),DGPTTSR=$E(DGPTSTR,49,54),DGPTTSC=$E(DGPTSTR,55,56),DGPTTLD=$E(DGPTSTR,57,59),DGPTTPD=$E(DGPTSTR,60,62),DGPTXX=$E(DGPTSTR,63,71)
DTE ;
S DGPTTDDS=$$FMDT^DGPT101($E(DGPTSTR,31,36))_"."_$E(DGPTSTR,37,40)
I (DGPTTDDS'>DGPTDTS)!(DGPTTDDS'<DGPTDDS) S DGPTERC=540 D ERR G:DGPTEDFL EXIT
TSPEC ;
N DGPTTSC1
I DGPTTSC'?2AN S DGPTERC=506 D ERR G:DGPTEDFL EXIT
S DGPTSP1=$E(DGPTTSC,1),DGPTSP2=$E(DGPTTSC,2),DGPTERC=0
D CHECK^DGPTAE02 I DGPTERC S DGPTERC=506 D ERR G:DGPTEDFL EXIT G LSPEC
;-- Active treating specialty edit check
I $E(DGPTTSC,1)=0!($E(DGPTTSC,1)=" ") S DGPTTSC=$E(DGPTTSC,2)
; DGPTTSC := ptf code (alpha-numeric) value (file:42.4,field:7)
; DGPTTSC1 := dinum value (file:42.4,field:.001)
S DGPTTSC1=+$O(^DIC(42.4,"C",DGPTTSC,0))
;-- If not active treat spec, set 535 flag to print error msg during
;-- PTF close-out error display at WRER^DGPTAEE
I '$$ACTIVE^DGACT(42.4,DGPTTSC1,DGPTTDTS) S DGPTERC=506,DGPTSER(DGPTTDTS_535)=1 D ERR G:DGPTEDFL EXIT
LSPEC ;
N DGPTTLC1
I DGPTTLC'?2AN S DGPTERC=506 D ERR G:DGPTEDFL EXIT
S DGPTSP1=$E(DGPTTLC,1),DGPTSP2=$E(DGPTTLC,2),DGPTERC=0
D CHECK^DGPTAE02 I DGPTERC S DGPTERC=506 D ERR G:DGPTEDFL EXIT G LVPAS
;-- Active treating specialty edit check
I $E(DGPTTLC,1)=0!($E(DGPTTLC,1)=" ") S DGPTTLC=$E(DGPTTLC,2)
; DGPTTLC := ptf code (alpha-nemeric) value (file:42.4,field:7)
; DGPTTLC1 := dinum value (file:42.4,field:.001)
S DGPTTLC1=+$O(^DIC(42.4,"C",DGPTTLC,0))
;-- If not active treat spec, set 535 flag to print error msg during
;-- PTF close-out error display at WRER^DGPTAEE
I '$$ACTIVE^DGACT(42.4,DGPTTLC1,DGPTTDTS) S DGPTERC=506,DGPTSER(DGPTTDTS_5351)=1 D ERR G:DGPTEDFL EXIT
LVPAS ;
I DGPTTLD'?1.3N&(DGPTTLD'=" ") S DGPTERC=507 D ERR G:DGPTEDFL EXIT
I DGPTTPD'?1.3N&(DGPTTPD'=" ") S DGPTERC=508 D ERR G:DGPTEDFL EXIT
S DGPTERC=0 S X1=DGPTTDTS D 535^DGPTAE03 D:DGPTERC ERR G:DGPTEDFL EXIT
ALLGD ;
W "."
;
EXIT ;
K DGPTTDT,DGPTTLR,DGPTTLC,DGPTTSR,DGPTTSC,DGPTTLD,DGPTTPD,DGPTSTR
K DGPTLO1,DGPTLO2,DGPTS1,DGPTS2,DGPTTDTS,DGPTTDDS,DGPTXX,X,X1,Y
Q
ERR ;
D WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
Q
DGPT535 ;ALB/MTC - Process 535 transmission ; 16 NOV 92
+1 ;;5.3;Registration;**64,164,729,1015**;Aug 13, 1993;Build 21
+2 ;
EN ;
+1 SET DGPTSTR=^TMP("AEDIT",$JOB,NODE,SEQ)
SET DGPTEDFL=0
+2 SET DGPTTDT=$EXTRACT(DGPTSTR,31,40)
SET (X,DGPTTDTS)=$$FMDT^DGPT101($EXTRACT(DGPTTDT,1,6))_"."_$EXTRACT(DGPTTDT,7,10)
SET %DT="XT"
DO ^%DT
IF Y<0
SET DGPTERC=505
DO ERR
IF DGPTEDFL
GOTO EXIT
GOTO SET
+3 DO DD^%DT
SET DGPTTDT=$EXTRACT(Y,5,6)_"-"_$EXTRACT(Y,1,3)_"-"_$EXTRACT(Y,8,11)_" "_$SELECT($PIECE(Y,"@",2)]"":$EXTRACT($PIECE(Y,"@",2),1,5),1:"00:00")
SET ;
+1 SET DGPTTLR=$EXTRACT(DGPTSTR,41,46)
SET DGPTTLC=$EXTRACT(DGPTSTR,47,48)
SET DGPTTSR=$EXTRACT(DGPTSTR,49,54)
SET DGPTTSC=$EXTRACT(DGPTSTR,55,56)
SET DGPTTLD=$EXTRACT(DGPTSTR,57,59)
SET DGPTTPD=$EXTRACT(DGPTSTR,60,62)
SET DGPTXX=$EXTRACT(DGPTSTR,63,71)
DTE ;
+1 SET DGPTTDDS=$$FMDT^DGPT101($EXTRACT(DGPTSTR,31,36))_"."_$EXTRACT(DGPTSTR,37,40)
+2 IF (DGPTTDDS'>DGPTDTS)!(DGPTTDDS'<DGPTDDS)
SET DGPTERC=540
DO ERR
IF DGPTEDFL
GOTO EXIT
TSPEC ;
+1 NEW DGPTTSC1
+2 IF DGPTTSC'?2AN
SET DGPTERC=506
DO ERR
IF DGPTEDFL
GOTO EXIT
+3 SET DGPTSP1=$EXTRACT(DGPTTSC,1)
SET DGPTSP2=$EXTRACT(DGPTTSC,2)
SET DGPTERC=0
+4 DO CHECK^DGPTAE02
IF DGPTERC
SET DGPTERC=506
DO ERR
IF DGPTEDFL
GOTO EXIT
GOTO LSPEC
+5 ;-- Active treating specialty edit check
+6 IF $EXTRACT(DGPTTSC,1)=0!($EXTRACT(DGPTTSC,1)=" ")
SET DGPTTSC=$EXTRACT(DGPTTSC,2)
+7 ; DGPTTSC := ptf code (alpha-numeric) value (file:42.4,field:7)
+8 ; DGPTTSC1 := dinum value (file:42.4,field:.001)
+9 SET DGPTTSC1=+$ORDER(^DIC(42.4,"C",DGPTTSC,0))
+10 ;-- If not active treat spec, set 535 flag to print error msg during
+11 ;-- PTF close-out error display at WRER^DGPTAEE
+12 IF '$$ACTIVE^DGACT(42.4,DGPTTSC1,DGPTTDTS)
SET DGPTERC=506
SET DGPTSER(DGPTTDTS_535)=1
DO ERR
IF DGPTEDFL
GOTO EXIT
LSPEC ;
+1 NEW DGPTTLC1
+2 IF DGPTTLC'?2AN
SET DGPTERC=506
DO ERR
IF DGPTEDFL
GOTO EXIT
+3 SET DGPTSP1=$EXTRACT(DGPTTLC,1)
SET DGPTSP2=$EXTRACT(DGPTTLC,2)
SET DGPTERC=0
+4 DO CHECK^DGPTAE02
IF DGPTERC
SET DGPTERC=506
DO ERR
IF DGPTEDFL
GOTO EXIT
GOTO LVPAS
+5 ;-- Active treating specialty edit check
+6 IF $EXTRACT(DGPTTLC,1)=0!($EXTRACT(DGPTTLC,1)=" ")
SET DGPTTLC=$EXTRACT(DGPTTLC,2)
+7 ; DGPTTLC := ptf code (alpha-nemeric) value (file:42.4,field:7)
+8 ; DGPTTLC1 := dinum value (file:42.4,field:.001)
+9 SET DGPTTLC1=+$ORDER(^DIC(42.4,"C",DGPTTLC,0))
+10 ;-- If not active treat spec, set 535 flag to print error msg during
+11 ;-- PTF close-out error display at WRER^DGPTAEE
+12 IF '$$ACTIVE^DGACT(42.4,DGPTTLC1,DGPTTDTS)
SET DGPTERC=506
SET DGPTSER(DGPTTDTS_5351)=1
DO ERR
IF DGPTEDFL
GOTO EXIT
LVPAS ;
+1 IF DGPTTLD'?1.3N&(DGPTTLD'=" ")
SET DGPTERC=507
DO ERR
IF DGPTEDFL
GOTO EXIT
+2 IF DGPTTPD'?1.3N&(DGPTTPD'=" ")
SET DGPTERC=508
DO ERR
IF DGPTEDFL
GOTO EXIT
+3 SET DGPTERC=0
SET X1=DGPTTDTS
DO 535^DGPTAE03
IF DGPTERC
DO ERR
IF DGPTEDFL
GOTO EXIT
ALLGD ;
+1 WRITE "."
+2 ;
EXIT ;
+1 KILL DGPTTDT,DGPTTLR,DGPTTLC,DGPTTSR,DGPTTSC,DGPTTLD,DGPTTPD,DGPTSTR
+2 KILL DGPTLO1,DGPTLO2,DGPTS1,DGPTS2,DGPTTDTS,DGPTTDDS,DGPTXX,X,X1,Y
+3 QUIT
ERR ;
+1 DO WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
+2 QUIT
