DGPTR4 ;ALB/JDS/MJK/MTC/ADL - ALB/BOK PTF TRANSMISSION ; 11 JUL 05 @0800
;;5.3;PIMS;**338,423,415,510,565,645,729,1015,1016**;JUN 30, 2012;Build 20
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)
S DGPTDAT=$$GETDATE^ICDGTDRG(J)
S DGPTTMP=$$ICDDX^ICDCODE(+$P(DG70,U,10),DGPTDAT) 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=$$ICDDX^ICDCODE(+$P(L,U,K),DGPTDAT) 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
I T1 F K=41:1:55,65:1:73 S Y=$E(Y,1,K-1)_" "_$E(Y,K+1,125)
I T1 D CEN^DGPTR1 S:'DGERR ^XMB(3.9,DGXMZ,2,DGCNT,0)=Y,DGCNT=DGCNT+1 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
I 'DGERR S ^XMB(3.9,DGXMZ,2,DGCNT,0)=Y,DGCNT=DGCNT+1
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 D START^DGPTR1 S:'DGERR ^XMB(3.9,DGXMZ,2,DGCNT,0)=Y,DGCNT=DGCNT+1
I DGERR'>0 S DGACNT=DGACNT+1,^TMP("AEDIT",$J,$E(Y,1,4),DGACNT)=Y
Q Q
;
FILL F K=$L(Y):1:124 S Y=Y_" "
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 mulitple 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)
.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
DGPTR4 ;ALB/JDS/MJK/MTC/ADL - ALB/BOK PTF TRANSMISSION ; 11 JUL 05 @0800
+1 ;;5.3;PIMS;**338,423,415,510,565,645,729,1015,1016**;JUN 30, 2012;Build 20
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 SET DGPTDAT=$$GETDATE^ICDGTDRG(J)
+3 SET DGPTTMP=$$ICDDX^ICDCODE(+$PIECE(DG70,U,10),DGPTDAT)
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))_" "
+4 SET L=$PIECE(DG70,U,16,24)_U_DG71
SET DG702=""
+5 FOR K=1:1:12
SET DGPTTMP=$$ICDDX^ICDCODE(+$PIECE(L,U,K),DGPTDAT)
IF +DGPTTMP>0&($PIECE(DGPTTMP,U,10))
SET DG702=DG702_$PIECE(DGPTTMP,U,2)_U
+6 SET Y=Y_$SELECT(DG702']"":"X",1:" ")
+7 ; -- get phy cdr @ d/c
+8 SET X=""
SET Z=+$ORDER(^DGPT(J,535,"AM",DG70-.0000001))
IF $DATA(^DGPT(J,535,+$ORDER(^(Z,0)),0))
SET X=^(0)
+9 ; -- set phy cdr
+10 SET Z=$PIECE(X,U,16)
DO CDR
+11 ; -- set phy spec
+12 ;replace specialty pointer (ien) with ptf code (alpha-numeric)
+13 ;DG729
NEW DGARRX,DGARRY
+14 SET DGARRX=$$TSDATA^DGACT(42.4,$PIECE(X,U,2),.DGARRY)
+15 SET $PIECE(X,U,2)=$GET(DGARRY(7))
+16 SET L=2
SET Z=2
DO ENTER0
+17 SET X=$SELECT($PIECE(DG3,U)="Y":$$RTEN($PIECE(DG3,U,2)),1:"0")
SET L=3
SET Z=1
DO ENTER0
+18 ;-- additional ptf questions
+19 SET DGAUX=$SELECT($DATA(^DGPT(J,300)):^(300),1:"")
+20 DO ADDQUES
+21 KILL DGAUX,DGDRUG
+22 ;-- sc,ao,ir,ec questions
+23 SET X=DG70
+24 ;-- sc
+25 SET Y=Y_$EXTRACT($PIECE(DG70,U,25)_" ")
+26 ;-- ao
+27 SET Y=Y_$EXTRACT($PIECE(DG70,U,26)_" ")
+28 ;-- ir
+29 SET Y=Y_$EXTRACT($PIECE(DG70,U,27)_" ")
+30 ;-- SW Asia conditions/ec
+31 SET Y=Y_$EXTRACT($PIECE(DG70,U,28)_" ")
+32 ;-- mst
+33 SET Y=Y_$EXTRACT($PIECE(DG70,U,29)_" ")
+34 ;-- Head/Neck CA
+35 SET Y=Y_$EXTRACT($PIECE(DG70,U,30)_" ")
+36 DO ETHNIC
+37 DO RACE
+38 ;Combat vet
+39 SET Y=Y_$EXTRACT($PIECE(DG70,U,31)_" ")
+40 ;Project 112/SHAD
+41 SET Y=Y_$EXTRACT($PIECE(DG70,U,32)_" ")
+42 DO FILL
+43 IF T1
FOR K=41:1:55,65:1:73
SET Y=$EXTRACT(Y,1,K-1)_" "_$EXTRACT(Y,K+1,125)
+44 IF T1
DO CEN^DGPTR1
IF 'DGERR
SET ^XMB(3.9,DGXMZ,2,DGCNT,0)=Y
SET DGCNT=DGCNT+1
QUIT
+45 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 DO FILL
+5 IF 'DGERR
SET ^XMB(3.9,DGXMZ,2,DGCNT,0)=Y
SET DGCNT=DGCNT+1
+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 DO START^DGPTR1
IF 'DGERR
SET ^XMB(3.9,DGXMZ,2,DGCNT,0)=Y
SET DGCNT=DGCNT+1
+1 IF DGERR'>0
SET DGACNT=DGACNT+1
SET ^TMP("AEDIT",$JOB,$EXTRACT(Y,1,4),DGACNT)=Y
Q QUIT
+1 ;
FILL FOR K=$LENGTH(Y):1:124
SET Y=Y_" "
+1 QUIT
+2 ;
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 mulitple 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)
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
