DGPTSUDO ;ALB/MTC,HIOFO/FT,WOIFO/PMK - PTF UPDATE TRANSFER DRG NODE ;6/2/15 11:27am
;;5.3;Registration;**441,510,478,785,850,884**;Aug 13, 1993;Build 31
;;ADL;Update for CSV Project;;Mar 28, 2003
;
; ICDXCODE APIs - #5699
; ^VA(200) reads - #10060
;
UTIL S ^UTILITY($J,"T",(9999999.9999999-I))=K_"^"_$S($D(^DIC(45.7,J,0)):$P(^(0),"^",2),1:0)_"^"_X_"^^"_$P(Y,"^",8)
Q
SUDO1 ;
N DGPOA,DGDXPOA
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 ;^(J,0) on next line references global on this line
.. 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)
S (DGDX,DGNSV,DGPSV,DGPOA,DGDXPOA)=""
N EFFDATE,DGTEMP,IMPDATE
D EFFDATE^DGPTIC10(PTF) S DGDAT=EFFDATE
K DGSURG,DGPROC S (DGSURG,DGPROC)=U
;
;-- build DGSURG array
F I=0:0 S I=$O(^DGPT(PTF,"S",I)) Q:I'>0 D
. K DG401
. D PTFICD^DGPTFUT(401,PTF,I,.DG401)
. Q:'$O(DG401(0))
. ;S Y=+$P(DG401,U,16),Y=$S('$D(DGSURG(Y)):Y,Y[".":Y_I_1,1:Y_".0000"_I_1),DGSURG(Y)=""
. S Y=I/100000000+$P(DG401,U,16),DGSURG(Y)=""
. S DGLOOP=0
. F S DGLOOP=$O(DG401(DGLOOP)) Q:'DGLOOP D
.. Q:$P(DG401(DGLOOP),U,1)=""
.. S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",$P(DG401(DGLOOP),U,1),EFFDATE)
.. I +DGPTTMP>0 S DGSURG(Y)=DGSURG(Y)_$P(DG401(DGLOOP),U,1)_U
K DG401,DGLOOP
;
;-- build DGPROC array
F I=0:0 S I=$O(^DGPT(PTF,"P",I)) Q:I'>0 D
. K DG601
. D PTFICD^DGPTFUT(601,PTF,I,.DG601)
. Q:'$O(DG601(0))
. ;S Y=+$P(DG601,U,16),Y=$S('$D(DGPROC(Y)):Y,Y[".":Y_I_1,1:Y_".0000"_I_1),DGPROC(Y)=""
. S Y=I/100000000+$P(DG601,U,16),DGPROC(Y)=""
. S DGLOOP=0
. F S DGLOOP=$O(DG601(DGLOOP)) Q:'DGLOOP D
.. Q:$P(DG601(DGLOOP),U,1)=""
.. S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",$P(DG601(DGLOOP),U,1),EFFDATE)
.. I +DGPTTMP>0 S DGPROC(Y)=DGPROC(Y)_$P(DG601(DGLOOP),U,1)_U
K DG601,DGLOOP
;
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=$$ICDDATA^ICDXCODE("PROC",$P(X,U,I),EFFDATE) I +EFFDATE>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)) D
. S DGNODE=^(0) ;^(0) references global on line above
. D BLD I DGPSV'=DGNSV D DRG S DGSURG=U,DGDX="",DGDXPOA="",DGLOS=0 I '$D(DG401P) S DGPROC=U
SWCH ;
K DGLEV,DGPAS
S DGPRD=DGNXD,T(DGPRD)=T(DGNXD),(DGNSV,DGPSV)=""
G SUDO2
;
BLD ;
D PTFICD^DGPTFUT(501,PTF,I1,.DG501)
QUIT:'$O(DG501(0))
S DGLOOP=0 F S DGLOOP=$O(DG501(DGLOOP)) Q:'DGLOOP D
. I $P(DGNODE,U,1)]"" S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",$P(DG501(DGLOOP),U,1),EFFDATE) I +DGPTTMP>0 S DGDX=DGDX_$P(DG501(DGLOOP),U,1)_U,DGDXPOA=DGDXPOA_$P(DG501(DGLOOP),U,2)_U
K DG501,DGLOOP
;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 X=DGPROC(I)
.F J=1:1:25 S Y=$P(X,U,J) Q:Y="" D
..;Q:$L(DGPROC)>240 ; - no longer needed
..S Z=U_Y_U
..S DGPROC=DGPROC_Y_U
..S DGPROC(J)=Y
..K DGPROC(I)
Q
SU ;
I I<DGNXD!(DGPSV=DGNSV)!(DGPSV="S") D
.S X=DGSURG(I)
.F J=1:1:25 S Y=$P(X,U,J) Q:Y="" D
..;Q:$L(DGSURG)>240 ; - no longer needed
..S Z=U_Y_U
..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 ;transfer drg
S DGFDA(45.02,I1_","_PTF_",",21)=DGPSV ;losing service
S DGFDA(45.02,I1_","_PTF_",",22)=DGNXD ;transfer date
S DGFDA(45.02,I1_","_PTF_",",23)=DGLOS ;los in service
S DGFDA(45.02,I1_","_PTF_",",24)=DGDOC ;provider
S DGFDA(45.02,I1_","_PTF_",",25)=DGTLOS ;cumulative los
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:""),I1=1
D BLD
I $D(^DGPT("AADA",DGADM,PTF)) F I=10,11 I $P(DGPT(70),U,I) S DGDX=$P(DGPT(70),U,I)_U_DGDX,DGDXPOA=$P($G(^DGPT(PTF,82)),U)_U_$G(DGDXPOA) QUIT
D DRG,^DGPTSUD1
Q ;
K DGDMS,DGDOC,DGDX,DGEXP,DGLEV,DGLOS,DGNODE,DGNSV,DGNXD,DGPAS,DGPRD,DGPROC,DGPSV,DGPT,DGSURG,ICDSURG,DGTLOS,DGTRS,DG401P,DGDXPOA,I,I1,I2,J,L1,T,X,X1,X2,Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTSUDO 5342 printed Sep 23, 2025@20:29:32 Page 2
DGPTSUDO ;ALB/MTC,HIOFO/FT,WOIFO/PMK - PTF UPDATE TRANSFER DRG NODE ;6/2/15 11:27am
+1 ;;5.3;Registration;**441,510,478,785,850,884**;Aug 13, 1993;Build 31
+2 ;;ADL;Update for CSV Project;;Mar 28, 2003
+3 ;
+4 ; ICDXCODE APIs - #5699
+5 ; ^VA(200) reads - #10060
+6 ;
UTIL SET ^UTILITY($JOB,"T",(9999999.9999999-I))=K_"^"_$SELECT($DATA(^DIC(45.7,J,0)):$PIECE(^(0),"^",2),1:0)_"^"_X_"^^"_$PIECE(Y,"^",8)
+1 QUIT
SUDO1 ;
+1 NEW DGPOA,DGDXPOA
+2 KILL ^UTILITY($JOB,"T"),T
+3 FOR I=0:0
SET I=$ORDER(^DGPM("ATS",DFN,DGPMCA,I))
if I'>0
QUIT
Begin DoDot:1
+4 ;^(J,0) on next line references global on this line
SET J=$ORDER(^DGPM("ATS",DFN,DGPMCA,I,0))
IF J
Begin DoDot:2
+5 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
+6 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)
+2 SET (DGDX,DGNSV,DGPSV,DGPOA,DGDXPOA)=""
+3 NEW EFFDATE,DGTEMP,IMPDATE
+4 DO EFFDATE^DGPTIC10(PTF)
SET DGDAT=EFFDATE
+5 KILL DGSURG,DGPROC
SET (DGSURG,DGPROC)=U
+6 ;
+7 ;-- build DGSURG array
+8 FOR I=0:0
SET I=$ORDER(^DGPT(PTF,"S",I))
if I'>0
QUIT
Begin DoDot:1
+9 KILL DG401
+10 DO PTFICD^DGPTFUT(401,PTF,I,.DG401)
+11 if '$ORDER(DG401(0))
QUIT
+12 ;S Y=+$P(DG401,U,16),Y=$S('$D(DGSURG(Y)):Y,Y[".":Y_I_1,1:Y_".0000"_I_1),DGSURG(Y)=""
+13 SET Y=I/100000000+$PIECE(DG401,U,16)
SET DGSURG(Y)=""
+14 SET DGLOOP=0
+15 FOR
SET DGLOOP=$ORDER(DG401(DGLOOP))
if 'DGLOOP
QUIT
Begin DoDot:2
+16 if $PIECE(DG401(DGLOOP),U,1)=""
QUIT
+17 SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",$PIECE(DG401(DGLOOP),U,1),EFFDATE)
+18 IF +DGPTTMP>0
SET DGSURG(Y)=DGSURG(Y)_$PIECE(DG401(DGLOOP),U,1)_U
End DoDot:2
End DoDot:1
+19 KILL DG401,DGLOOP
+20 ;
+21 ;-- build DGPROC array
+22 FOR I=0:0
SET I=$ORDER(^DGPT(PTF,"P",I))
if I'>0
QUIT
Begin DoDot:1
+23 KILL DG601
+24 DO PTFICD^DGPTFUT(601,PTF,I,.DG601)
+25 if '$ORDER(DG601(0))
QUIT
+26 ;S Y=+$P(DG601,U,16),Y=$S('$D(DGPROC(Y)):Y,Y[".":Y_I_1,1:Y_".0000"_I_1),DGPROC(Y)=""
+27 SET Y=I/100000000+$PIECE(DG601,U,16)
SET DGPROC(Y)=""
+28 SET DGLOOP=0
+29 FOR
SET DGLOOP=$ORDER(DG601(DGLOOP))
if 'DGLOOP
QUIT
Begin DoDot:2
+30 if $PIECE(DG601(DGLOOP),U,1)=""
QUIT
+31 SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",$PIECE(DG601(DGLOOP),U,1),EFFDATE)
+32 IF +DGPTTMP>0
SET DGPROC(Y)=DGPROC(Y)_$PIECE(DG601(DGLOOP),U,1)_U
End DoDot:2
End DoDot:1
+33 KILL DG601,DGLOOP
+34 ;
+35 IF $DATA(^DGPT(PTF,"401P"))
IF +DGPT(70)
IF +DGPT(70)<2871000
SET X=^("401P")
IF X]""
IF X'="^^^^"
Begin DoDot:1
+36 FOR I=1:1:5
IF $PIECE(X,U,I)]""
SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",$PIECE(X,U,I),EFFDATE)
IF +EFFDATE>0
SET DGPROC=DGPROC_$PIECE(X,U,I)_U
SET DG401P=1
End DoDot:1
+37 ;
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))
Begin DoDot:1
+8 ;^(0) references global on line above
SET DGNODE=^(0)
+9 DO BLD
IF DGPSV'=DGNSV
DO DRG
SET DGSURG=U
SET DGDX=""
SET DGDXPOA=""
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 DO PTFICD^DGPTFUT(501,PTF,I1,.DG501)
+2 if '$ORDER(DG501(0))
QUIT
+3 SET DGLOOP=0
FOR
SET DGLOOP=$ORDER(DG501(DGLOOP))
if 'DGLOOP
QUIT
Begin DoDot:1
+4 IF $PIECE(DGNODE,U,1)]""
SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",$PIECE(DG501(DGLOOP),U,1),EFFDATE)
IF +DGPTTMP>0
SET DGDX=DGDX_$PIECE(DG501(DGLOOP),U,1)_U
SET DGDXPOA=DGDXPOA_$PIECE(DG501(DGLOOP),U,2)_U
End DoDot:1
+5 KILL DG501,DGLOOP
+6 ;S:$L(DGDX)>200 DGDX=$P(DGDX,U,1,30)
+7 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
+8 NEW I,J,X,Y,Z
+9 FOR I=0:0
SET I=$ORDER(DGSURG(I))
if I'>0!(I\1>(DGNXD\1))
QUIT
DO SU
+10 IF '$DATA(DG401P)
FOR I=0:0
SET I=$ORDER(DGPROC(I))
if I'>0!((I\1)>(DGNXD\1))
QUIT
Begin DoDot:1
+11 SET X=DGPROC(I)
+12 FOR J=1:1:25
SET Y=$PIECE(X,U,J)
if Y=""
QUIT
Begin DoDot:2
+13 ;Q:$L(DGPROC)>240 ; - no longer needed
+14 SET Z=U_Y_U
+15 SET DGPROC=DGPROC_Y_U
+16 SET DGPROC(J)=Y
+17 KILL DGPROC(I)
End DoDot:2
End DoDot:1
+18 QUIT
SU ;
+1 IF I<DGNXD!(DGPSV=DGNSV)!(DGPSV="S")
Begin DoDot:1
+2 SET X=DGSURG(I)
+3 FOR J=1:1:25
SET Y=$PIECE(X,U,J)
if Y=""
QUIT
Begin DoDot:2
+4 ;Q:$L(DGSURG)>240 ; - no longer needed
+5 SET Z=U_Y_U
+6 SET DGSURG=DGSURG_Y_U
+7 SET ICDSURG(J)=Y
+8 KILL DGSURG(I)
End DoDot:2
End DoDot:1
+9 QUIT
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 ;transfer drg
SET DGFDA(45.02,I1_","_PTF_",",20)=DRG
+6 ;losing service
SET DGFDA(45.02,I1_","_PTF_",",21)=DGPSV
+7 ;transfer date
SET DGFDA(45.02,I1_","_PTF_",",22)=DGNXD
+8 ;los in service
SET DGFDA(45.02,I1_","_PTF_",",23)=DGLOS
+9 ;provider
SET DGFDA(45.02,I1_","_PTF_",",24)=DGDOC
+10 ;cumulative los
SET DGFDA(45.02,I1_","_PTF_",",25)=DGTLOS
+11 DO FILE^DIE("","DGFDA","DGMSG")
+12 QUIT
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:"")
SET I1=1
+5 DO BLD
+6 IF $DATA(^DGPT("AADA",DGADM,PTF))
FOR I=10,11
IF $PIECE(DGPT(70),U,I)
SET DGDX=$PIECE(DGPT(70),U,I)_U_DGDX
SET DGDXPOA=$PIECE($GET(^DGPT(PTF,82)),U)_U_$GET(DGDXPOA)
QUIT
+7 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,DGDXPOA,I,I1,I2,J,L1,T,X,X1,X2,Y
+2 QUIT
