Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGPTR4

DGPTR4.m

Go to the documentation of this file. 
  1. 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
  1. 701 ; -- setup 701 transaction
  1.  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)
  1.  S X=DG70
  1.  ;replace specialty pointer (ien) with ptf code (alpha-numeric)
  1.  N DGARRX,DGARRY ;DG729
  1.  S DGARRX=$$TSDATA^DGACT(42.4,$P(X,U,2),.DGARRY)
  1.  S $P(X,U,2)=$G(DGARRY(7))
  1.  S (L,Z)=2 D ENTER0 K DGDDX
  1.  S X=DG70 I "467"[($P(X,U,3)\1) S Y=Y_$P(X,U,3)_"         " G J
  1.  S L=1 F Z=3:1:5 D ENTER
  1.  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)
  1. J S L=3,Z=8 D ENTER0
  1.  S Y=Y_"X"_$J($P(DG70,U,9),1)
  1.  S DGPTDAT=$$GETDATE^ICDGTDRG(J)
  1.  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))_" "
  1.  S L=$P(DG70,U,16,24)_U_DG71 S DG702=""
  1.  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
  1.  S Y=Y_$S(DG702']"":"X",1:" ")
  1.  ; -- get phy cdr @ d/c
  1.  S X="",Z=+$O(^DGPT(J,535,"AM",DG70-.0000001)) I $D(^DGPT(J,535,+$O(^(Z,0)),0)) S X=^(0)
  1.  ; -- set phy cdr
  1.  S Z=$P(X,U,16) D CDR
  1.  ; -- set phy spec
  1.  ;replace specialty pointer (ien) with ptf code (alpha-numeric)
  1.  N DGARRX,DGARRY ;DG729
  1.  S DGARRX=$$TSDATA^DGACT(42.4,$P(X,U,2),.DGARRY)
  1.  S $P(X,U,2)=$G(DGARRY(7))
  1.  S L=2,Z=2 D ENTER0
  1.  S X=$S($P(DG3,U)="Y":$$RTEN($P(DG3,U,2)),1:"0"),L=3,Z=1 D ENTER0
  1.  ;-- additional ptf questions
  1.  S DGAUX=$S($D(^DGPT(J,300)):^(300),1:"")
  1.  D ADDQUES
  1.  K DGAUX,DGDRUG
  1.  ;-- sc,ao,ir,ec questions
  1.  S X=DG70
  1.  ;-- sc
  1.  S Y=Y_$E($P(DG70,U,25)_" ")
  1.  ;-- ao
  1.  S Y=Y_$E($P(DG70,U,26)_" ")
  1.  ;-- ir
  1.  S Y=Y_$E($P(DG70,U,27)_" ")
  1.  ;-- SW Asia conditions/ec
  1.  S Y=Y_$E($P(DG70,U,28)_" ")
  1.  ;-- mst
  1.  S Y=Y_$E($P(DG70,U,29)_" ")
  1.  ;-- Head/Neck CA
  1.  S Y=Y_$E($P(DG70,U,30)_" ")
  1.  D ETHNIC
  1.  D RACE
  1.  ;Combat vet
  1.  S Y=Y_$E($P(DG70,U,31)_" ")
  1.  ;Project 112/SHAD
  1.  S Y=Y_$E($P(DG70,U,32)_" ")
  1.  D FILL
  1.  I T1 F K=41:1:55,65:1:73 S Y=$E(Y,1,K-1)_" "_$E(Y,K+1,125)
  1.  I T1 D CEN^DGPTR1 S:'DGERR ^XMB(3.9,DGXMZ,2,DGCNT,0)=Y,DGCNT=DGCNT+1 Q
  1.  I 'T1 D SAVE
  1. 702 ;
  1.  Q:DG702']""
  1.  S Y="N702"_$E(Y,5,40)
  1.  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
  1.  D FILL
  1.  I 'DGERR S ^XMB(3.9,DGXMZ,2,DGCNT,0)=Y,DGCNT=DGCNT+1
  1.  I DGERR'>0 S DGACNT=DGACNT+1,^TMP("AEDIT",$J,$E(Y,1,4),DGACNT)=Y
  1.  S DG702=$P(DG702,U,6,9)
  1.  Q
  1.  ;
  1. ENTER S Y=Y_$J($P(X,U,Z),L)
  1.  Q
  1.  ;
  1. 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))
  1.  Q
  1.  ;
  1. SAVE D START^DGPTR1 S:'DGERR ^XMB(3.9,DGXMZ,2,DGCNT,0)=Y,DGCNT=DGCNT+1
  1.  I DGERR'>0 S DGACNT=DGACNT+1,^TMP("AEDIT",$J,$E(Y,1,4),DGACNT)=Y
  1. Q Q
  1.  ;
  1. FILL F K=$L(Y):1:124 S Y=Y_" "
  1.  Q
  1.  ;
  1. CDR S Y=Y_$E($P(Z,".")_"0000",1,4)_$E($P(Z,".",2)_"00",1,2)
  1.  Q
  1. ADDQUES ;-- additional PTF questions load records for trans 501/701
  1.  N DGADDQ
  1.  F DGADDQ=2,3,4 D  ;null results if discharge>inactive date. DG/729
  1.  . 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:"")
  1.  S DGDRUG=$S($D(^DIC(45.61,+$P(DGAUX,U,4),0)):$P(^(0),U,2),1:"    ")
  1.  S Y=Y_$E($P(DGAUX,U,3)_" ")_$E($P(DGAUX,U,2)_" ")_$J($P(DGDRUG,U),4)
  1.  S Y=Y_$E($P(DGAUX,U,5)_" ")
  1.  S DGT=0,X=$P(DGAUX,U,6) I X]"" S DGT=1,Z=1,L=2 D ENTER0
  1.  I 'DGT S Y=Y_"  "
  1.  S DGT=0,X=$P(DGAUX,U,7) I X]"" S DGT=1,Z=1,L=2 D ENTER0
  1.  I 'DGT S Y=Y_"  "
  1.  Q
  1. RTEN(X) ; This function will round X to the nearest mulitple of ten.
  1.  ; 0-4 ->DOWN; 5-9->UP
  1.  Q (X\10)*10+$S(X#10>4:10,1:0)
  1. ETHNIC ;-- Ethnicity (use first active value)
  1.  N NODE,NUM,ETHNIC,I,X
  1.  S ETHNIC=""
  1.  S I=0
  1.  S NUM=1
  1.  F  S I=+$O(DG06(I)) Q:'I  D  Q:NUM>1
  1.  .S NODE=$G(DG06(I,0))
  1.  .Q:('NODE)!('$D(^DIC(10.2,+NODE,0)))
  1.  .Q:$$INACTIVE^DGUTL4(+NODE)
  1.  .S X=$$PTR2CODE^DGUTL4(+NODE,2,4)
  1.  .S ETHNIC=$S(X="":" ",1:X)
  1.  .S X=$$PTR2CODE^DGUTL4(+$P(NODE,"^",2),3,4)
  1.  .S ETHNIC=ETHNIC_$S(X="":" ",1:X)
  1.  .S NUM=NUM+1
  1.  S Y=Y_$S(ETHNIC="":"  ",1:ETHNIC)
  1.  Q
  1. RACE ;-- Race (use first 6 active values)
  1.  N NODE,NUM,RACE,I,X
  1.  S RACE=""
  1.  S I=0
  1.  S NUM=1
  1.  F  S I=+$O(DG02(I)) Q:'I  D  Q:NUM>6
  1.  .S NODE=$G(DG02(I,0))
  1.  .Q:('NODE)!('$D(^DIC(10,+NODE,0)))
  1.  .Q:$$INACTIVE^DGUTL4(+NODE)
  1.  .S X=$$PTR2CODE^DGUTL4(+NODE,1,4)
  1.  .S RACE=RACE_$S(X="":" ",1:X)
  1.  .S X=$$PTR2CODE^DGUTL4(+$P(NODE,"^",2),3,4)
  1.  .S RACE=RACE_$S(X="":" ",1:X)
  1.  .S NUM=NUM+1
  1.  S X="" S $P(X," ",12)=""
  1.  S RACE=$S(RACE="":"  ",1:RACE)_X
  1.  S Y=Y_$E(RACE,1,12)
  1.  Q