DGPT701 ;ALB/MTC - Process 701 Transaction ;10/06/1999
;;5.3;Registration;**64,164,251,415,729,1015**;Aug 13, 1993;Build 21
; 10/06/1999 ACS - Removed Place of Disposition codes M,Y,Z from the list of
; invalid codes.
;
EN ;
Q
SET ;
S DGPTSTR=$G(^TMP("AEDIT",$J,"N701",DGPTAL7))
D PARSE^DGPT701P
DTE ;
S (X,DGPTDDS)=$$FMDT^DGPT101($E(DGPTDDTD,1,6))_"."_$E(DGPTDDTD,7,10)
S %DT="XT" D ^%DT I Y<0 S DGPTERC=705 D ERR G:DGPTEDFL EXIT
I Y>0 D DD^%DT S DGPTDTD=$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")
S X1=DGPTNOW,X2=+DGPTDDS D ^%DTC I X<0 S DGPTERC=740 D ERR G:DGPTEDFL EXIT
S X1=+DGPTDDS,X2=+DGPTDTS D ^%DTC S DGPTELP=X I X<0 S DGPTERC=737 D ERR G:DGPTEDFL EXIT
CHECK ;
TSPEC ; CHECK TREATING SPECIALTY CODE
N DGPTDSP1
I DGPTDSP'?2AN S DGPTERC=706 D ERR G:DGPTEDFL EXIT G DISPTY
S DGPTSP1=$E(DGPTDSP,1),DGPTSP2=$E(DGPTDSP,2),DGPTERC=0
D CHECK^DGPTAE02 I DGPTERC S DGPTERC=706 D ERR G:DGPTEDFL EXIT G DISPTY
;-- Active treating specialty edit check
I $E(DGPTDSP,1)=0!($E(DGPTDSP,1)=" ") S DGPTDSP=$E(DGPTDSP,2)
; DGPTDSP := ptf code (alpha-numeric) value (file:42.4,field:7)
; DGPTDSP1 := dinum value (ien, file:42.4,field:.001)
S DGPTDSP1=+$O(^DIC(42.4,"C",DGPTDSP,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,DGPTDSP1,DGPTDDS) S DGPTERC=706,DGPTSER(DGPTDDS_701)=1 D ERR G:DGPTEDFL EXIT
;
DISPTY ;
I (DGPTDTY<1)!(DGPTDTY>7) S DGPTERC=707 D ERR G:DGPTEDFL EXIT G OPCAR
S DGPTERC=0 D DISPTY^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
OPCAR ;
I "13 "'[DGPTDOP S DGPTERC=708 D ERR G:DGPTEDFL EXIT G VA
I DGPTDOP'=" " S DGPTERC=0 D OP^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
VA ;
I "12 "'[DGPTDVA S DGPTERC=709 D ERR G:DGPTEDFL EXIT
;
VAOP ;-- check for inconsistencies between opcare and va aspices
I DGPTDVA=2,DGPTDOP=1 D G:DGPTEDFL EXIT
. S DGPTERC=708 D ERR
. S DGPTERC=709 D ERR
CDR ;
I DGPTDLR'?6" "&(DGPTDLR'?." "6N) S DGPTERC=775 D ERR G:DGPTEDFL EXIT
POD ;
;I "68EIMNOQSVWYZ"[DGPTDPD S DGPTERC=710 D ERR G:DGPTEDFL EXIT G RECF
I "68EINOQSVW"[DGPTDPD S DGPTERC=710 D ERR G:DGPTEDFL EXIT G RECF
S DGPTERC=0 D POD^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
RECF ;
I DGPTDVA'=1!(DGPTDRF=" ") G ASIH
I DGPTDRF[" " S DGPTDRF=$P(DGPTDRF," ",1)
I DGPTDRF="" S DGPTERC=711 D ERR G:DGPTEDFL EXIT
ASIH ;
I DGPTDAS'=" ",DGPTDAS'?2E1N S DGPTERC=712 D ERR G:DGPTEDFL EXIT
;
LEAVE ;
S DGPTERC=0 D LEAVE^DGPTAE02 D:DGPTERC ERR G:DGPTEDFL EXIT
SC ;
I DGPTDSC'=" "&(DGPTDSC'?3N) S DGPTERC=730 D ERR G:DGPTEDFL EXIT G CP
S DGPTDSC=+DGPTDSC
CP ;
S DGPTERC=0 D CANDP^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
DIAG ;
S DGPTERC=0 D ^DGPT70DX I DGPTERC D ERR G:DGPTEDFL EXIT
OVER ; Pass FY92 edits for earlier data
I DGPTDDS'>2911001 G ONED
LEG ; LEGIONNAIRE'S DISEASE
S DGPTERC=0 D LEG^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
SUI ; Suicide indicator
S DGPTERC=0 D SUI^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
DRUG ;
S DGPTERC=0 D DRUG^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
AXES ; Psych axises
I '$P($G(^DIC(42.4,+DGPTDSP1,0)),U,4) S (DGPT70X4,DGPT7X51,DGPT7X52)=" " G ONED
S DGPTERC=0 D AXIV^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
S DGPTERC=0 D AXV1^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
S DGPTERC=0 D AXV2^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
ONED ;
I (DGPTDDXO=" ")&('$D(^TMP("AEDIT",$J,"N702"))&'$D(^TMP("AEDIT",$J,"N703"))) S DGPTERC=718 D ERR G:DGPTEDFL EXIT
I (DGPTDDXO="X")&($D(^TMP("AEDIT",$J,"N072"))) S DGPTERC=719 D ERR G:DGPTEDFL EXIT
EXIT ;
Q
ERR ;
D WRTERR^DGPTAE(DGPTERC,"N701",DGPTAL7)
S ERROR=1
Q
DGPT701 ;ALB/MTC - Process 701 Transaction ;10/06/1999
+1 ;;5.3;Registration;**64,164,251,415,729,1015**;Aug 13, 1993;Build 21
+2 ; 10/06/1999 ACS - Removed Place of Disposition codes M,Y,Z from the list of
+3 ; invalid codes.
+4 ;
EN ;
+1 QUIT
SET ;
+1 SET DGPTSTR=$GET(^TMP("AEDIT",$JOB,"N701",DGPTAL7))
+2 DO PARSE^DGPT701P
DTE ;
+1 SET (X,DGPTDDS)=$$FMDT^DGPT101($EXTRACT(DGPTDDTD,1,6))_"."_$EXTRACT(DGPTDDTD,7,10)
+2 SET %DT="XT"
DO ^%DT
IF Y<0
SET DGPTERC=705
DO ERR
IF DGPTEDFL
GOTO EXIT
+3 IF Y>0
DO DD^%DT
SET DGPTDTD=$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")
+4 SET X1=DGPTNOW
SET X2=+DGPTDDS
DO ^%DTC
IF X<0
SET DGPTERC=740
DO ERR
IF DGPTEDFL
GOTO EXIT
+5 SET X1=+DGPTDDS
SET X2=+DGPTDTS
DO ^%DTC
SET DGPTELP=X
IF X<0
SET DGPTERC=737
DO ERR
IF DGPTEDFL
GOTO EXIT
CHECK ;
TSPEC ; CHECK TREATING SPECIALTY CODE
+1 NEW DGPTDSP1
+2 IF DGPTDSP'?2AN
SET DGPTERC=706
DO ERR
IF DGPTEDFL
GOTO EXIT
GOTO DISPTY
+3 SET DGPTSP1=$EXTRACT(DGPTDSP,1)
SET DGPTSP2=$EXTRACT(DGPTDSP,2)
SET DGPTERC=0
+4 DO CHECK^DGPTAE02
IF DGPTERC
SET DGPTERC=706
DO ERR
IF DGPTEDFL
GOTO EXIT
GOTO DISPTY
+5 ;-- Active treating specialty edit check
+6 IF $EXTRACT(DGPTDSP,1)=0!($EXTRACT(DGPTDSP,1)=" ")
SET DGPTDSP=$EXTRACT(DGPTDSP,2)
+7 ; DGPTDSP := ptf code (alpha-numeric) value (file:42.4,field:7)
+8 ; DGPTDSP1 := dinum value (ien, file:42.4,field:.001)
+9 SET DGPTDSP1=+$ORDER(^DIC(42.4,"C",DGPTDSP,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,DGPTDSP1,DGPTDDS)
SET DGPTERC=706
SET DGPTSER(DGPTDDS_701)=1
DO ERR
IF DGPTEDFL
GOTO EXIT
+13 ;
DISPTY ;
+1 IF (DGPTDTY<1)!(DGPTDTY>7)
SET DGPTERC=707
DO ERR
IF DGPTEDFL
GOTO EXIT
GOTO OPCAR
+2 SET DGPTERC=0
DO DISPTY^DGPTAE02
IF DGPTERC
DO ERR
IF DGPTEDFL
GOTO EXIT
OPCAR ;
+1 IF "13 "'[DGPTDOP
SET DGPTERC=708
DO ERR
IF DGPTEDFL
GOTO EXIT
GOTO VA
+2 IF DGPTDOP'=" "
SET DGPTERC=0
DO OP^DGPTAE02
IF DGPTERC
DO ERR
IF DGPTEDFL
GOTO EXIT
VA ;
+1 IF "12 "'[DGPTDVA
SET DGPTERC=709
DO ERR
IF DGPTEDFL
GOTO EXIT
+2 ;
VAOP ;-- check for inconsistencies between opcare and va aspices
+1 IF DGPTDVA=2
IF DGPTDOP=1
Begin DoDot:1
+2 SET DGPTERC=708
DO ERR
+3 SET DGPTERC=709
DO ERR
End DoDot:1
IF DGPTEDFL
GOTO EXIT
CDR ;
+1 IF DGPTDLR'?6" "&(DGPTDLR'?." "6N)
SET DGPTERC=775
DO ERR
IF DGPTEDFL
GOTO EXIT
POD ;
+1 ;I "68EIMNOQSVWYZ"[DGPTDPD S DGPTERC=710 D ERR G:DGPTEDFL EXIT G RECF
+2 IF "68EINOQSVW"[DGPTDPD
SET DGPTERC=710
DO ERR
IF DGPTEDFL
GOTO EXIT
GOTO RECF
+3 SET DGPTERC=0
DO POD^DGPTAE02
IF DGPTERC
DO ERR
IF DGPTEDFL
GOTO EXIT
RECF ;
+1 IF DGPTDVA'=1!(DGPTDRF=" ")
GOTO ASIH
+2 IF DGPTDRF[" "
SET DGPTDRF=$PIECE(DGPTDRF," ",1)
+3 IF DGPTDRF=""
SET DGPTERC=711
DO ERR
IF DGPTEDFL
GOTO EXIT
ASIH ;
+1 IF DGPTDAS'=" "
IF DGPTDAS'?2E1N
SET DGPTERC=712
DO ERR
IF DGPTEDFL
GOTO EXIT
+2 ;
LEAVE ;
+1 SET DGPTERC=0
DO LEAVE^DGPTAE02
IF DGPTERC
DO ERR
IF DGPTEDFL
GOTO EXIT
SC ;
+1 IF DGPTDSC'=" "&(DGPTDSC'?3N)
SET DGPTERC=730
DO ERR
IF DGPTEDFL
GOTO EXIT
GOTO CP
+2 SET DGPTDSC=+DGPTDSC
CP ;
+1 SET DGPTERC=0
DO CANDP^DGPTAE02
IF DGPTERC
DO ERR
IF DGPTEDFL
GOTO EXIT
DIAG ;
+1 SET DGPTERC=0
DO ^DGPT70DX
IF DGPTERC
DO ERR
IF DGPTEDFL
GOTO EXIT
OVER ; Pass FY92 edits for earlier data
+1 IF DGPTDDS'>2911001
GOTO ONED
LEG ; LEGIONNAIRE'S DISEASE
+1 SET DGPTERC=0
DO LEG^DGPTAE02
IF DGPTERC
DO ERR
IF DGPTEDFL
GOTO EXIT
SUI ; Suicide indicator
+1 SET DGPTERC=0
DO SUI^DGPTAE02
IF DGPTERC
DO ERR
IF DGPTEDFL
GOTO EXIT
DRUG ;
+1 SET DGPTERC=0
DO DRUG^DGPTAE02
IF DGPTERC
DO ERR
IF DGPTEDFL
GOTO EXIT
AXES ; Psych axises
+1 IF '$PIECE($GET(^DIC(42.4,+DGPTDSP1,0)),U,4)
SET (DGPT70X4,DGPT7X51,DGPT7X52)=" "
GOTO ONED
+2 SET DGPTERC=0
DO AXIV^DGPTAE02
IF DGPTERC
DO ERR
IF DGPTEDFL
GOTO EXIT
+3 SET DGPTERC=0
DO AXV1^DGPTAE02
IF DGPTERC
DO ERR
IF DGPTEDFL
GOTO EXIT
+4 SET DGPTERC=0
DO AXV2^DGPTAE02
IF DGPTERC
DO ERR
IF DGPTEDFL
GOTO EXIT
ONED ;
+1 IF (DGPTDDXO=" ")&('$DATA(^TMP("AEDIT",$JOB,"N702"))&'$DATA(^TMP("AEDIT",$JOB,"N703")))
SET DGPTERC=718
DO ERR
IF DGPTEDFL
GOTO EXIT
+2 IF (DGPTDDXO="X")&($DATA(^TMP("AEDIT",$JOB,"N072")))
SET DGPTERC=719
DO ERR
IF DGPTEDFL
GOTO EXIT
EXIT ;
+1 QUIT
ERR ;
+1 DO WRTERR^DGPTAE(DGPTERC,"N701",DGPTAL7)
+2 SET ERROR=1
+3 QUIT
