DGPT601 ;ALB/MTC - Process 601 transmission ; 17 NOV 92
;;5.3;Registration;**64,164,729,1015**;Aug 13, 1993;Build 21
;
;
EN ; Process 601 transmission
N ERROR
K DGPTPAR
S DGPTSTR=^TMP("AEDIT",$J,NODE,SEQ),DGPTEDFL=0,DGPTERP=7
S:$E(DGPTSTR,37,40)="2400" DGPTSTR=$E(DGPTSTR,1,36)_"2359"_$E(DGPTSTR,41,125)
SET ;
S DGPTPSC=$E(DGPTSTR,41,42),DGPTPDY=$E(DGPTSTR,43),DGPTPNT=$E(DGPTSTR,44,46),DGPTPC1=$E(DGPTSTR,47,53),DGPTPC2=$E(DGPTSTR,54,60),DGPTPC3=$E(DGPTSTR,61,67),DGPTPC4=$E(DGPTSTR,68,74),DGPTPC5=$E(DGPTSTR,75,81)
S DGPTPDT=$E(DGPTSTR,31,40)
DATE ;
S (X,DGPTPDTS)=$$FMDT^DGPT101($E(DGPTPDT,1,6))_"."_$E(DGPTPDT,7,10),%DT="XT" D ^%DT I Y<0 S DGPTERC=601 D ERR G:DGPTEDFL EXIT G TSPEC
D DD^%DT S DGPTPDT=$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 DGPTPDT'?1.2N1"-"3U1"-"4N1" "2N1":"2N S DGPTERC=601 D ERR G:DGPTEDFL EXIT
S X1=DGPTDDS,X2=DGPTPDTS D ^%DTC I (X<0)!(%Y<0) S DGPTERC=640 D ERR G:DGPTEDFL EXIT
S X1=DGPTPDTS,X2=DGPTDTS D ^%DTC I (X<0)!(%Y<0) S DGPTERC=637 D ERR G:DGPTEDFL EXIT
;
TSPEC ;
N DGPTPSC1
I DGPTPSC'?2AN S DGPTERC=602 D ERR G:DGPTEDFL EXIT
S DGPTSP1=$E(DGPTPSC,1),DGPTSP2=$E(DGPTPSC,2),DGPTERC=0
D CHECK^DGPTAE02 I DGPTERC S DGPTERC=602 D ERR G:DGPTEDFL EXIT G DIAL
;-- Active treating specialty edit check
I $E(DGPTPSC,1)=0!($E(DGPTPSC,1)=" ") S DGPTPSC=$E(DGPTPSC,2)
; DGPTPSC := ptf code (alpha-numeric) value (file:42.4, field:7)
; DGPTPSC1 := dinum value (ien, file:42.4, field:.001)
S DGPTPSC1=+$O(^DIC(42.4,"C",DGPTPSC,0))
;-- If not active treat spec, set 601 flag to print error msg during
;-- PTF close-out error display at WRER^DGPTAEE
I '$$ACTIVE^DGACT(42.4,DGPTPSC1,DGPTPDTS) S DGPTERC=602,DGPTSER(DGPTPDTS_601)=1 D ERR G:DGPTEDFL EXIT
DIAL ;
;I DGPTPDY'=" " D DIALE I DGPTERC G EXIT
I DGPTPNT=" "!(+DGPTPNT'>0) D G:DGPTEDFL EXIT
.I DGPTPC1="3995 "!(DGPTPC1="5498 ")!(DGPTPC1="5092 ") S DGPTERC=604 D ERR
.I DGPTPC2="3995 "!(DGPTPC2="5498 ")!(DGPTPC2="5092 ") S DGPTERC=604 D ERR
.I DGPTPC3="3995 "!(DGPTPC3="5498 ")!(DGPTPC3="5092 ") S DGPTERC=604 D ERR
.I DGPTPC4="3995 "!(DGPTPC4="5498 ")!(DGPTPC4="5092 ") S DGPTERC=604 D ERR
.I DGPTPC5="3995 "!(DGPTPC5="5498 ")!(DGPTPC5="5092 ") S DGPTERC=604 D ERR
OPS ;
S DGPTERC=0 D ^DGPT60PR G:DGPTEDFL EXIT
;
OPDUP ;--check for duplicate procedure codes
I ((DGPTPDY=" ")&(DGPTPNT=" "))&(+$E(DGPTSTR,47,81)=0) S DGPTERC="605Z" D ERR G EXIT
F DGPTL4=1:1:5 I +@("DGPTPC"_DGPTL4)'=0 S DGPTPAR(+@("DGPTPC"_DGPTL4),DGPTL4)=""
S DGPTPAR1=0 F DGPTL4=1:1:5 S DGPTPAR1=$O(DGPTPAR(DGPTPAR1)) Q:DGPTPAR1="" S DGPTPRA2=$O(DGPTPAR(DGPTPAR1,0)) I DGPTPRA2'="" S DGPTPRA3=$O(DGPTPAR(DGPTPAR1,DGPTPRA2)) I DGPTPRA3'="" S DGPTERC=657 D ERR G:DGPTEDFL EXIT
K DGPTPAR
GOOD ;
W:'$D(ERROR) "."
;
EXIT ;
K DGPTERC,DGPTL3,DGPTL4,DGPTOP,DGPTOP1,DGPTP1,DGPTP2,DGPTPAR1,DGPTPC1,DGPTPC2,DGPTPC3,DGPTPC4,DGPTPC5,DGPTPDT,DGPTPDTS,DGPTPDY,DGPTPFL,DGPTPNT,DGPTPP,DGPTPRA2,DGPTPRA3,DGPTPSC,DGPTSTR,X,X1,X2,Y
K DGPTXX
Q
ERR ;
D WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
S ERROR=1
Q
DIALE ;
I "12345678"'[DGPTPDY S DGPTERC=603 D ERR G:DGPTEDFL EXIT
I DGPTPNT=" "!(+DGPTPNT'>0) S DGPTERC=604 D ERR G:DGPTEDFL EXIT
Q
;
DGPT601 ;ALB/MTC - Process 601 transmission ; 17 NOV 92
+1 ;;5.3;Registration;**64,164,729,1015**;Aug 13, 1993;Build 21
+2 ;
+3 ;
EN ; Process 601 transmission
+1 NEW ERROR
+2 KILL DGPTPAR
+3 SET DGPTSTR=^TMP("AEDIT",$JOB,NODE,SEQ)
SET DGPTEDFL=0
SET DGPTERP=7
+4 IF $EXTRACT(DGPTSTR,37,40)="2400"
SET DGPTSTR=$EXTRACT(DGPTSTR,1,36)_"2359"_$EXTRACT(DGPTSTR,41,125)
SET ;
+1 SET DGPTPSC=$EXTRACT(DGPTSTR,41,42)
SET DGPTPDY=$EXTRACT(DGPTSTR,43)
SET DGPTPNT=$EXTRACT(DGPTSTR,44,46)
SET DGPTPC1=$EXTRACT(DGPTSTR,47,53)
SET DGPTPC2=$EXTRACT(DGPTSTR,54,60)
SET DGPTPC3=$EXTRACT(DGPTSTR,61,67)
SET DGPTPC4=$EXTRACT(DGPTSTR,68,74)
SET DGPTPC5=$EXTRACT(DGPTSTR,75,81)
+2 SET DGPTPDT=$EXTRACT(DGPTSTR,31,40)
DATE ;
+1 SET (X,DGPTPDTS)=$$FMDT^DGPT101($EXTRACT(DGPTPDT,1,6))_"."_$EXTRACT(DGPTPDT,7,10)
SET %DT="XT"
DO ^%DT
IF Y<0
SET DGPTERC=601
DO ERR
IF DGPTEDFL
GOTO EXIT
GOTO TSPEC
+2 DO DD^%DT
SET DGPTPDT=$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 DGPTPDT'?1.2N1"-"3U1"-"4N1" "2N1":"2N
SET DGPTERC=601
DO ERR
IF DGPTEDFL
GOTO EXIT
+4 SET X1=DGPTDDS
SET X2=DGPTPDTS
DO ^%DTC
IF (X<0)!(%Y<0)
SET DGPTERC=640
DO ERR
IF DGPTEDFL
GOTO EXIT
+5 SET X1=DGPTPDTS
SET X2=DGPTDTS
DO ^%DTC
IF (X<0)!(%Y<0)
SET DGPTERC=637
DO ERR
IF DGPTEDFL
GOTO EXIT
+6 ;
TSPEC ;
+1 NEW DGPTPSC1
+2 IF DGPTPSC'?2AN
SET DGPTERC=602
DO ERR
IF DGPTEDFL
GOTO EXIT
+3 SET DGPTSP1=$EXTRACT(DGPTPSC,1)
SET DGPTSP2=$EXTRACT(DGPTPSC,2)
SET DGPTERC=0
+4 DO CHECK^DGPTAE02
IF DGPTERC
SET DGPTERC=602
DO ERR
IF DGPTEDFL
GOTO EXIT
GOTO DIAL
+5 ;-- Active treating specialty edit check
+6 IF $EXTRACT(DGPTPSC,1)=0!($EXTRACT(DGPTPSC,1)=" ")
SET DGPTPSC=$EXTRACT(DGPTPSC,2)
+7 ; DGPTPSC := ptf code (alpha-numeric) value (file:42.4, field:7)
+8 ; DGPTPSC1 := dinum value (ien, file:42.4, field:.001)
+9 SET DGPTPSC1=+$ORDER(^DIC(42.4,"C",DGPTPSC,0))
+10 ;-- If not active treat spec, set 601 flag to print error msg during
+11 ;-- PTF close-out error display at WRER^DGPTAEE
+12 IF '$$ACTIVE^DGACT(42.4,DGPTPSC1,DGPTPDTS)
SET DGPTERC=602
SET DGPTSER(DGPTPDTS_601)=1
DO ERR
IF DGPTEDFL
GOTO EXIT
DIAL ;
+1 ;I DGPTPDY'=" " D DIALE I DGPTERC G EXIT
+2 IF DGPTPNT=" "!(+DGPTPNT'>0)
Begin DoDot:1
+3 IF DGPTPC1="3995 "!(DGPTPC1="5498 ")!(DGPTPC1="5092 ")
SET DGPTERC=604
DO ERR
+4 IF DGPTPC2="3995 "!(DGPTPC2="5498 ")!(DGPTPC2="5092 ")
SET DGPTERC=604
DO ERR
+5 IF DGPTPC3="3995 "!(DGPTPC3="5498 ")!(DGPTPC3="5092 ")
SET DGPTERC=604
DO ERR
+6 IF DGPTPC4="3995 "!(DGPTPC4="5498 ")!(DGPTPC4="5092 ")
SET DGPTERC=604
DO ERR
+7 IF DGPTPC5="3995 "!(DGPTPC5="5498 ")!(DGPTPC5="5092 ")
SET DGPTERC=604
DO ERR
End DoDot:1
IF DGPTEDFL
GOTO EXIT
OPS ;
+1 SET DGPTERC=0
DO ^DGPT60PR
IF DGPTEDFL
GOTO EXIT
+2 ;
OPDUP ;--check for duplicate procedure codes
+1 IF ((DGPTPDY=" ")&(DGPTPNT=" "))&(+$EXTRACT(DGPTSTR,47,81)=0)
SET DGPTERC="605Z"
DO ERR
GOTO EXIT
+2 FOR DGPTL4=1:1:5
IF +@("DGPTPC"_DGPTL4)'=0
SET DGPTPAR(+@("DGPTPC"_DGPTL4),DGPTL4)=""
+3 SET DGPTPAR1=0
FOR DGPTL4=1:1:5
SET DGPTPAR1=$ORDER(DGPTPAR(DGPTPAR1))
IF DGPTPAR1=""
QUIT
SET DGPTPRA2=$ORDER(DGPTPAR(DGPTPAR1,0))
IF DGPTPRA2'=""
SET DGPTPRA3=$ORDER(DGPTPAR(DGPTPAR1,DGPTPRA2))
IF DGPTPRA3'=""
SET DGPTERC=657
DO ERR
IF DGPTEDFL
GOTO EXIT
+4 KILL DGPTPAR
GOOD ;
+1 IF '$DATA(ERROR)
WRITE "."
+2 ;
EXIT ;
+1 KILL DGPTERC,DGPTL3,DGPTL4,DGPTOP,DGPTOP1,DGPTP1,DGPTP2,DGPTPAR1,DGPTPC1,DGPTPC2,DGPTPC3,DGPTPC4,DGPTPC5,DGPTPDT,DGPTPDTS,DGPTPDY,DGPTPFL,DGPTPNT,DGPTPP,DGPTPRA2,DGPTPRA3,DGPTPSC,DGPTSTR,X,X1,X2,Y
+2 KILL DGPTXX
+3 QUIT
ERR ;
+1 DO WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
+2 SET ERROR=1
+3 QUIT
DIALE ;
+1 IF "12345678"'[DGPTPDY
SET DGPTERC=603
DO ERR
IF DGPTEDFL
GOTO EXIT
+2 IF DGPTPNT=" "!(+DGPTPNT'>0)
SET DGPTERC=604
DO ERR
IF DGPTEDFL
GOTO EXIT
+3 QUIT
+4 ;
