DGPTRI3 ;ALB/JDS/MJK/BOK,ISF/GJW,HIOFO/FT - PTF TRANSMISSION ;4/23/15 8:59am
;;5.3;Registration;**850,884**;Aug 13, 1993;Build 31
;
; ICDEX APIs - #5747
;
535 ; -- setup 535 transactions
;$P(DGM,U,10) is MOVEMENT DATE
;$P(DGM,U,17) is TRANSMIT FLAG
;$P(DGM,U,7) is ICD3 ???
;$D(^DGPT(J,"M","AM",DGTD)) is x-ref on MOVEMENT DATE
F I=0:0 S I=$O(^DGPT(J,535,I)) Q:'I I $D(^(I,0)) S DGM=^(0),DGTD=+$P(DGM,U,10) I $P(DGM,U,17)'="n",'$P(DGM,U,7),'$D(^DGPT(J,"M","AM",DGTD)),DGTD'<T1,DGTD'>T2 D PHY
Q
;
PHY ; -- set up physical mvt
S Y=$S(T1:"C",1:"N")_"535"_DGHEAD,X=$P(DGTD,".")_" ",Y=Y_$E(X,4,5)_$E(X,6,7)_$E(X,2,3)_$E($P(DGTD,".",2)_"0000",1,4)
; physical cdr - $E(Y,41,46)
S Z=$P(DGM,U,16) D CDR^DGPTRI2
; physical specialty - $E(Y,47,48)
;replace specialty pointer (ien) with ptf code (alpha-numeric)
N DGARRX,DGARRY ;DG729
S DGARRX=$$TSDATA^DGACT(42.4,$P(DGM,U,2),.DGARRY)
S $P(DGM,U,2)=$G(DGARRY(7))
S L=2,X=DGM,Z=2 D ENTER0
; find corresponding PTF mvt
S X="",Z=+$O(^DGPT(J,"M","AM",DGTD-.0000001)),Z=$S(Z:+$O(^(Z,0)),1:1) I $D(^DGPT(J,"M",Z,0)) S X=^(0) ; use d/c mvt if 'Z
; specialty cdr - $E(Y,49,54)
S Z=$P(X,U,16) D CDR^DGPTRI2
; specialty - $E(Y,55,56)
;replace specialty pointer (ien) with ptf code (alpha-numeric)
N DGARRX,DGARRY ;DG729
S DGARRX=$$TSDATA^DGACT(42.4,$P(X,U,2),.DGARRY)
S $P(X,U,2)=$G(DGARRY(7))
S L=2,Z=2 D ENTER0
;
; convert pass, leave days >999 to 999
; 3 is LEAVE DAYS - $E(Y,57,59)
; 4 is PASS DAYS - $E(Y,60,62)
S X=DGM,L=3 F Z=3,4 S:$P(X,U,Z)>999 $P(X,U,Z)=999 D ENTER0
D SAVE
K DGM,X,Z,L Q
;
ENTER S Y=Y_$J($P(X,U,Z),L)
Q
;
ENTER0 S Y=Y_$S($P(X,U,Z)]"":$E("00000",$L($P(X,U,Z))+1,L)_$P(X,U,Z),1:$J($P(X,U,Z),L))
Q
;
SAVE ;
D SAVE^DGPTRI2
Q Q
;
VERCHK(REC) ; -- check version for all diagnosis and procedure codes
N I,J,X,Y,DGPTF,FLD,VER,%,ICD,DGICD,M,CODSYSD,CODSYSP,ERR1,ERR2,ERR3,ERR4,ERR5,ERR6
N EFFDATE,IMPDATE,DGPTDAT
Q:+$G(REC)<1
;
D EFFDATE^DGPTIC10(REC,"701")
S CODSYSD=+$$CS^ICDEX(80,"I",EFFDATE)
S CODSYSP=+$$CS^ICDEX(80.1,"I",EFFDATE)
;
S %=$S($D(^DGPT(REC,70)):^(70),1:"") I %'="" D
. S %=$$STR701^DGPTFUT(REC)
.F ICD=1:1:25 S DGICD=$P(%,U,ICD) I DGICD'="" D Q:$G(ERR1)=1
.. S X=$$CSI^ICDEX(80,DGICD)
.. I +X'=CODSYSD S ERR1=CODSYSD ;W !,%,!,ICD,!,X
.. Q
. Q
;
S M=0 F I=0:0 S I=$O(^DGPT(REC,"M",I)) Q:'I D
. S %=$$STR501^DGPTFUT(REC,I)
. F ICD=1:1:25 S DGICD=$P(%,U,ICD) I DGICD'="" D Q:$G(ERR2)=1
.. S X=$$CSI^ICDEX(80,DGICD)
.. I +X'=CODSYSD S ERR2=CODSYSD
.. Q
. Q
;
S I=0 F I=0:0 S I=$O(^DGPT(REC,"P",I)) Q:'I D
. S %=$$STR601^DGPTFUT(REC,I)
. F ICD=1:1:25 S DGICD=$P(%,U,ICD) I DGICD'="" D Q:$G(ERR3)=1
.. S X=$$CSI^ICDEX(80.1,DGICD)
.. I +X'=CODSYSP S ERR3=CODSYSP ;W !,%,!,ICD,!,X,!,CODSYSP
.. Q
. Q
;
S I=0 F I=0:0 S I=$O(^DGPT(REC,"S",I)) Q:'I D
. S %=$$STR401^DGPTFUT(REC,I)
. F ICD=1:1:25 S DGICD=$P(%,U,ICD) I DGICD'="" D Q:$G(ERR4)=1
.. S X=$$CSI^ICDEX(80.1,DGICD)
.. I +X'=CODSYSP S ERR4=CODSYSP
.. Q
. Q
;
S %=$S($D(^DGPT(REC,"401P")):^("401P"),1:"") I %'="" D
. S %=U_$P(%,U,1,5)
.F ICD=2:1:6 S DGICD=$P(%,U,ICD) I DGICD'="" D Q:$G(ERR5)=1
.. S X=$$CSI^ICDEX(80,DGICD)
.. I +X'=CODSYSD S ERR5=CODSYSD ;W !,%,!,ICD,!,X
.. Q
. Q
;
D CPTDATA
;
I $G(ERR4) S DGERR=$G(DGERR)+1 W !,"401 ",$S(ERR4=2:"ICD-9",1:"ICD-10")," Code Expected, ",$S(ERR4=2:"ICD-10",1:"ICD-9")," Code found."
I $G(ERR2) S DGERR=$G(DGERR)+1 W !,"501 ",$S(ERR2=1:"ICD-9",1:"ICD-10")," Code Expected, ",$S(ERR2=1:"ICD-10",1:"ICD-9")," Code found."
I $G(ERR3) S DGERR=$G(DGERR)+1 W !,"601 ",$S(ERR3=2:"ICD-9",1:"ICD-10")," Code Expected, ",$S(ERR3=2:"ICD-10",1:"ICD-9")," Code found."
I $G(ERR5) S DGERR=$G(DGERR)+1 W !,"601 ",$S(ERR5=1:"ICD-9",1:"ICD-10")," Code Expected, ",$S(ERR5=1:"ICD-10",1:"ICD-9")," Code found."
I $G(ERR1) S DGERR=$G(DGERR)+1 W !,"701 ",$S(ERR1=1:"ICD-9",1:"ICD-10")," Code Expected, ",$S(ERR1=1:"ICD-10",1:"ICD-9")," Code found."
I $G(ERR6) S DGERR=$G(DGERR)+1 W !,"801 ",$S(ERR6=1:"ICD-9",1:"ICD-10")," Code Expected, ",$S(ERR6=1:"ICD-10",1:"ICD-9")," Code found."
;
Q
;
CPTDATA ; -- get 801 movement Diagnosis Data in DG801(i,j,"DATA")
; 801 movement uses CPT Record date instead of 701 type dates
N H,I,I2,N,IEN,K,K1,L,DGCPTDT,DGCPTSYS
S (H,I,N)=0
F I2=1:1 S H=$O(^DGPT(PTF,"C","B",H)) Q:H'>0 D
. F S I=$O(^DGPT(PTF,"C","B",H,I)) Q:I'>0 D
.. S DG801(I2)=^DGPT(PTF,"C",I,0),DGCPTDT=$P(DG801(I2),U,1),DGCPTSYS=+$$CS^ICDEX(80,"I",DGCPTDT)
.. S (K,K1)=0,F=1 ;D
.. F S K=$O(^DGCPT(46,"C",PTF,K)) Q:K'>0 I +DG801(I2)=+$G(^DGCPT(46,K,1)),'$G(^DGCPT(46,K,9)) D
... S K1=K1+1
... S DG801(I2,K1,"DATA")=$P(^DGCPT(46,K,0),U,4,7)_U_$P(^DGCPT(46,K,0),U,15,18)
... F L=1:1:8 S DGICD=$P(DG801(I2,K1,"DATA"),U,L) I DGICD D Q:$G(ERR6)
.... S X=$$CSI^ICDEX(80,DGICD)
.... I +X'=DGCPTSYS S ERR6=DGCPTSYS
.... Q
... S F=0
... Q
..I F K DG801(I2) S I2=I2-1
.. Q
. Q
K F,I,K,K1,N
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTRI3 5045 printed Apr 09, 2024@21:40:48 Page 2
DGPTRI3 ;ALB/JDS/MJK/BOK,ISF/GJW,HIOFO/FT - PTF TRANSMISSION ;4/23/15 8:59am
+1 ;;5.3;Registration;**850,884**;Aug 13, 1993;Build 31
+2 ;
+3 ; ICDEX APIs - #5747
+4 ;
535 ; -- setup 535 transactions
+1 ;$P(DGM,U,10) is MOVEMENT DATE
+2 ;$P(DGM,U,17) is TRANSMIT FLAG
+3 ;$P(DGM,U,7) is ICD3 ???
+4 ;$D(^DGPT(J,"M","AM",DGTD)) is x-ref on MOVEMENT DATE
+5 FOR I=0:0
SET I=$ORDER(^DGPT(J,535,I))
if 'I
QUIT
IF $DATA(^(I,0))
SET DGM=^(0)
SET DGTD=+$PIECE(DGM,U,10)
IF $PIECE(DGM,U,17)'="n"
IF '$PIECE(DGM,U,7)
IF '$DATA(^DGPT(J,"M","AM",DGTD))
IF DGTD'<T1
IF DGTD'>T2
DO PHY
+6 QUIT
+7 ;
PHY ; -- set up physical mvt
+1 SET Y=$SELECT(T1:"C",1:"N")_"535"_DGHEAD
SET X=$PIECE(DGTD,".")_" "
SET Y=Y_$EXTRACT(X,4,5)_$EXTRACT(X,6,7)_$EXTRACT(X,2,3)_$EXTRACT($PIECE(DGTD,".",2)_"0000",1,4)
+2 ; physical cdr - $E(Y,41,46)
+3 SET Z=$PIECE(DGM,U,16)
DO CDR^DGPTRI2
+4 ; physical specialty - $E(Y,47,48)
+5 ;replace specialty pointer (ien) with ptf code (alpha-numeric)
+6 ;DG729
NEW DGARRX,DGARRY
+7 SET DGARRX=$$TSDATA^DGACT(42.4,$PIECE(DGM,U,2),.DGARRY)
+8 SET $PIECE(DGM,U,2)=$GET(DGARRY(7))
+9 SET L=2
SET X=DGM
SET Z=2
DO ENTER0
+10 ; find corresponding PTF mvt
+11 ; use d/c mvt if 'Z
SET X=""
SET Z=+$ORDER(^DGPT(J,"M","AM",DGTD-.0000001))
SET Z=$SELECT(Z:+$ORDER(^(Z,0)),1:1)
IF $DATA(^DGPT(J,"M",Z,0))
SET X=^(0)
+12 ; specialty cdr - $E(Y,49,54)
+13 SET Z=$PIECE(X,U,16)
DO CDR^DGPTRI2
+14 ; specialty - $E(Y,55,56)
+15 ;replace specialty pointer (ien) with ptf code (alpha-numeric)
+16 ;DG729
NEW DGARRX,DGARRY
+17 SET DGARRX=$$TSDATA^DGACT(42.4,$PIECE(X,U,2),.DGARRY)
+18 SET $PIECE(X,U,2)=$GET(DGARRY(7))
+19 SET L=2
SET Z=2
DO ENTER0
+20 ;
+21 ; convert pass, leave days >999 to 999
+22 ; 3 is LEAVE DAYS - $E(Y,57,59)
+23 ; 4 is PASS DAYS - $E(Y,60,62)
+24 SET X=DGM
SET L=3
FOR Z=3,4
if $PIECE(X,U,Z)>999
SET $PIECE(X,U,Z)=999
DO ENTER0
+25 DO SAVE
+26 KILL DGM,X,Z,L
QUIT
+27 ;
ENTER SET Y=Y_$JUSTIFY($PIECE(X,U,Z),L)
+1 QUIT
+2 ;
ENTER0 SET Y=Y_$SELECT($PIECE(X,U,Z)]"":$EXTRACT("00000",$LENGTH($PIECE(X,U,Z))+1,L)_$PIECE(X,U,Z),1:$JUSTIFY($PIECE(X,U,Z),L))
+1 QUIT
+2 ;
SAVE ;
+1 DO SAVE^DGPTRI2
Q QUIT
+1 ;
VERCHK(REC) ; -- check version for all diagnosis and procedure codes
+1 NEW I,J,X,Y,DGPTF,FLD,VER,%,ICD,DGICD,M,CODSYSD,CODSYSP,ERR1,ERR2,ERR3,ERR4,ERR5,ERR6
+2 NEW EFFDATE,IMPDATE,DGPTDAT
+3 if +$GET(REC)<1
QUIT
+4 ;
+5 DO EFFDATE^DGPTIC10(REC,"701")
+6 SET CODSYSD=+$$CS^ICDEX(80,"I",EFFDATE)
+7 SET CODSYSP=+$$CS^ICDEX(80.1,"I",EFFDATE)
+8 ;
+9 SET %=$SELECT($DATA(^DGPT(REC,70)):^(70),1:"")
IF %'=""
Begin DoDot:1
+10 SET %=$$STR701^DGPTFUT(REC)
+11 FOR ICD=1:1:25
SET DGICD=$PIECE(%,U,ICD)
IF DGICD'=""
Begin DoDot:2
+12 SET X=$$CSI^ICDEX(80,DGICD)
+13 ;W !,%,!,ICD,!,X
IF +X'=CODSYSD
SET ERR1=CODSYSD
+14 QUIT
End DoDot:2
if $GET(ERR1)=1
QUIT
+15 QUIT
End DoDot:1
+16 ;
+17 SET M=0
FOR I=0:0
SET I=$ORDER(^DGPT(REC,"M",I))
if 'I
QUIT
Begin DoDot:1
+18 SET %=$$STR501^DGPTFUT(REC,I)
+19 FOR ICD=1:1:25
SET DGICD=$PIECE(%,U,ICD)
IF DGICD'=""
Begin DoDot:2
+20 SET X=$$CSI^ICDEX(80,DGICD)
+21 IF +X'=CODSYSD
SET ERR2=CODSYSD
+22 QUIT
End DoDot:2
if $GET(ERR2)=1
QUIT
+23 QUIT
End DoDot:1
+24 ;
+25 SET I=0
FOR I=0:0
SET I=$ORDER(^DGPT(REC,"P",I))
if 'I
QUIT
Begin DoDot:1
+26 SET %=$$STR601^DGPTFUT(REC,I)
+27 FOR ICD=1:1:25
SET DGICD=$PIECE(%,U,ICD)
IF DGICD'=""
Begin DoDot:2
+28 SET X=$$CSI^ICDEX(80.1,DGICD)
+29 ;W !,%,!,ICD,!,X,!,CODSYSP
IF +X'=CODSYSP
SET ERR3=CODSYSP
+30 QUIT
End DoDot:2
if $GET(ERR3)=1
QUIT
+31 QUIT
End DoDot:1
+32 ;
+33 SET I=0
FOR I=0:0
SET I=$ORDER(^DGPT(REC,"S",I))
if 'I
QUIT
Begin DoDot:1
+34 SET %=$$STR401^DGPTFUT(REC,I)
+35 FOR ICD=1:1:25
SET DGICD=$PIECE(%,U,ICD)
IF DGICD'=""
Begin DoDot:2
+36 SET X=$$CSI^ICDEX(80.1,DGICD)
+37 IF +X'=CODSYSP
SET ERR4=CODSYSP
+38 QUIT
End DoDot:2
if $GET(ERR4)=1
QUIT
+39 QUIT
End DoDot:1
+40 ;
+41 SET %=$SELECT($DATA(^DGPT(REC,"401P")):^("401P"),1:"")
IF %'=""
Begin DoDot:1
+42 SET %=U_$PIECE(%,U,1,5)
+43 FOR ICD=2:1:6
SET DGICD=$PIECE(%,U,ICD)
IF DGICD'=""
Begin DoDot:2
+44 SET X=$$CSI^ICDEX(80,DGICD)
+45 ;W !,%,!,ICD,!,X
IF +X'=CODSYSD
SET ERR5=CODSYSD
+46 QUIT
End DoDot:2
if $GET(ERR5)=1
QUIT
+47 QUIT
End DoDot:1
+48 ;
+49 DO CPTDATA
+50 ;
+51 IF $GET(ERR4)
SET DGERR=$GET(DGERR)+1
WRITE !,"401 ",$SELECT(ERR4=2:"ICD-9",1:"ICD-10")," Code Expected, ",$SELECT(ERR4=2:"ICD-10",1:"ICD-9")," Code found."
+52 IF $GET(ERR2)
SET DGERR=$GET(DGERR)+1
WRITE !,"501 ",$SELECT(ERR2=1:"ICD-9",1:"ICD-10")," Code Expected, ",$SELECT(ERR2=1:"ICD-10",1:"ICD-9")," Code found."
+53 IF $GET(ERR3)
SET DGERR=$GET(DGERR)+1
WRITE !,"601 ",$SELECT(ERR3=2:"ICD-9",1:"ICD-10")," Code Expected, ",$SELECT(ERR3=2:"ICD-10",1:"ICD-9")," Code found."
+54 IF $GET(ERR5)
SET DGERR=$GET(DGERR)+1
WRITE !,"601 ",$SELECT(ERR5=1:"ICD-9",1:"ICD-10")," Code Expected, ",$SELECT(ERR5=1:"ICD-10",1:"ICD-9")," Code found."
+55 IF $GET(ERR1)
SET DGERR=$GET(DGERR)+1
WRITE !,"701 ",$SELECT(ERR1=1:"ICD-9",1:"ICD-10")," Code Expected, ",$SELECT(ERR1=1:"ICD-10",1:"ICD-9")," Code found."
+56 IF $GET(ERR6)
SET DGERR=$GET(DGERR)+1
WRITE !,"801 ",$SELECT(ERR6=1:"ICD-9",1:"ICD-10")," Code Expected, ",$SELECT(ERR6=1:"ICD-10",1:"ICD-9")," Code found."
+57 ;
+58 QUIT
+59 ;
CPTDATA ; -- get 801 movement Diagnosis Data in DG801(i,j,"DATA")
+1 ; 801 movement uses CPT Record date instead of 701 type dates
+2 NEW H,I,I2,N,IEN,K,K1,L,DGCPTDT,DGCPTSYS
+3 SET (H,I,N)=0
+4 FOR I2=1:1
SET H=$ORDER(^DGPT(PTF,"C","B",H))
if H'>0
QUIT
Begin DoDot:1
+5 FOR
SET I=$ORDER(^DGPT(PTF,"C","B",H,I))
if I'>0
QUIT
Begin DoDot:2
+6 SET DG801(I2)=^DGPT(PTF,"C",I,0)
SET DGCPTDT=$PIECE(DG801(I2),U,1)
SET DGCPTSYS=+$$CS^ICDEX(80,"I",DGCPTDT)
+7 ;D
SET (K,K1)=0
SET F=1
+8 FOR
SET K=$ORDER(^DGCPT(46,"C",PTF,K))
if K'>0
QUIT
IF +DG801(I2)=+$GET(^DGCPT(46,K,1))
IF '$GET(^DGCPT(46,K,9))
Begin DoDot:3
+9 SET K1=K1+1
+10 SET DG801(I2,K1,"DATA")=$PIECE(^DGCPT(46,K,0),U,4,7)_U_$PIECE(^DGCPT(46,K,0),U,15,18)
+11 FOR L=1:1:8
SET DGICD=$PIECE(DG801(I2,K1,"DATA"),U,L)
IF DGICD
Begin DoDot:4
+12 SET X=$$CSI^ICDEX(80,DGICD)
+13 IF +X'=DGCPTSYS
SET ERR6=DGCPTSYS
+14 QUIT
End DoDot:4
if $GET(ERR6)
QUIT
+15 SET F=0
+16 QUIT
End DoDot:3
+17 IF F
KILL DG801(I2)
SET I2=I2-1
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 KILL F,I,K,K1,N
+21 QUIT
