DGPTR4 ;ALB/JDS/MJK/MTC/ADL/TJ/BOK,HIOFO/FT - PTF TRANSMISSION ;5/11/15 4:52pm
;;5.3;Registration;**338,423,415,510,565,645,729,664,850,884**;Aug 13, 1993;Build 31
;
; ICDXCODE APIs - #5699
;
701 ; -- setup 701 transaction
S Y=$S(T1:"C",1:"N")_"701"_DGHEAD,DGDDX=$P(+DG70,".")_" ",Y=Y_$E(DGDDX,4,5)_$E(DGDDX,6,7)_$E(DGDDX,2,3)_$E($P(+DG70,".",2)_"0000",1,4)
S X=DG70
;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,Z)=2 D ENTER0 K DGDDX
S X=DG70 I "467"[($P(X,U,3)\1) S Y=Y_$P(X,U,3)_" " G J
S L=1 F Z=3:1:5 D ENTER
S Y=Y_$S($D(^DIC(45.6,+$P(X,U,6),0)):$P(^(0),U,2),1:" "),L=3,Z=12 D ENTER S Y=Y_$E($P(X,U,13)_" ",1,3)
J S L=3,Z=8 D ENTER0
S Y=Y_"X"_$J($P(DG70,U,9),1)
N EFFDATE,IMPDATE,DGPTDAT D EFFDATE^DGPTIC10(J)
S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$P(DG70,U,10),EFFDATE,"I")
S DGXLS=$S(+DGPTTMP>0&($P(DGPTTMP,U,10)):$P(DGPTTMP,U,2),1:""),Y=Y_$S(DGXLS[".":$J($P(DGXLS,".",1),3)_$E($P(DGXLS,".",2)_" ",1,3),1:$J(DGXLS,6))_" "
S L=$P(DG70,U,16,24)_U_DG71 S DG702=""
F K=1:1:12 S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$P(L,U,K),EFFDATE,"I") I +DGPTTMP>0&($P(DGPTTMP,U,10)) S DG702=DG702_$P(DGPTTMP,U,2)_U
S Y=Y_$S(DG702']"":"X",1:" ")
; -- get phy cdr @ d/c
S X="",Z=+$O(^DGPT(J,535,"AM",DG70-.0000001)) I $D(^DGPT(J,535,+$O(^(Z,0)),0)) S X=^(0)
; -- set phy cdr
S Z=$P(X,U,16) D CDR
; -- set phy spec
;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
S X=$S($P(DG3,U)="Y":$$RTEN($P(DG3,U,2)),1:"0"),L=3,Z=1 D ENTER0
;-- additional ptf questions
S DGAUX=$S($D(^DGPT(J,300)):^(300),1:"")
D ADDQUES
K DGAUX,DGDRUG
;-- sc,ao,ir,ec questions
S X=DG70
;-- sc
S Y=Y_$E($P(DG70,U,25)_" ")
;-- ao
S Y=Y_$E($P(DG70,U,26)_" ")
;-- ir
S Y=Y_$E($P(DG70,U,27)_" ")
;-- SW Asia conditions/ec
S Y=Y_$E($P(DG70,U,28)_" ")
;-- mst
S Y=Y_$E($P(DG70,U,29)_" ")
;-- Head/Neck CA
S Y=Y_$E($P(DG70,U,30)_" ")
D ETHNIC
D RACE
;Combat vet
S Y=Y_$E($P(DG70,U,31)_" ")
;Project 112/SHAD
S Y=Y_$E($P(DG70,U,32)_" ")
D FILL^DGPTR2 ;pad to 125 characters
I T1 F K=41:1:55,65:1:73 S $E(Y,K)=" " ;send spaces if census
I T1 D CEN^DGPTR1 D:'DGERR SAVE70X Q
I 'T1 D SAVE
702 ;
Q:DG702']""
S Y="N702"_$E(Y,5,40)
F K=1:1:12 S F=$P(DG702,U,K),F=$P(F,".",1)_$E($P(F,".",2)_" ",1,3),F=F_$E(" ",1,7-$L(F)),Y=Y_F
D FILL^DGPTR2 ;pad to 125 characters
I 'DGERR D SAVE70X
I DGERR'>0 S DGACNT=DGACNT+1,^TMP("AEDIT",$J,$E(Y,1,4),DGACNT)=Y
S DG702=$P(DG702,U,6,9)
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 ;validate data and save to MailMan message & ^TMP("AEDIT",$J)
D SAVE^DGPTR2
Q ;
Q
SAVE70X ;pad with spaces, set 383rd character & save to MailMan message.
N DGY1,DGY2
D FILL384^DGPTR2
S DGY1=$E(Y,1,240),DGY2=$E(Y,241,384)
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
;
CDR S Y=Y_$E($P(Z,".")_"0000",1,4)_$E($P(Z,".",2)_"00",1,2)
Q
ADDQUES ;-- additional PTF questions load records for trans 501/701
N DGADDQ
F DGADDQ=2,3,4 D ;null results if discharge>inactive date. DG/729
. I +$P($G(^DIC(45.88,DGADDQ,0)),U,3) S $P(DGAUX,U,DGADDQ)=$S((+$G(^DGPT(J,70))<$P(^DIC(45.88,DGADDQ,0),U,3)):$P(DGAUX,U,DGADDQ),1:"")
S DGDRUG=$S($D(^DIC(45.61,+$P(DGAUX,U,4),0)):$P(^(0),U,2),1:" ")
S Y=Y_$E($P(DGAUX,U,3)_" ")_$E($P(DGAUX,U,2)_" ")_$J($P(DGDRUG,U),4)
S Y=Y_$E($P(DGAUX,U,5)_" ")
S DGT=0,X=$P(DGAUX,U,6) I X]"" S DGT=1,Z=1,L=2 D ENTER0
I 'DGT S Y=Y_" "
S DGT=0,X=$P(DGAUX,U,7) I X]"" S DGT=1,Z=1,L=2 D ENTER0
I 'DGT S Y=Y_" "
Q
RTEN(X) ; This function will round X to the nearest multiple of ten.
; 0-4 ->DOWN; 5-9->UP
Q (X\10)*10+$S(X#10>4:10,1:0)
ETHNIC ;-- Ethnicity (use first active value)
N NODE,NUM,ETHNIC,I,X
S ETHNIC=""
S I=0
S NUM=1
F S I=+$O(DG06(I)) Q:'I D Q:NUM>1
.S NODE=$G(DG06(I,0))
.Q:('NODE)!('$D(^DIC(10.2,+NODE,0)))
.Q:$$INACTIVE^DGUTL4(+NODE,2)
.S X=$$PTR2CODE^DGUTL4(+NODE,2,4)
.S ETHNIC=$S(X="":" ",1:X)
.S X=$$PTR2CODE^DGUTL4(+$P(NODE,"^",2),3,4)
.S ETHNIC=ETHNIC_$S(X="":" ",1:X)
.S NUM=NUM+1
S Y=Y_$S(ETHNIC="":" ",1:ETHNIC)
Q
RACE ;-- Race (use first 6 active values)
N NODE,NUM,RACE,I,X
S RACE=""
S I=0
S NUM=1
F S I=+$O(DG02(I)) Q:'I D Q:NUM>6
.S NODE=$G(DG02(I,0))
.Q:('NODE)!('$D(^DIC(10,+NODE,0)))
.Q:$$INACTIVE^DGUTL4(+NODE)
.S X=$$PTR2CODE^DGUTL4(+NODE,1,4)
.S RACE=RACE_$S(X="":" ",1:X)
.S X=$$PTR2CODE^DGUTL4(+$P(NODE,"^",2),3,4)
.S RACE=RACE_$S(X="":" ",1:X)
.S NUM=NUM+1
S X="" S $P(X," ",12)=""
S RACE=$S(RACE="":" ",1:RACE)_X
S Y=Y_$E(RACE,1,12)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTR4 4935 printed Jan 18, 2025@03:54:06 Page 2
DGPTR4 ;ALB/JDS/MJK/MTC/ADL/TJ/BOK,HIOFO/FT - PTF TRANSMISSION ;5/11/15 4:52pm
+1 ;;5.3;Registration;**338,423,415,510,565,645,729,664,850,884**;Aug 13, 1993;Build 31
+2 ;
+3 ; ICDXCODE APIs - #5699
+4 ;
701 ; -- setup 701 transaction
+1 SET Y=$SELECT(T1:"C",1:"N")_"701"_DGHEAD
SET DGDDX=$PIECE(+DG70,".")_" "
SET Y=Y_$EXTRACT(DGDDX,4,5)_$EXTRACT(DGDDX,6,7)_$EXTRACT(DGDDX,2,3)_$EXTRACT($PIECE(+DG70,".",2)_"0000",1,4)
+2 SET X=DG70
+3 ;replace specialty pointer (ien) with ptf code (alpha-numeric)
+4 ;DG729
NEW DGARRX,DGARRY
+5 SET DGARRX=$$TSDATA^DGACT(42.4,$PIECE(X,U,2),.DGARRY)
+6 SET $PIECE(X,U,2)=$GET(DGARRY(7))
+7 SET (L,Z)=2
DO ENTER0
KILL DGDDX
+8 SET X=DG70
IF "467"[($PIECE(X,U,3)\1)
SET Y=Y_$PIECE(X,U,3)_" "
GOTO J
+9 SET L=1
FOR Z=3:1:5
DO ENTER
+10 SET Y=Y_$SELECT($DATA(^DIC(45.6,+$PIECE(X,U,6),0)):$PIECE(^(0),U,2),1:" ")
SET L=3
SET Z=12
DO ENTER
SET Y=Y_$EXTRACT($PIECE(X,U,13)_" ",1,3)
J SET L=3
SET Z=8
DO ENTER0
+1 SET Y=Y_"X"_$JUSTIFY($PIECE(DG70,U,9),1)
+2 NEW EFFDATE,IMPDATE,DGPTDAT
DO EFFDATE^DGPTIC10(J)
+3 SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$PIECE(DG70,U,10),EFFDATE,"I")
+4 SET DGXLS=$SELECT(+DGPTTMP>0&($PIECE(DGPTTMP,U,10)):$PIECE(DGPTTMP,U,2),1:"")
SET Y=Y_$SELECT(DGXLS[".":$JUSTIFY($PIECE(DGXLS,".",1),3)_$EXTRACT($PIECE(DGXLS,".",2)_" ",1,3),1:$JUSTIFY(DGXLS,6))_" "
+5 SET L=$PIECE(DG70,U,16,24)_U_DG71
SET DG702=""
+6 FOR K=1:1:12
SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$PIECE(L,U,K),EFFDATE,"I")
IF +DGPTTMP>0&($PIECE(DGPTTMP,U,10))
SET DG702=DG702_$PIECE(DGPTTMP,U,2)_U
+7 SET Y=Y_$SELECT(DG702']"":"X",1:" ")
+8 ; -- get phy cdr @ d/c
+9 SET X=""
SET Z=+$ORDER(^DGPT(J,535,"AM",DG70-.0000001))
IF $DATA(^DGPT(J,535,+$ORDER(^(Z,0)),0))
SET X=^(0)
+10 ; -- set phy cdr
+11 SET Z=$PIECE(X,U,16)
DO CDR
+12 ; -- set phy spec
+13 ;replace specialty pointer (ien) with ptf code (alpha-numeric)
+14 ;DG729
NEW DGARRX,DGARRY
+15 SET DGARRX=$$TSDATA^DGACT(42.4,$PIECE(X,U,2),.DGARRY)
+16 SET $PIECE(X,U,2)=$GET(DGARRY(7))
+17 SET L=2
SET Z=2
DO ENTER0
+18 SET X=$SELECT($PIECE(DG3,U)="Y":$$RTEN($PIECE(DG3,U,2)),1:"0")
SET L=3
SET Z=1
DO ENTER0
+19 ;-- additional ptf questions
+20 SET DGAUX=$SELECT($DATA(^DGPT(J,300)):^(300),1:"")
+21 DO ADDQUES
+22 KILL DGAUX,DGDRUG
+23 ;-- sc,ao,ir,ec questions
+24 SET X=DG70
+25 ;-- sc
+26 SET Y=Y_$EXTRACT($PIECE(DG70,U,25)_" ")
+27 ;-- ao
+28 SET Y=Y_$EXTRACT($PIECE(DG70,U,26)_" ")
+29 ;-- ir
+30 SET Y=Y_$EXTRACT($PIECE(DG70,U,27)_" ")
+31 ;-- SW Asia conditions/ec
+32 SET Y=Y_$EXTRACT($PIECE(DG70,U,28)_" ")
+33 ;-- mst
+34 SET Y=Y_$EXTRACT($PIECE(DG70,U,29)_" ")
+35 ;-- Head/Neck CA
+36 SET Y=Y_$EXTRACT($PIECE(DG70,U,30)_" ")
+37 DO ETHNIC
+38 DO RACE
+39 ;Combat vet
+40 SET Y=Y_$EXTRACT($PIECE(DG70,U,31)_" ")
+41 ;Project 112/SHAD
+42 SET Y=Y_$EXTRACT($PIECE(DG70,U,32)_" ")
+43 ;pad to 125 characters
DO FILL^DGPTR2
+44 ;send spaces if census
IF T1
FOR K=41:1:55,65:1:73
SET $EXTRACT(Y,K)=" "
+45 IF T1
DO CEN^DGPTR1
if 'DGERR
DO SAVE70X
QUIT
+46 IF 'T1
DO SAVE
702 ;
+1 if DG702']""
QUIT
+2 SET Y="N702"_$EXTRACT(Y,5,40)
+3 FOR K=1:1:12
SET F=$PIECE(DG702,U,K)
SET F=$PIECE(F,".",1)_$EXTRACT($PIECE(F,".",2)_" ",1,3)
SET F=F_$EXTRACT(" ",1,7-$LENGTH(F))
SET Y=Y_F
+4 ;pad to 125 characters
DO FILL^DGPTR2
+5 IF 'DGERR
DO SAVE70X
+6 IF DGERR'>0
SET DGACNT=DGACNT+1
SET ^TMP("AEDIT",$JOB,$EXTRACT(Y,1,4),DGACNT)=Y
+7 SET DG702=$PIECE(DG702,U,6,9)
+8 QUIT
+9 ;
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 ;validate data and save to MailMan message & ^TMP("AEDIT",$J)
+1 DO SAVE^DGPTR2
Q ;
+1 QUIT
SAVE70X ;pad with spaces, set 383rd character & save to MailMan message.
+1 NEW DGY1,DGY2
+2 DO FILL384^DGPTR2
+3 SET DGY1=$EXTRACT(Y,1,240)
SET DGY2=$EXTRACT(Y,241,384)
+4 SET ^XMB(3.9,DGXMZ,2,DGCNT,0)=DGY1
SET DGCNT=DGCNT+1
+5 SET ^XMB(3.9,DGXMZ,2,DGCNT,0)=DGY2
SET DGCNT=DGCNT+1
+6 QUIT
+7 ;
CDR SET Y=Y_$EXTRACT($PIECE(Z,".")_"0000",1,4)_$EXTRACT($PIECE(Z,".",2)_"00",1,2)
+1 QUIT
ADDQUES ;-- additional PTF questions load records for trans 501/701
+1 NEW DGADDQ
+2 ;null results if discharge>inactive date. DG/729
FOR DGADDQ=2,3,4
Begin DoDot:1
+3 IF +$PIECE($GET(^DIC(45.88,DGADDQ,0)),U,3)
SET $PIECE(DGAUX,U,DGADDQ)=$SELECT((+$GET(^DGPT(J,70))<$PIECE(^DIC(45.88,DGADDQ,0),U,3)):$PIECE(DGAUX,U,DGADDQ),1:"")
End DoDot:1
+4 SET DGDRUG=$SELECT($DATA(^DIC(45.61,+$PIECE(DGAUX,U,4),0)):$PIECE(^(0),U,2),1:" ")
+5 SET Y=Y_$EXTRACT($PIECE(DGAUX,U,3)_" ")_$EXTRACT($PIECE(DGAUX,U,2)_" ")_$JUSTIFY($PIECE(DGDRUG,U),4)
+6 SET Y=Y_$EXTRACT($PIECE(DGAUX,U,5)_" ")
+7 SET DGT=0
SET X=$PIECE(DGAUX,U,6)
IF X]""
SET DGT=1
SET Z=1
SET L=2
DO ENTER0
+8 IF 'DGT
SET Y=Y_" "
+9 SET DGT=0
SET X=$PIECE(DGAUX,U,7)
IF X]""
SET DGT=1
SET Z=1
SET L=2
DO ENTER0
+10 IF 'DGT
SET Y=Y_" "
+11 QUIT
RTEN(X) ; This function will round X to the nearest multiple of ten.
+1 ; 0-4 ->DOWN; 5-9->UP
+2 QUIT (X\10)*10+$SELECT(X#10>4:10,1:0)
ETHNIC ;-- Ethnicity (use first active value)
+1 NEW NODE,NUM,ETHNIC,I,X
+2 SET ETHNIC=""
+3 SET I=0
+4 SET NUM=1
+5 FOR
SET I=+$ORDER(DG06(I))
if 'I
QUIT
Begin DoDot:1
+6 SET NODE=$GET(DG06(I,0))
+7 if ('NODE)!('$DATA(^DIC(10.2,+NODE,0)))
QUIT
+8 if $$INACTIVE^DGUTL4(+NODE,2)
QUIT
+9 SET X=$$PTR2CODE^DGUTL4(+NODE,2,4)
+10 SET ETHNIC=$SELECT(X="":" ",1:X)
+11 SET X=$$PTR2CODE^DGUTL4(+$PIECE(NODE,"^",2),3,4)
+12 SET ETHNIC=ETHNIC_$SELECT(X="":" ",1:X)
+13 SET NUM=NUM+1
End DoDot:1
if NUM>1
QUIT
+14 SET Y=Y_$SELECT(ETHNIC="":" ",1:ETHNIC)
+15 QUIT
RACE ;-- Race (use first 6 active values)
+1 NEW NODE,NUM,RACE,I,X
+2 SET RACE=""
+3 SET I=0
+4 SET NUM=1
+5 FOR
SET I=+$ORDER(DG02(I))
if 'I
QUIT
Begin DoDot:1
+6 SET NODE=$GET(DG02(I,0))
+7 if ('NODE)!('$DATA(^DIC(10,+NODE,0)))
QUIT
+8 if $$INACTIVE^DGUTL4(+NODE)
QUIT
+9 SET X=$$PTR2CODE^DGUTL4(+NODE,1,4)
+10 SET RACE=RACE_$SELECT(X="":" ",1:X)
+11 SET X=$$PTR2CODE^DGUTL4(+$PIECE(NODE,"^",2),3,4)
+12 SET RACE=RACE_$SELECT(X="":" ",1:X)
+13 SET NUM=NUM+1
End DoDot:1
if NUM>6
QUIT
+14 SET X=""
SET $PIECE(X," ",12)=""
+15 SET RACE=$SELECT(RACE="":" ",1:RACE)_X
+16 SET Y=Y_$EXTRACT(RACE,1,12)
+17 QUIT
