- 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
