DGPT601 ;ALB/MTC,HIOFO/FT - Process 601 transmission ;3/23/2015 5:19pm
;;5.3;Registration;**64,164,729,850,884,1057**;Aug 13, 1993;Build 17
;
;no external references
;
;called from RTE^DGPTAE
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 ;parse data string and set variables
D:DGPTFMT=2 SET9
D:DGPTFMT=3 SET10
DATE ;date/time of procedure
; DGPTDDS - discharge DT
; DGPTDTS - admission DT
; DGPTPDTS - procedure DT
;
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
I $$FMDIFF^XLFDT(DGPTDDS,DGPTPDTS,2)<0 S DGPTERC=640 D ERR G:DGPTEDFL EXIT ; DG*5.3*1057
I $$FMDIFF^XLFDT(DGPTPDTS,$$FMADD^XLFDT(DGPTDTS,,-72),2)<0 S DGPTERC=637 D ERR G:DGPTEDFL EXIT ; DG*5.3*1057
;
TSPEC ;treating specialty
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 ;dialysis
N DGLOOP,DGPTPCODE
I DGPTPNT=" "!(+DGPTPNT'>0) D G:DGPTEDFL EXIT
.F DGLOOP=1:1:$S(DGPTFMT=3:25,1:5) S DGPTPCODE=@("DGPTPC"_DGLOOP) D
..I DGPTPCODE="3995 "!(DGPTPCODE="5498 ")!(DGPTPCODE="5092 ") S DGPTERC=604 D ERR
..I DGPTPCODE="5A1C00Z"!(DGPTPCODE="5A1C60Z")!(DGPTPCODE="5A1D00Z")!(DGPTPCODE="5A1D60Z")!(DGPTPCODE="3E1M39Z") S DGPTERC=604 D ERR
;
OPS ;operation codes
S DGPTERC=0 D ^DGPT60PR G:DGPTEDFL EXIT
;
OPDUP ;--check for duplicate procedure codes
I DGPTFMT=2 I ((DGPTPDY=" ")&(DGPTPNT=" "))&($E(DGPTSTR,47,81)?1.35" ") S DGPTERC="605Z" D ERR G EXIT
;I DGPTFMT=3 I ((DGPTPDY=" ")&(DGPTPNT=" "))&($E(DGPTSTR,47,245)?1.199" ") S DGPTERC="605Z" D ERR G EXIT
;commenting out duplicate check with dg*5.3*884 ft 11/5/14
;F DGPTL4=1:1:5 I $E(@("DGPTPC"_DGPTL4),1)'=" " S DGPTPAR(@("DGPTPC"_DGPTL4),DGPTL4)=""
;S DGPTPAR1=0 F DGPTL4=1:1:5 S DGPTPAR1=$O(DGPTPAR(DGPTPAR1)) Q:DGPTPAR1="" D G:DGPTEDFL EXIT
;. S DGPTPRA2=$O(DGPTPAR(DGPTPAR1,0))
;. I DGPTPRA2'="" S DGPTPRA3=$O(DGPTPAR(DGPTPAR1,DGPTPRA2))
;. I DGPTPRA3'="" S DGPTERC=657 D ERR
K DGPTPAR
GOOD ;
W:'$D(ERROR) "."
;
EXIT ;
K DGPTERC,DGPTL3,DGPTL4,DGPTOP,DGPTOP1,DGPTP1,DGPTP2,DGPTPAR1
K DGPTPC1,DGPTPC2,DGPTPC3,DGPTPC4,DGPTPC5,DGPTPC6,DGPTPC7,DGPTPC8,DGPTPC9,DGPTPC10,DGPTPC11,DGPTPC12,DGPTPC13,DGPTPC14,DGPTPC15
K DGPTPC16,DGPTPC17,DGPTPC18,DGPTPC19,DGPTPC20,DGPTPC21,DGPTPC22,DGPTPC23,DGPTPC24,DGPTPC25
K DGPTPDT,DGPTPDTS,DGPTPDY,DGPTPFL,DGPTPNT,DGPTPP,DGPTPRA2,DGPTPRA3,DGPTPSC,DGPTSTR,DGPTXX
K X,X1,X2,Y
Q
ERR ;
D WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
S ERROR=1
Q
DIALE ;dialysis type
I "12345678"'[DGPTPDY S DGPTERC=603 D ERR G:DGPTEDFL EXIT
I DGPTPNT=" "!(+DGPTPNT'>0) S DGPTERC=604 D ERR G:DGPTEDFL EXIT
Q
SET9 ;record layout before icd10 turned on
S DGPTPDT=$E(DGPTSTR,31,40) ;date/time of procedure
S DGPTPSC=$E(DGPTSTR,41,42) ;specialty
S DGPTPDY=$E(DGPTSTR,43) ;dialysis type
S DGPTPNT=$E(DGPTSTR,44,46) ;number of dialysis treatments
S DGPTPC1=$E(DGPTSTR,47,53) ;procedure codes 1-5
S DGPTPC2=$E(DGPTSTR,54,60)
S DGPTPC3=$E(DGPTSTR,61,67)
S DGPTPC4=$E(DGPTSTR,68,74)
S DGPTPC5=$E(DGPTSTR,75,81)
Q
SET10 ;record layout after icd10 turned on
S DGPTPDT=$E(DGPTSTR,31,40) ;date/time of procedure
S DGPTPSC=$E(DGPTSTR,41,42) ;specialty
S DGPTPDY=$E(DGPTSTR,43) ;dialysis type
S DGPTPNT=$E(DGPTSTR,44,46) ;number of dialysis treatments
S DGPTPC1=$E(DGPTSTR,47,53) ;procedure codes 1-25. 7 characters long (padded with a space when transmitting)
S DGPTPC2=$E(DGPTSTR,55,61)
S DGPTPC3=$E(DGPTSTR,63,69)
S DGPTPC4=$E(DGPTSTR,71,77)
S DGPTPC5=$E(DGPTSTR,79,85)
S DGPTPC6=$E(DGPTSTR,87,93)
S DGPTPC7=$E(DGPTSTR,95,101)
S DGPTPC8=$E(DGPTSTR,103,109)
S DGPTPC9=$E(DGPTSTR,111,117)
S DGPTPC10=$E(DGPTSTR,119,125)
S DGPTPC11=$E(DGPTSTR,127,133)
S DGPTPC12=$E(DGPTSTR,135,141)
S DGPTPC13=$E(DGPTSTR,143,149)
S DGPTPC14=$E(DGPTSTR,151,157)
S DGPTPC15=$E(DGPTSTR,159,165)
S DGPTPC16=$E(DGPTSTR,167,173)
S DGPTPC17=$E(DGPTSTR,175,181)
S DGPTPC18=$E(DGPTSTR,183,189)
S DGPTPC19=$E(DGPTSTR,191,197)
S DGPTPC20=$E(DGPTSTR,199,205)
S DGPTPC21=$E(DGPTSTR,207,213)
S DGPTPC22=$E(DGPTSTR,215,221)
S DGPTPC23=$E(DGPTSTR,223,229)
S DGPTPC24=$E(DGPTSTR,231,237)
S DGPTPC25=$E(DGPTSTR,239,245)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPT601 5172 printed Sep 02, 2024@19:36:38 Page 2
DGPT601 ;ALB/MTC,HIOFO/FT - Process 601 transmission ;3/23/2015 5:19pm
+1 ;;5.3;Registration;**64,164,729,850,884,1057**;Aug 13, 1993;Build 17
+2 ;
+3 ;no external references
+4 ;
+5 ;called from RTE^DGPTAE
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 ;parse data string and set variables
+1 if DGPTFMT=2
DO SET9
+2 if DGPTFMT=3
DO SET10
DATE ;date/time of procedure
+1 ; DGPTDDS - discharge DT
+2 ; DGPTDTS - admission DT
+3 ; DGPTPDTS - procedure DT
+4 ;
+5 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
+6 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")
+7 IF DGPTPDT'?1.2N1"-"3U1"-"4N1" "2N1":"2N
SET DGPTERC=601
DO ERR
if DGPTEDFL
GOTO EXIT
+8 ; DG*5.3*1057
IF $$FMDIFF^XLFDT(DGPTDDS,DGPTPDTS,2)<0
SET DGPTERC=640
DO ERR
if DGPTEDFL
GOTO EXIT
+9 ; DG*5.3*1057
IF $$FMDIFF^XLFDT(DGPTPDTS,$$FMADD^XLFDT(DGPTDTS,,-72),2)<0
SET DGPTERC=637
DO ERR
if DGPTEDFL
GOTO EXIT
+10 ;
TSPEC ;treating specialty
+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 ;dialysis
+1 NEW DGLOOP,DGPTPCODE
+2 IF DGPTPNT=" "!(+DGPTPNT'>0)
Begin DoDot:1
+3 FOR DGLOOP=1:1:$SELECT(DGPTFMT=3:25,1:5)
SET DGPTPCODE=@("DGPTPC"_DGLOOP)
Begin DoDot:2
+4 IF DGPTPCODE="3995 "!(DGPTPCODE="5498 ")!(DGPTPCODE="5092 ")
SET DGPTERC=604
DO ERR
+5 IF DGPTPCODE="5A1C00Z"!(DGPTPCODE="5A1C60Z")!(DGPTPCODE="5A1D00Z")!(DGPTPCODE="5A1D60Z")!(DGPTPCODE="3E1M39Z")
SET DGPTERC=604
DO ERR
End DoDot:2
End DoDot:1
if DGPTEDFL
GOTO EXIT
+6 ;
OPS ;operation codes
+1 SET DGPTERC=0
DO ^DGPT60PR
if DGPTEDFL
GOTO EXIT
+2 ;
OPDUP ;--check for duplicate procedure codes
+1 IF DGPTFMT=2
IF ((DGPTPDY=" ")&(DGPTPNT=" "))&($EXTRACT(DGPTSTR,47,81)?1.35" ")
SET DGPTERC="605Z"
DO ERR
GOTO EXIT
+2 ;I DGPTFMT=3 I ((DGPTPDY=" ")&(DGPTPNT=" "))&($E(DGPTSTR,47,245)?1.199" ") S DGPTERC="605Z" D ERR G EXIT
+3 ;commenting out duplicate check with dg*5.3*884 ft 11/5/14
+4 ;F DGPTL4=1:1:5 I $E(@("DGPTPC"_DGPTL4),1)'=" " S DGPTPAR(@("DGPTPC"_DGPTL4),DGPTL4)=""
+5 ;S DGPTPAR1=0 F DGPTL4=1:1:5 S DGPTPAR1=$O(DGPTPAR(DGPTPAR1)) Q:DGPTPAR1="" D G:DGPTEDFL EXIT
+6 ;. S DGPTPRA2=$O(DGPTPAR(DGPTPAR1,0))
+7 ;. I DGPTPRA2'="" S DGPTPRA3=$O(DGPTPAR(DGPTPAR1,DGPTPRA2))
+8 ;. I DGPTPRA3'="" S DGPTERC=657 D ERR
+9 KILL DGPTPAR
GOOD ;
+1 if '$DATA(ERROR)
WRITE "."
+2 ;
EXIT ;
+1 KILL DGPTERC,DGPTL3,DGPTL4,DGPTOP,DGPTOP1,DGPTP1,DGPTP2,DGPTPAR1
+2 KILL DGPTPC1,DGPTPC2,DGPTPC3,DGPTPC4,DGPTPC5,DGPTPC6,DGPTPC7,DGPTPC8,DGPTPC9,DGPTPC10,DGPTPC11,DGPTPC12,DGPTPC13,DGPTPC14,DGPTPC15
+3 KILL DGPTPC16,DGPTPC17,DGPTPC18,DGPTPC19,DGPTPC20,DGPTPC21,DGPTPC22,DGPTPC23,DGPTPC24,DGPTPC25
+4 KILL DGPTPDT,DGPTPDTS,DGPTPDY,DGPTPFL,DGPTPNT,DGPTPP,DGPTPRA2,DGPTPRA3,DGPTPSC,DGPTSTR,DGPTXX
+5 KILL X,X1,X2,Y
+6 QUIT
ERR ;
+1 DO WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
+2 SET ERROR=1
+3 QUIT
DIALE ;dialysis type
+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
SET9 ;record layout before icd10 turned on
+1 ;date/time of procedure
SET DGPTPDT=$EXTRACT(DGPTSTR,31,40)
+2 ;specialty
SET DGPTPSC=$EXTRACT(DGPTSTR,41,42)
+3 ;dialysis type
SET DGPTPDY=$EXTRACT(DGPTSTR,43)
+4 ;number of dialysis treatments
SET DGPTPNT=$EXTRACT(DGPTSTR,44,46)
+5 ;procedure codes 1-5
SET DGPTPC1=$EXTRACT(DGPTSTR,47,53)
+6 SET DGPTPC2=$EXTRACT(DGPTSTR,54,60)
+7 SET DGPTPC3=$EXTRACT(DGPTSTR,61,67)
+8 SET DGPTPC4=$EXTRACT(DGPTSTR,68,74)
+9 SET DGPTPC5=$EXTRACT(DGPTSTR,75,81)
+10 QUIT
SET10 ;record layout after icd10 turned on
+1 ;date/time of procedure
SET DGPTPDT=$EXTRACT(DGPTSTR,31,40)
+2 ;specialty
SET DGPTPSC=$EXTRACT(DGPTSTR,41,42)
+3 ;dialysis type
SET DGPTPDY=$EXTRACT(DGPTSTR,43)
+4 ;number of dialysis treatments
SET DGPTPNT=$EXTRACT(DGPTSTR,44,46)
+5 ;procedure codes 1-25. 7 characters long (padded with a space when transmitting)
SET DGPTPC1=$EXTRACT(DGPTSTR,47,53)
+6 SET DGPTPC2=$EXTRACT(DGPTSTR,55,61)
+7 SET DGPTPC3=$EXTRACT(DGPTSTR,63,69)
+8 SET DGPTPC4=$EXTRACT(DGPTSTR,71,77)
+9 SET DGPTPC5=$EXTRACT(DGPTSTR,79,85)
+10 SET DGPTPC6=$EXTRACT(DGPTSTR,87,93)
+11 SET DGPTPC7=$EXTRACT(DGPTSTR,95,101)
+12 SET DGPTPC8=$EXTRACT(DGPTSTR,103,109)
+13 SET DGPTPC9=$EXTRACT(DGPTSTR,111,117)
+14 SET DGPTPC10=$EXTRACT(DGPTSTR,119,125)
+15 SET DGPTPC11=$EXTRACT(DGPTSTR,127,133)
+16 SET DGPTPC12=$EXTRACT(DGPTSTR,135,141)
+17 SET DGPTPC13=$EXTRACT(DGPTSTR,143,149)
+18 SET DGPTPC14=$EXTRACT(DGPTSTR,151,157)
+19 SET DGPTPC15=$EXTRACT(DGPTSTR,159,165)
+20 SET DGPTPC16=$EXTRACT(DGPTSTR,167,173)
+21 SET DGPTPC17=$EXTRACT(DGPTSTR,175,181)
+22 SET DGPTPC18=$EXTRACT(DGPTSTR,183,189)
+23 SET DGPTPC19=$EXTRACT(DGPTSTR,191,197)
+24 SET DGPTPC20=$EXTRACT(DGPTSTR,199,205)
+25 SET DGPTPC21=$EXTRACT(DGPTSTR,207,213)
+26 SET DGPTPC22=$EXTRACT(DGPTSTR,215,221)
+27 SET DGPTPC23=$EXTRACT(DGPTSTR,223,229)
+28 SET DGPTPC24=$EXTRACT(DGPTSTR,231,237)
+29 SET DGPTPC25=$EXTRACT(DGPTSTR,239,245)
+30 QUIT
