DGPTRI2 ;ALB/JDS/MJK/MTC/ADL/TJ/BOK,ISF/GJW,HIOFO/FT - PTF TRANSMISSION ;4/20/15 9:18am
;;5.3;Registration;**850,884**;Aug 13, 1993;Build 31
;;ADL;Update for CSV Project;;Mar 27,2003
;
; ^XMB(3.9) - #10113
; ICDXCODE APIs - #5699
; XLFSTR APIs - #10104
;
501 ; -- setup 501 transactions
; DG*636
N DGPTMVDT,DGMPOA,DGEC,DGHNC,DGIR,DGM2,DGMST,DGPTMCNT,DGSC
K DGCMVT I T2'=9999999 S DGCMVT=$O(^DGPT(J,"M","AM",+$P(T2,".")_".2359")),DGCMVT=$S('DGCMVT:1,$O(^(DGCMVT,0)):$O(^(0)),1:1)
;$P(DGM,U,10) - MOVEMENT DATE
;$P(DGM,U,18) - TREATED FOR SC CONDITION
;$P(DGM,U,26) - TREATED FOR AO CONDITION
;$P(DGM,U,27) - TREATED FOR IR CONDITION
;$P(DGM,U,28) - EXPOSED TO SW ASIA CONDITIONS
;$P(DGM,U,29) - TREATMENT FOR MST
;$P(DGM,U,30) - TREATED FOR HEAD/NECK CANCER
F I=0:0 S I=$O(^DGPT(J,"M",I)) G 535:I'>0 I $D(^DGPT(J,"M",I,0)) S DGM=^DGPT(J,"M",I,0),DGM2=$G(^DGPT(J,"M",I,81)),DGMPOA=$G(^DGPT(J,"M",I,82)) D
. S DGPTMCNT=$G(DGPTMCNT)+1,DGSC=$P(DGM,U,18),DGAO=$P(DGM,U,26),DGIR=$P(DGM,U,27)
. S DGEC=$P(DGM,U,28),DGMST=$P(DGM,U,29),DGHNC=$P(DGM,U,30),DGTD=$P(DGM,U,10),DGPTMVDT=$P(DGM,U,10)
. S:$D(DGCMVT) DGTD=$S(I=DGCMVT:$P(T2,".")_".2359",1:DGTD)
. I $P(DGM,U,17)'="n",DGTD,DGTD'<T1,DGTD'>T2 D MOV
Q
MOV ; build movement record
S DGCDR=$P(DGM,U,16)
S DGM=$P(DGM,U,1,9)_U_$P(DGM,U,11,15),L=1
;
S Y=$S(T1:"C",1:"N")_"501"_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)
;SPECIALTY CDR CODE - $E(Y,41,46)
S Z=DGCDR D CDR
;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))
;SPECIALTY CODE - $E(Y,47,48)
S L=2,X=DGM,Z=2 D ENTER0
; convert pass, leave days >999 to 999
;3 is LEAVE DAYS - $E(Y,49,51)
;4 is PASS DAYS - $E(Y,52,54)
S L=3 F Z=3,4 S:$P(X,U,Z)>999 $P(X,U,Z)=999 D ENTER0
;SPINAL CORD INJURY INDICATOR - $E(Y,55)
S L=1,X=DG57,Z=4 D ENTER S:I=1 DG502=Y
;DIAGNOSTIC CODES and POAs 1 thru 25 - $E(Y,56,255)
N EFFDATE,IMPDATE
D EFFDATE^DGPTIC10(J)
N DG501DX,DG501POA,DGLOOP,DGSTRING,DG501CODES,DGPTTMP
D PTFICD^DGPTFUT(501,J,I,.DG501CODES) ;get 501 values
S DGLOOP=0,DGSTRING=""
F S DGLOOP=$O(DG501CODES(DGLOOP)) Q:DGLOOP="" D
.S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",$P(DG501CODES(DGLOOP),U,1),EFFDATE,"I") ;get dx code info
.I +DGPTTMP>0&($P(DGPTTMP,U,10)) D ;check ien and status
..S DG501DX=$P(DG501CODES(DGLOOP),U,3) ;external value
..S DG501DX=$$FMTICD^DGPTRNU(DG501DX) ;remove decimal point
..S DG501DX=$$LJ^XLFSTR(DG501DX,7," ") ;left justify & add spaces to the right to reach 7 characters
..S DG501POA=$P(DG501CODES(DGLOOP),U,2) ;get poa code
..S DG501POA=$S(DG501POA'="":DG501POA,1:" ") ;use space, if no POA code
..S DGSTRING=DGSTRING_DG501DX_DG501POA ;build string of dx and poa values
S $E(Y,56,255)=DGSTRING_$$REPEAT^XLFSTR(" ",200-$L(DGSTRING))
;attending physician ssn - $E(Y,256,264)
S X=$$GET1^DIQ(45,J_",",79.2),$E(Y,256,264)=$E(X_" ",1,9)
S X=""
I 'T1 S Z=$S(I=1:+$O(^DGPT(J,535,"ADC",0)),1:+$O(^DGPT(J,535,"AM",DGTD-.0000001))) I $D(^DGPT(J,535,+$O(^(Z,0)),0)) S X=^(0)
I T1 S Z=+$O(^DGPT(J,535,"AM",DGTD-.0000001)) S:'Z Z=+$O(^DGPT(J,535,"ADC",0)) I $D(^DGPT(J,535,+$O(^(Z,0)),0)) S X=^(0)
;PHYSICAL LOCATION CDR CODE - $E(Y,265,270)
S Z=$P(X,U,16) D CDR
;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))
;PHYSICAL LOCATION CODE - $E(Y,271,272)
S L=2,Z=2 D ENTER0
;BED STATUS (DISCHARGE MOVEMENT ONLY) - $E(Y,273)
I T1 S Y=Y_$S(I=1:$E($P(DG70,U,14)_" "),$P(+DGTD,".")=$P(T2,"."):5,1:1)
I 'T1 S Y=Y_$S(I=1:$E($P(DG70,U,14)_" "),1:" ")
;[NOT ACTIVATED] - $E(Y,274,284)
;[RESERVED] - $E(Y,285,301)
;[NOT IN USE] - $E(Y,302,384)
D SAVE
Q
535 ; -- do 535's
D 535^DGPTRI3
;
PROC ; -- setup 601 transactions
K ^UTILITY($J,"PROC") S I=0
601 S I=$O(^DGPT(J,"P",I)) G 701:I'>0 S (X,DGPROC)=^(I,0) G 601:'DGPROC
G 601:DGPROC<T1!(DGPROC>T2) S DGPROCD=+^DGPT(J,"P",I,0),^UTILITY($J,"PROC",DGPROCD)=$S($D(^UTILITY($J,"PROC",DGPROCD)):^(DGPROCD),1:0)+1
I ^UTILITY($J,"PROC",DGPROCD)>1 W !,"More than one procedure record on same date/time" S DGERR=1 Q
S Y=$S('T1:"N",1:"C")_"601"_DGHEAD_$E(DGPROCD,4,7)_$E(DGPROCD,2,3)_$E($P(+X,".",2)_"0000",1,4)
;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))
;SPECIALTY - $E(Y,41,42)
S L=2,Z=2 D ENTER0
;DIALYSIS TYPE - $E(Y,43)
S L=1,Z=3 S $P(X,U,Z)="" D ENTER ;null dialysis type. DG729
;NUMBER OF DIALYSIS TREATMENTS - $E(Y44,46)
S L=3,Z=4 D ENTER0
N EFFDATE,IMPDATE,DGPTDAT D EFFDATE^DGPTIC10(J)
;procedure codes 1 thru 25 - $E(Y,47,246)
N DG601CODES,DGLOOP,DGPCODE,DGPROCNODE,DGSTRING,DGPTTMP
D PTFICD^DGPTFUT(601,J,I,.DG601CODES) ;get 601 values
S DGLOOP=0,DGSTRING=""
F S DGLOOP=$O(DG601CODES(DGLOOP)) Q:DGLOOP="" D ;returns codes used, no null fields
.S DGPCODE=$P(DG601CODES(DGLOOP),U,3) ;external value
.S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",$P(DG601CODES(DGLOOP),U,1),EFFDATE,"I") ;check data
.Q:+DGPTTMP'>0 ;don't use if bad
.S DGSTRING=DGSTRING_DGPCODE_" "
S $E(Y,47,246)=DGSTRING_$$REPEAT^XLFSTR(" ",200-$L(DGSTRING))
;[NOT ACTIVATED] - $E(Y,247,255)
;[RESERVED] - $E(Y,256,290)
;[NOT ALLOCATED] - $E(Y,291,384)
D SAVE G 601
Q
;
701 ; -- setup 701 transaction
D 701^DGPTRI4 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 ;save segment to MailMan message and ^TMP("AEDIT",$J), if data is valid
N DGY1,DGY2
S (DGY1,DGY2)=""
D START^DGPTRI1 ;validate data in segment
I DGERR'>0 S DGACNT=DGACNT+1,^TMP("AEDIT",$J,$E(Y,1,4),DGACNT)=Y ;^TMP("AEDIT",$J) used by DGPTAE* for more data validation
;AITC wants segment length of 384 characters.
;Break the segment at 240, if it does not affect a data field. Otherwise break line before data field.
I 'DGERR D
.D FILL
.I $E(Y,2,4)=101 S DGY1=$E(Y,1,240),DGY2=$E(Y,241,384)
.I $E(Y,2,4)=401 S DGY1=$E(Y,1,238),DGY2=$E(Y,239,384)
.I $E(Y,2,4)=501 S DGY1=$E(Y,1,239),DGY2=$E(Y,240,384)
.I $E(Y,2,4)=535 S DGY1=$E(Y,1,240),DGY2=$E(Y,241,384)
.I $E(Y,2,4)=601 S DGY1=$E(Y,1,238),DGY2=$E(Y,239,384)
.I $E(Y,2,4)=701 S DGY1=$E(Y,1,240),DGY2=$E(Y,241,384)
.I $E(Y,2,4)=702 S DGY1=$E(Y,1,240),DGY2=$E(Y,241,384)
.Q:DGY1=""!(DGY2="")
.S ^XMB(3.9,DGXMZ,2,DGCNT,0)=DGY1,DGCNT=DGCNT+1
.S ^XMB(3.9,DGXMZ,2,DGCNT,0)=DGY2,DGCNT=DGCNT+1
Q Q
;
FILL ;fill out segment with spaces
F K=$L(Y):1 Q:$L(Y)>383 S Y=Y_" "
S $E(Y,383)=1 ;383rd character=1 to indicate ICD10 record. DGPTR2 sets 383rd character=9 to indicate ICD9 record.
Q
;
CDR S Y=Y_$E($P(Z,".")_"0000",1,4)_$E($P(Z,".",2)_"00",1,2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTRI2 6944 printed Dec 13, 2024@02:53:29 Page 2
DGPTRI2 ;ALB/JDS/MJK/MTC/ADL/TJ/BOK,ISF/GJW,HIOFO/FT - PTF TRANSMISSION ;4/20/15 9:18am
+1 ;;5.3;Registration;**850,884**;Aug 13, 1993;Build 31
+2 ;;ADL;Update for CSV Project;;Mar 27,2003
+3 ;
+4 ; ^XMB(3.9) - #10113
+5 ; ICDXCODE APIs - #5699
+6 ; XLFSTR APIs - #10104
+7 ;
501 ; -- setup 501 transactions
+1 ; DG*636
+2 NEW DGPTMVDT,DGMPOA,DGEC,DGHNC,DGIR,DGM2,DGMST,DGPTMCNT,DGSC
+3 KILL DGCMVT
IF T2'=9999999
SET DGCMVT=$ORDER(^DGPT(J,"M","AM",+$PIECE(T2,".")_".2359"))
SET DGCMVT=$SELECT('DGCMVT:1,$ORDER(^(DGCMVT,0)):$ORDER(^(0)),1:1)
+4 ;$P(DGM,U,10) - MOVEMENT DATE
+5 ;$P(DGM,U,18) - TREATED FOR SC CONDITION
+6 ;$P(DGM,U,26) - TREATED FOR AO CONDITION
+7 ;$P(DGM,U,27) - TREATED FOR IR CONDITION
+8 ;$P(DGM,U,28) - EXPOSED TO SW ASIA CONDITIONS
+9 ;$P(DGM,U,29) - TREATMENT FOR MST
+10 ;$P(DGM,U,30) - TREATED FOR HEAD/NECK CANCER
+11 FOR I=0:0
SET I=$ORDER(^DGPT(J,"M",I))
if I'>0
GOTO 535
IF $DATA(^DGPT(J,"M",I,0))
SET DGM=^DGPT(J,"M",I,0)
SET DGM2=$GET(^DGPT(J,"M",I,81))
SET DGMPOA=$GET(^DGPT(J,"M",I,82))
Begin DoDot:1
+12 SET DGPTMCNT=$GET(DGPTMCNT)+1
SET DGSC=$PIECE(DGM,U,18)
SET DGAO=$PIECE(DGM,U,26)
SET DGIR=$PIECE(DGM,U,27)
+13 SET DGEC=$PIECE(DGM,U,28)
SET DGMST=$PIECE(DGM,U,29)
SET DGHNC=$PIECE(DGM,U,30)
SET DGTD=$PIECE(DGM,U,10)
SET DGPTMVDT=$PIECE(DGM,U,10)
+14 if $DATA(DGCMVT)
SET DGTD=$SELECT(I=DGCMVT:$PIECE(T2,".")_".2359",1:DGTD)
+15 IF $PIECE(DGM,U,17)'="n"
IF DGTD
IF DGTD'<T1
IF DGTD'>T2
DO MOV
End DoDot:1
+16 QUIT
MOV ; build movement record
+1 SET DGCDR=$PIECE(DGM,U,16)
+2 SET DGM=$PIECE(DGM,U,1,9)_U_$PIECE(DGM,U,11,15)
SET L=1
+3 ;
+4 SET Y=$SELECT(T1:"C",1:"N")_"501"_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)
+5 ;SPECIALTY CDR CODE - $E(Y,41,46)
+6 SET Z=DGCDR
DO CDR
+7 ;replace specialty pointer (ien) with ptf code (alpha-numeric)
+8 ;DG729
NEW DGARRX,DGARRY
+9 SET DGARRX=$$TSDATA^DGACT(42.4,$PIECE(DGM,U,2),.DGARRY)
+10 SET $PIECE(DGM,U,2)=$GET(DGARRY(7))
+11 ;SPECIALTY CODE - $E(Y,47,48)
+12 SET L=2
SET X=DGM
SET Z=2
DO ENTER0
+13 ; convert pass, leave days >999 to 999
+14 ;3 is LEAVE DAYS - $E(Y,49,51)
+15 ;4 is PASS DAYS - $E(Y,52,54)
+16 SET L=3
FOR Z=3,4
if $PIECE(X,U,Z)>999
SET $PIECE(X,U,Z)=999
DO ENTER0
+17 ;SPINAL CORD INJURY INDICATOR - $E(Y,55)
+18 SET L=1
SET X=DG57
SET Z=4
DO ENTER
if I=1
SET DG502=Y
+19 ;DIAGNOSTIC CODES and POAs 1 thru 25 - $E(Y,56,255)
+20 NEW EFFDATE,IMPDATE
+21 DO EFFDATE^DGPTIC10(J)
+22 NEW DG501DX,DG501POA,DGLOOP,DGSTRING,DG501CODES,DGPTTMP
+23 ;get 501 values
DO PTFICD^DGPTFUT(501,J,I,.DG501CODES)
+24 SET DGLOOP=0
SET DGSTRING=""
+25 FOR
SET DGLOOP=$ORDER(DG501CODES(DGLOOP))
if DGLOOP=""
QUIT
Begin DoDot:1
+26 ;get dx code info
SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",$PIECE(DG501CODES(DGLOOP),U,1),EFFDATE,"I")
+27 ;check ien and status
IF +DGPTTMP>0&($PIECE(DGPTTMP,U,10))
Begin DoDot:2
+28 ;external value
SET DG501DX=$PIECE(DG501CODES(DGLOOP),U,3)
+29 ;remove decimal point
SET DG501DX=$$FMTICD^DGPTRNU(DG501DX)
+30 ;left justify & add spaces to the right to reach 7 characters
SET DG501DX=$$LJ^XLFSTR(DG501DX,7," ")
+31 ;get poa code
SET DG501POA=$PIECE(DG501CODES(DGLOOP),U,2)
+32 ;use space, if no POA code
SET DG501POA=$SELECT(DG501POA'="":DG501POA,1:" ")
+33 ;build string of dx and poa values
SET DGSTRING=DGSTRING_DG501DX_DG501POA
End DoDot:2
End DoDot:1
+34 SET $EXTRACT(Y,56,255)=DGSTRING_$$REPEAT^XLFSTR(" ",200-$LENGTH(DGSTRING))
+35 ;attending physician ssn - $E(Y,256,264)
+36 SET X=$$GET1^DIQ(45,J_",",79.2)
SET $EXTRACT(Y,256,264)=$EXTRACT(X_" ",1,9)
+37 SET X=""
+38 IF 'T1
SET Z=$SELECT(I=1:+$ORDER(^DGPT(J,535,"ADC",0)),1:+$ORDER(^DGPT(J,535,"AM",DGTD-.0000001)))
IF $DATA(^DGPT(J,535,+$ORDER(^(Z,0)),0))
SET X=^(0)
+39 IF T1
SET Z=+$ORDER(^DGPT(J,535,"AM",DGTD-.0000001))
if 'Z
SET Z=+$ORDER(^DGPT(J,535,"ADC",0))
IF $DATA(^DGPT(J,535,+$ORDER(^(Z,0)),0))
SET X=^(0)
+40 ;PHYSICAL LOCATION CDR CODE - $E(Y,265,270)
+41 SET Z=$PIECE(X,U,16)
DO CDR
+42 ;replace specialty pointer (ien) with ptf code (alpha-numeric)
+43 ;DG729
NEW DGARRX,DGARRY
+44 SET DGARRX=$$TSDATA^DGACT(42.4,$PIECE(X,U,2),.DGARRY)
+45 SET $PIECE(X,U,2)=$GET(DGARRY(7))
+46 ;PHYSICAL LOCATION CODE - $E(Y,271,272)
+47 SET L=2
SET Z=2
DO ENTER0
+48 ;BED STATUS (DISCHARGE MOVEMENT ONLY) - $E(Y,273)
+49 IF T1
SET Y=Y_$SELECT(I=1:$EXTRACT($PIECE(DG70,U,14)_" "),$PIECE(+DGTD,".")=$PIECE(T2,"."):5,1:1)
+50 IF 'T1
SET Y=Y_$SELECT(I=1:$EXTRACT($PIECE(DG70,U,14)_" "),1:" ")
+51 ;[NOT ACTIVATED] - $E(Y,274,284)
+52 ;[RESERVED] - $E(Y,285,301)
+53 ;[NOT IN USE] - $E(Y,302,384)
+54 DO SAVE
+55 QUIT
535 ; -- do 535's
+1 DO 535^DGPTRI3
+2 ;
PROC ; -- setup 601 transactions
+1 KILL ^UTILITY($JOB,"PROC")
SET I=0
601 SET I=$ORDER(^DGPT(J,"P",I))
if I'>0
GOTO 701
SET (X,DGPROC)=^(I,0)
if 'DGPROC
GOTO 601
+1 if DGPROC<T1!(DGPROC>T2)
GOTO 601
SET DGPROCD=+^DGPT(J,"P",I,0)
SET ^UTILITY($JOB,"PROC",DGPROCD)=$SELECT($DATA(^UTILITY($JOB,"PROC",DGPROCD)):^(DGPROCD),1:0)+1
+2 IF ^UTILITY($JOB,"PROC",DGPROCD)>1
WRITE !,"More than one procedure record on same date/time"
SET DGERR=1
QUIT
+3 SET Y=$SELECT('T1:"N",1:"C")_"601"_DGHEAD_$EXTRACT(DGPROCD,4,7)_$EXTRACT(DGPROCD,2,3)_$EXTRACT($PIECE(+X,".",2)_"0000",1,4)
+4 ;replace specialty pointer (ien) with ptf code (alpha-numeric)
+5 ;DG729
NEW DGARRX,DGARRY
+6 SET DGARRX=$$TSDATA^DGACT(42.4,$PIECE(X,U,2),.DGARRY)
+7 SET $PIECE(X,U,2)=$GET(DGARRY(7))
+8 ;SPECIALTY - $E(Y,41,42)
+9 SET L=2
SET Z=2
DO ENTER0
+10 ;DIALYSIS TYPE - $E(Y,43)
+11 ;null dialysis type. DG729
SET L=1
SET Z=3
SET $PIECE(X,U,Z)=""
DO ENTER
+12 ;NUMBER OF DIALYSIS TREATMENTS - $E(Y44,46)
+13 SET L=3
SET Z=4
DO ENTER0
+14 NEW EFFDATE,IMPDATE,DGPTDAT
DO EFFDATE^DGPTIC10(J)
+15 ;procedure codes 1 thru 25 - $E(Y,47,246)
+16 NEW DG601CODES,DGLOOP,DGPCODE,DGPROCNODE,DGSTRING,DGPTTMP
+17 ;get 601 values
DO PTFICD^DGPTFUT(601,J,I,.DG601CODES)
+18 SET DGLOOP=0
SET DGSTRING=""
+19 ;returns codes used, no null fields
FOR
SET DGLOOP=$ORDER(DG601CODES(DGLOOP))
if DGLOOP=""
QUIT
Begin DoDot:1
+20 ;external value
SET DGPCODE=$PIECE(DG601CODES(DGLOOP),U,3)
+21 ;check data
SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",$PIECE(DG601CODES(DGLOOP),U,1),EFFDATE,"I")
+22 ;don't use if bad
if +DGPTTMP'>0
QUIT
+23 SET DGSTRING=DGSTRING_DGPCODE_" "
End DoDot:1
+24 SET $EXTRACT(Y,47,246)=DGSTRING_$$REPEAT^XLFSTR(" ",200-$LENGTH(DGSTRING))
+25 ;[NOT ACTIVATED] - $E(Y,247,255)
+26 ;[RESERVED] - $E(Y,256,290)
+27 ;[NOT ALLOCATED] - $E(Y,291,384)
+28 DO SAVE
GOTO 601
+29 QUIT
+30 ;
701 ; -- setup 701 transaction
+1 DO 701^DGPTRI4
QUIT
+2 ;
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 ;save segment to MailMan message and ^TMP("AEDIT",$J), if data is valid
+1 NEW DGY1,DGY2
+2 SET (DGY1,DGY2)=""
+3 ;validate data in segment
DO START^DGPTRI1
+4 ;^TMP("AEDIT",$J) used by DGPTAE* for more data validation
IF DGERR'>0
SET DGACNT=DGACNT+1
SET ^TMP("AEDIT",$JOB,$EXTRACT(Y,1,4),DGACNT)=Y
+5 ;AITC wants segment length of 384 characters.
+6 ;Break the segment at 240, if it does not affect a data field. Otherwise break line before data field.
+7 IF 'DGERR
Begin DoDot:1
+8 DO FILL
+9 IF $EXTRACT(Y,2,4)=101
SET DGY1=$EXTRACT(Y,1,240)
SET DGY2=$EXTRACT(Y,241,384)
+10 IF $EXTRACT(Y,2,4)=401
SET DGY1=$EXTRACT(Y,1,238)
SET DGY2=$EXTRACT(Y,239,384)
+11 IF $EXTRACT(Y,2,4)=501
SET DGY1=$EXTRACT(Y,1,239)
SET DGY2=$EXTRACT(Y,240,384)
+12 IF $EXTRACT(Y,2,4)=535
SET DGY1=$EXTRACT(Y,1,240)
SET DGY2=$EXTRACT(Y,241,384)
+13 IF $EXTRACT(Y,2,4)=601
SET DGY1=$EXTRACT(Y,1,238)
SET DGY2=$EXTRACT(Y,239,384)
+14 IF $EXTRACT(Y,2,4)=701
SET DGY1=$EXTRACT(Y,1,240)
SET DGY2=$EXTRACT(Y,241,384)
+15 IF $EXTRACT(Y,2,4)=702
SET DGY1=$EXTRACT(Y,1,240)
SET DGY2=$EXTRACT(Y,241,384)
+16 if DGY1=""!(DGY2="")
QUIT
+17 SET ^XMB(3.9,DGXMZ,2,DGCNT,0)=DGY1
SET DGCNT=DGCNT+1
+18 SET ^XMB(3.9,DGXMZ,2,DGCNT,0)=DGY2
SET DGCNT=DGCNT+1
End DoDot:1
Q QUIT
+1 ;
FILL ;fill out segment with spaces
+1 FOR K=$LENGTH(Y):1
if $LENGTH(Y)>383
QUIT
SET Y=Y_" "
+2 ;383rd character=1 to indicate ICD10 record. DGPTR2 sets 383rd character=9 to indicate ICD9 record.
SET $EXTRACT(Y,383)=1
+3 QUIT
+4 ;
CDR SET Y=Y_$EXTRACT($PIECE(Z,".")_"0000",1,4)_$EXTRACT($PIECE(Z,".",2)_"00",1,2)
+1 QUIT
