- 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 Feb 19, 2025@00:19:32 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