DGPTSUDO ;ALB/MTC - PTF UPDATE TRANSFER DRG NODE; 30 MAR 89@09 ; 3/12/02 12:14pm
;;5.3;PIMS;**441,510,478,785,1015,1016**;JUN 30, 2012;Build 20
;;ADL;Update for CSV Project;;Mar 28, 2003
UTIL S ^UTILITY($J,"T",(9999999.999999-$E(I,1,14)))=K_"^"_$S($D(^DIC(45.7,J,0)):$P(^(0),"^",2),1:0)_"^"_X_"^^"_$P(Y,"^",8)
Q
SUDO1 K ^UTILITY($J,"T"),T
F I=0:0 S I=$O(^DGPM("ATS",DFN,DGPMCA,I)) Q:I'>0 D
. S J=$O(^DGPM("ATS",DFN,DGPMCA,I,0)) I J D
.. S K=+$O(^(J,0)) I $D(^DGPM(K,0)) S Y=^(0),X=$S($D(^("PTF")):$P(^("PTF"),"^",2),1:"") I $D(^DGPT(PTF,"M",+X,0))!($D(^DGPM("APHY",+$P(Y,"^",14),K))) D UTIL
Q:'$D(^UTILITY($J,"T"))
VARS I '$D(^UTILITY($J,"T")) G SUDO1
S (DGPRD,DGNXD)=$O(^UTILITY($J,"T",0)) G Q:DGPRD'>0 S T(DGPRD)=^(DGPRD),(DGEXP,DGDMS,DGTRS,DGTLOS,DGLOS,DGDAT)=0,DGPT(70)=$S($D(^DGPT(PTF,70)):^(70),1:""),SEX=$P(^DPT(DFN,0),U,2),DOB=$P(^(0),U,3),(DGDX,DGNSV,DGPSV)=""
S DGDAT=$$GETDATE^ICDGTDRG(PTF)
K DGSURG,DGPROC S (DGSURG,DGPROC)=U
;-- build DGSURG array
S DGPTDAT=$$GETDATE^ICDGTDRG(PTF)
F I=0:0 S I=$O(^DGPT(PTF,"S",I)) Q:I'>0 S X=$P(^(I,0),U,8,12) D
. I X]"",X'="^^^^" S Y=+^(0),Y=$S('$D(DGSURG(Y)):Y,Y[".":Y_I_1,1:Y_".0000"_I_1),DGSURG(Y)="" D
..F J=1:1:5 I $P(X,U,J)]"" S DGPTTMP=$$ICDOP^ICDCODE($P(X,U,J),DGPTDAT) I +DGPTTMP>0 S DGSURG(Y)=DGSURG(Y)_$P(X,U,J)_U
;-- build DGPROC array
F I=0:0 S I=$O(^DGPT(PTF,"P",I)) Q:I'>0 S X=$P(^(I,0),U,5,9) D
. I X]"",X'="^^^^" S Y=+^(0),Y=$S('$D(DGPROC(Y)):Y,Y[".":Y_I_1,1:Y_".0000"_I_1),DGPROC(Y)="" D
.. F J=1:1:5 I $P(X,U,J)]"" S DGPTTMP=$$ICDOP^ICDCODE($P(X,U,J),DGPTDAT) I +DGPTTMP>0 S DGPROC(Y)=DGPROC(Y)_$P(X,U,J)_U
;
I $D(^DGPT(PTF,"401P")),+DGPT(70),+DGPT(70)<2871000 S X=^("401P") I X]"",X'="^^^^" D
. F I=1:1:5 I $P(X,U,I)]"" S DGPTTMP=$$ICDOP^ICDCODE($P(X,U,I),DGPTDAT) I +DGPTTMP>0 S DGPROC=DGPROC_$P(X,U,I)_U,DG401P=1
;
SUDO2 ;
S DGNXD=$O(^UTILITY($J,"T",DGNXD))
G ONE:DGNXD'>0 S T(DGNXD)=^UTILITY($J,"T",DGNXD),I1=+$P(T(DGNXD),U,3),DGDOC=$P(T(DGNXD),U,5)
F I=DGPRD,DGNXD S L1(I)=$P(T(I),U,2)
G:L1(DGPRD)=L1(DGNXD) SWCH
S DGPSV=$S($D(^DIC(42.4,+L1(DGPRD),0)):$P(^(0),U,3),1:""),DGNSV=$S($D(^DIC(42.4,+L1(DGNXD),0)):$P(^(0),U,3),1:"")
G:DGPSV']""!(DGNSV']"") SWCH
I "^I^SCI^B^NH^D^RE^"'[(U_DGPSV_U),$D(^DGPT(PTF,"M",I1,0)) S DGNODE=^(0) D
. D BLD I DGPSV'=DGNSV D DRG S DGSURG=U,DGDX="",DGLOS=0 I '$D(DG401P) S DGPROC=U
SWCH ;
K DGLEV,DGPAS
S DGPRD=DGNXD,T(DGPRD)=T(DGNXD),(DGNSV,DGPSV)=""
G SUDO2
;
BLD ;
F I=9:-1:5 I $P(DGNODE,U,I)]"" S DGPTTMP=$$ICDDX^ICDCODE($P(DGNODE,U,I),$$GETDATE^ICDGTDRG(PTF)) I +DGPTTMP>0 S DGDX=$P(DGNODE,U,I)_U_DGDX
S:$L(DGDX)>200 DGDX=$P(DGDX,U,1,30)
S DGLEV=$P(DGNODE,U,3),DGPAS=$P(DGNODE,U,4),X1=DGNXD,X2=DGPRD D ^%DTC S X=$S(X>0:X,1:1)-DGLEV-DGPAS,DGLOS=DGLOS+X
N I,J,X,Y,Z
F I=0:0 S I=$O(DGSURG(I)) Q:I'>0!(I\1>(DGNXD\1)) D SU
I '$D(DG401P) F I=0:0 S I=$O(DGPROC(I)) Q:I'>0!((I\1)>(DGNXD\1)) D ;S DGPROC=DGPROC(I)_DGPROC K DGPROC(I) I $L(DGPROC)>200 S DGPROC=$P(DGPROC,U,1,30)
.S X=DGPROC(I)
.F J=1:1:5 S Y=$P(X,U,J) Q:Y="" D
..Q:$L(DGPROC)>240
..S Z=U_Y_U
..;Q:DGPROC[Z
..S DGPROC=DGPROC_Y_U
..S DGPROC(J)=Y
..K DGPROC(I)
Q
SU ;
;S:$L(DGSURG)>200 DGSURG=$P(DGSURG,U,1,30)
;I I<DGNXD S DGSURG=DGSURG(I)_DGSURG K DGSURG(I) Q ; surgery date is prior to movement date
; only gets here if surgery occurred on movement date
;I DGPSV=DGNSV S DGSURG=DGSURG(I)_DGSURG K DGSURG(I) Q ; no RAM movement occurred so surgery should be grouped
;I DGPSV="S" S DGSURG=DGSURG(I)_DGSURG K DGSURG(I) Q ; RAM movement occurred and losing service is surgery, so surgery should be grouped
;Q
; 2002 coding replaces above,eliminates dupes,allows more codes
I I<DGNXD!(DGPSV=DGNSV)!(DGPSV="S") D
.S X=DGSURG(I)
.F J=1:1:5 S Y=$P(X,U,J) Q:Y="" D
..Q:$L(DGSURG)>240
..S Z=U_Y_U
..;Q:DGSURG[Z
..S DGSURG=DGSURG_Y_U
..S ICDSURG(J)=Y
..K DGSURG(I)
Q
;
DRG ;
S AGE=DGPRD-DOB\10000,DGTLOS=DGTLOS+DGLOS,DRG=""
D ^DGPTICD
S DGDOC=$S($D(^VA(200,+DGDOC)):DGDOC,1:"")
N DGFDA,DGMSG
S DGFDA(45.02,I1_","_PTF_",",20)=DRG
S DGFDA(45.02,I1_","_PTF_",",21)=DGPSV
S DGFDA(45.02,I1_","_PTF_",",22)=DGNXD
S DGFDA(45.02,I1_","_PTF_",",23)=DGLOS
S DGFDA(45.02,I1_","_PTF_",",24)=DGDOC
S DGFDA(45.02,I1_","_PTF_",",25)=DGTLOS
D FILE^DIE("","DGFDA","DGMSG")
Q
;
ONE ;
S DGNXD=$S(+$P(^DGPT(PTF,"M",1,0),U,10):$P(^(0),U,10),1:DT),L1(DGNXD)=$P(^(0),U,2) S:'$D(T(DGNXD)) T(DGNXD)=T(DGPRD),DGDOC=$P(T(DGNXD),U,5)
S:$P(DGPT(70),U,3)>5 DGEXP=1 S:$P(DGPT(70),U,3)=4 DGDMS=1 S:$P(DGPT(70),U,13) DGTRS=1
I L1(DGNXD),$D(^DIC(42.4,+L1(DGNXD),0)) S I1=1,DGPSV=$P(^(0),U,3),DGADM=$P(^DGPT(PTF,0),U,2)
S DGNODE=$S($D(^DGPT(PTF,"M",1,0)):^(0),1:"") D BLD
I $D(^DGPT("AADA",DGADM,PTF)) S I=$S($P(DGPT(70),U,10):$P(DGPT(70),U,10),$P(DGPT(70),U,11):$P(DGPT(70),U,11),1:"") I I]"" S DGDX=I_U_DGDX
S I1=1 D DRG,^DGPTSUD1
Q ;
K DGDMS,DGDOC,DGDX,DGEXP,DGLEV,DGLOS,DGNODE,DGNSV,DGNXD,DGPAS,DGPRD,DGPROC,DGPSV,DGPT,DGSURG,ICDSURG,DGTLOS,DGTRS,DG401P,I,I1,I2,J,L1,T,X,X1,X2,Y Q
;
DGPTSUDO ;ALB/MTC - PTF UPDATE TRANSFER DRG NODE; 30 MAR 89@09 ; 3/12/02 12:14pm
+1 ;;5.3;PIMS;**441,510,478,785,1015,1016**;JUN 30, 2012;Build 20
+2 ;;ADL;Update for CSV Project;;Mar 28, 2003
UTIL SET ^UTILITY($JOB,"T",(9999999.999999-$EXTRACT(I,1,14)))=K_"^"_$SELECT($DATA(^DIC(45.7,J,0)):$PIECE(^(0),"^",2),1:0)_"^"_X_"^^"_$PIECE(Y,"^",8)
+1 QUIT
SUDO1 KILL ^UTILITY($JOB,"T"),T
+1 FOR I=0:0
SET I=$ORDER(^DGPM("ATS",DFN,DGPMCA,I))
IF I'>0
QUIT
Begin DoDot:1
+2 SET J=$ORDER(^DGPM("ATS",DFN,DGPMCA,I,0))
IF J
Begin DoDot:2
+3 SET K=+$ORDER(^(J,0))
IF $DATA(^DGPM(K,0))
SET Y=^(0)
SET X=$SELECT($DATA(^("PTF")):$PIECE(^("PTF"),"^",2),1:"")
IF $DATA(^DGPT(PTF,"M",+X,0))!($DATA(^DGPM("APHY",+$PIECE(Y,"^",14),K)))
DO UTIL
End DoDot:2
End DoDot:1
+4 IF '$DATA(^UTILITY($JOB,"T"))
QUIT
VARS IF '$DATA(^UTILITY($JOB,"T"))
GOTO SUDO1
+1 SET (DGPRD,DGNXD)=$ORDER(^UTILITY($JOB,"T",0))
IF DGPRD'>0
GOTO Q
SET T(DGPRD)=^(DGPRD)
SET (DGEXP,DGDMS,DGTRS,DGTLOS,DGLOS,DGDAT)=0
SET DGPT(70)=$SELECT($DATA(^DGPT(PTF,70)):^(70),1:"")
SET SEX=$PIECE(^DPT(DFN,0),U,2)
SET DOB=$PIECE(^(0),U,3)
SET (DGDX,DGNSV,DGPSV)=""
+2 SET DGDAT=$$GETDATE^ICDGTDRG(PTF)
+3 KILL DGSURG,DGPROC
SET (DGSURG,DGPROC)=U
+4 ;-- build DGSURG array
+5 SET DGPTDAT=$$GETDATE^ICDGTDRG(PTF)
+6 FOR I=0:0
SET I=$ORDER(^DGPT(PTF,"S",I))
IF I'>0
QUIT
SET X=$PIECE(^(I,0),U,8,12)
Begin DoDot:1
+7 IF X]""
IF X'="^^^^"
SET Y=+^(0)
SET Y=$SELECT('$DATA(DGSURG(Y)):Y,Y[".":Y_I_1,1:Y_".0000"_I_1)
SET DGSURG(Y)=""
Begin DoDot:2
+8 FOR J=1:1:5
IF $PIECE(X,U,J)]""
SET DGPTTMP=$$ICDOP^ICDCODE($PIECE(X,U,J),DGPTDAT)
IF +DGPTTMP>0
SET DGSURG(Y)=DGSURG(Y)_$PIECE(X,U,J)_U
End DoDot:2
End DoDot:1
+9 ;-- build DGPROC array
+10 FOR I=0:0
SET I=$ORDER(^DGPT(PTF,"P",I))
IF I'>0
QUIT
SET X=$PIECE(^(I,0),U,5,9)
Begin DoDot:1
+11 IF X]""
IF X'="^^^^"
SET Y=+^(0)
SET Y=$SELECT('$DATA(DGPROC(Y)):Y,Y[".":Y_I_1,1:Y_".0000"_I_1)
SET DGPROC(Y)=""
Begin DoDot:2
+12 FOR J=1:1:5
IF $PIECE(X,U,J)]""
SET DGPTTMP=$$ICDOP^ICDCODE($PIECE(X,U,J),DGPTDAT)
IF +DGPTTMP>0
SET DGPROC(Y)=DGPROC(Y)_$PIECE(X,U,J)_U
End DoDot:2
End DoDot:1
+13 ;
+14 IF $DATA(^DGPT(PTF,"401P"))
IF +DGPT(70)
IF +DGPT(70)<2871000
SET X=^("401P")
IF X]""
IF X'="^^^^"
Begin DoDot:1
+15 FOR I=1:1:5
IF $PIECE(X,U,I)]""
SET DGPTTMP=$$ICDOP^ICDCODE($PIECE(X,U,I),DGPTDAT)
IF +DGPTTMP>0
SET DGPROC=DGPROC_$PIECE(X,U,I)_U
SET DG401P=1
End DoDot:1
+16 ;
SUDO2 ;
+1 SET DGNXD=$ORDER(^UTILITY($JOB,"T",DGNXD))
+2 IF DGNXD'>0
GOTO ONE
SET T(DGNXD)=^UTILITY($JOB,"T",DGNXD)
SET I1=+$PIECE(T(DGNXD),U,3)
SET DGDOC=$PIECE(T(DGNXD),U,5)
+3 FOR I=DGPRD,DGNXD
SET L1(I)=$PIECE(T(I),U,2)
+4 IF L1(DGPRD)=L1(DGNXD)
GOTO SWCH
+5 SET DGPSV=$SELECT($DATA(^DIC(42.4,+L1(DGPRD),0)):$PIECE(^(0),U,3),1:"")
SET DGNSV=$SELECT($DATA(^DIC(42.4,+L1(DGNXD),0)):$PIECE(^(0),U,3),1:"")
+6 IF DGPSV']""!(DGNSV']"")
GOTO SWCH
+7 IF "^I^SCI^B^NH^D^RE^"'[(U_DGPSV_U)
IF $DATA(^DGPT(PTF,"M",I1,0))
SET DGNODE=^(0)
Begin DoDot:1
+8 DO BLD
IF DGPSV'=DGNSV
DO DRG
SET DGSURG=U
SET DGDX=""
SET DGLOS=0
IF '$DATA(DG401P)
SET DGPROC=U
End DoDot:1
SWCH ;
+1 KILL DGLEV,DGPAS
+2 SET DGPRD=DGNXD
SET T(DGPRD)=T(DGNXD)
SET (DGNSV,DGPSV)=""
+3 GOTO SUDO2
+4 ;
BLD ;
+1 FOR I=9:-1:5
IF $PIECE(DGNODE,U,I)]""
SET DGPTTMP=$$ICDDX^ICDCODE($PIECE(DGNODE,U,I),$$GETDATE^ICDGTDRG(PTF))
IF +DGPTTMP>0
SET DGDX=$PIECE(DGNODE,U,I)_U_DGDX
+2 IF $LENGTH(DGDX)>200
SET DGDX=$PIECE(DGDX,U,1,30)
+3 SET DGLEV=$PIECE(DGNODE,U,3)
SET DGPAS=$PIECE(DGNODE,U,4)
SET X1=DGNXD
SET X2=DGPRD
DO ^%DTC
SET X=$SELECT(X>0:X,1:1)-DGLEV-DGPAS
SET DGLOS=DGLOS+X
+4 NEW I,J,X,Y,Z
+5 FOR I=0:0
SET I=$ORDER(DGSURG(I))
IF I'>0!(I\1>(DGNXD\1))
QUIT
DO SU
+6 ;S DGPROC=DGPROC(I)_DGPROC K DGPROC(I) I $L(DGPROC)>200 S DGPROC=$P(DGPROC,U,1,30)
IF '$DATA(DG401P)
FOR I=0:0
SET I=$ORDER(DGPROC(I))
IF I'>0!((I\1)>(DGNXD\1))
QUIT
Begin DoDot:1
+7 SET X=DGPROC(I)
+8 FOR J=1:1:5
SET Y=$PIECE(X,U,J)
IF Y=""
QUIT
Begin DoDot:2
+9 IF $LENGTH(DGPROC)>240
QUIT
+10 SET Z=U_Y_U
+11 ;Q:DGPROC[Z
+12 SET DGPROC=DGPROC_Y_U
+13 SET DGPROC(J)=Y
+14 KILL DGPROC(I)
End DoDot:2
End DoDot:1
+15 QUIT
SU ;
+1 ;S:$L(DGSURG)>200 DGSURG=$P(DGSURG,U,1,30)
+2 ;I I<DGNXD S DGSURG=DGSURG(I)_DGSURG K DGSURG(I) Q ; surgery date is prior to movement date
+3 ; only gets here if surgery occurred on movement date
+4 ;I DGPSV=DGNSV S DGSURG=DGSURG(I)_DGSURG K DGSURG(I) Q ; no RAM movement occurred so surgery should be grouped
+5 ;I DGPSV="S" S DGSURG=DGSURG(I)_DGSURG K DGSURG(I) Q ; RAM movement occurred and losing service is surgery, so surgery should be grouped
+6 ;Q
+7 ; 2002 coding replaces above,eliminates dupes,allows more codes
+8 IF I<DGNXD!(DGPSV=DGNSV)!(DGPSV="S")
Begin DoDot:1
+9 SET X=DGSURG(I)
+10 FOR J=1:1:5
SET Y=$PIECE(X,U,J)
IF Y=""
QUIT
Begin DoDot:2
+11 IF $LENGTH(DGSURG)>240
QUIT
+12 SET Z=U_Y_U
+13 ;Q:DGSURG[Z
+14 SET DGSURG=DGSURG_Y_U
+15 SET ICDSURG(J)=Y
+16 KILL DGSURG(I)
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
DRG ;
+1 SET AGE=DGPRD-DOB\10000
SET DGTLOS=DGTLOS+DGLOS
SET DRG=""
+2 DO ^DGPTICD
+3 SET DGDOC=$SELECT($DATA(^VA(200,+DGDOC)):DGDOC,1:"")
+4 NEW DGFDA,DGMSG
+5 SET DGFDA(45.02,I1_","_PTF_",",20)=DRG
+6 SET DGFDA(45.02,I1_","_PTF_",",21)=DGPSV
+7 SET DGFDA(45.02,I1_","_PTF_",",22)=DGNXD
+8 SET DGFDA(45.02,I1_","_PTF_",",23)=DGLOS
+9 SET DGFDA(45.02,I1_","_PTF_",",24)=DGDOC
+10 SET DGFDA(45.02,I1_","_PTF_",",25)=DGTLOS
+11 DO FILE^DIE("","DGFDA","DGMSG")
+12 QUIT
+13 ;
ONE ;
+1 SET DGNXD=$SELECT(+$PIECE(^DGPT(PTF,"M",1,0),U,10):$PIECE(^(0),U,10),1:DT)
SET L1(DGNXD)=$PIECE(^(0),U,2)
IF '$DATA(T(DGNXD))
SET T(DGNXD)=T(DGPRD)
SET DGDOC=$PIECE(T(DGNXD),U,5)
+2 IF $PIECE(DGPT(70),U,3)>5
SET DGEXP=1
IF $PIECE(DGPT(70),U,3)=4
SET DGDMS=1
IF $PIECE(DGPT(70),U,13)
SET DGTRS=1
+3 IF L1(DGNXD)
IF $DATA(^DIC(42.4,+L1(DGNXD),0))
SET I1=1
SET DGPSV=$PIECE(^(0),U,3)
SET DGADM=$PIECE(^DGPT(PTF,0),U,2)
+4 SET DGNODE=$SELECT($DATA(^DGPT(PTF,"M",1,0)):^(0),1:"")
DO BLD
+5 IF $DATA(^DGPT("AADA",DGADM,PTF))
SET I=$SELECT($PIECE(DGPT(70),U,10):$PIECE(DGPT(70),U,10),$PIECE(DGPT(70),U,11):$PIECE(DGPT(70),U,11),1:"")
IF I]""
SET DGDX=I_U_DGDX
+6 SET I1=1
DO DRG
DO ^DGPTSUD1
Q ;
+1 KILL DGDMS,DGDOC,DGDX,DGEXP,DGLEV,DGLOS,DGNODE,DGNSV,DGNXD,DGPAS,DGPRD,DGPROC,DGPSV,DGPT,DGSURG,ICDSURG,DGTLOS,DGTRS,DG401P,I,I1,I2,J,L1,T,X,X1,X2,Y
QUIT
+2 ;
