DGPTSUD1 ;ALB/AS/ADL - Look for the same DRG in consecutive RAM movements ; Feb 23 87
;;5.3;Registration;**510,478**;Aug 13, 1993
;;ADL;Update for CSV Project;;Mar 27, 2003
;
;called from ONE+2^DGPTSUDO
F I=0:0 S I=$O(^DGPT(PTF,"M",I)) Q:I'>0 I $D(^DGPT(PTF,"M",I,"P")) S DGNODE=^("P"),DGSUDO(+$P(DGNODE,"^",3))=I_"^"_$P(DGNODE,"^",1)
G Q:'$D(DGSUDO) S (DGSUNX,DGSUPR)=$O(DGSUDO(0)) F XX=0:0 S DGSUNX=$O(DGSUDO(DGSUPR)) Q:DGSUNX'>0 D SAME
Q K DGSUPR,DGSUNX,DGNODE,DGSUDO,DG1,DG2,DGMV1,DGMV2,DGSUB,DGSUR,DGSURDT,%,I,J,X1,X2 Q
SAME I $P(DGSUDO(DGSUPR),"^",2)']""!($P(DGSUDO(DGSUPR),"^",2)'=$P(DGSUDO(DGSUNX),"^",2)) S DGSUPR=DGSUNX Q
S DG1=+$P(DGSUDO(DGSUPR),"^",1),DG2=+$P(DGSUDO(DGSUNX),"^",1),DGMV1=$S($D(^DGPT(PTF,"M",+DG1,"P")):^("P"),1:""),DGMV2=$S($D(^DGPT(PTF,"M",+DG2,"P")):^("P"),1:"")
;Fiscal year 89 discharges are checked for a surgery performed while on Surgery Service if the DRG is a surgical DRG
G 88:'$P($$DRG^ICDGTDRG($P(DGSUDO(DGSUNX),"^",2),$$GETDATE^ICDGTDRG(PTF)),"^",6)
I $D(^DGPT(PTF,70)),$P(^DGPT(PTF,70),"^",1)<2881000 G 88
I $P(DGMV1,"^",2)'="S"&($P(DGMV2,"^",2)'="S") G 88
I $P(DGMV1,"^",2)="S" S I=DGADM F J=0:0 S J=$O(DGSUDO(J)) Q:J=DGSUPR!(J'>0) S I=J
S X1=$S($P(DGMV1,"^",2)="S":I,1:DGSUPR),X2=$S($P(DGMV1,"^",2)="S":DGSUPR,1:DGSUNX),X1=$P(X1,".",1),X2=$P(X2,".",1)_.99,DGSUR=0
F I=0:0 S I=$O(^DGPT(PTF,"S",I)) Q:I'>0 S DGSURDT=$S($D(^DGPT(PTF,"S",I,0)):+^(0),1:9999999) I X1<DGSURDT&(DGSURDT<X2) S DGSUR=1 Q
I DGSUR S DGSUB=$S($P(DGMV1,"^",2)="S":DG1,1:DG2) G KILL
88 S DGSUB=$S($P(DGMV1,"^",4)>$P(DGMV2,"^",4):DG1,1:DG2)
KILL N DGFDA,DGMSG,FLD
S DGFDA(45.02,DGSUB_","_PTF_",",23)=$P(DGMV1,"^",4)+$P(DGMV2,"^",4)
D FILE^DIE("","DGFDA","DGMSG")
I DGSUB=DG1 D Q
.K DGFDA,DGMSG
.S DGFDA(45.02,DG1_","_PTF_",",25)=$P(DGMV2,"^",6)
.D FILE^DIE("","DGFDA","DGMSG")
.K DGFDA,DGMSG
.F FLD=20:1:25 S DGFDA(45.02,DG2_","_PTF_",",FLD)="@"
.D FILE^DIE("","DGFDA","DGMSG")
.K DGSUDO(DGSUNX)
K DGFDA,DGMSG
F FLD=20:1:25 S DGFDA(45.02,DG1_","_PTF_",",FLD)="@"
D FILE^DIE("","DGFDA","DGMSG")
K DGSUDO(DGSUPR)
S DGSUPR=DGSUNX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTSUD1 2114 printed Dec 13, 2024@02:53:38 Page 2
DGPTSUD1 ;ALB/AS/ADL - Look for the same DRG in consecutive RAM movements ; Feb 23 87
+1 ;;5.3;Registration;**510,478**;Aug 13, 1993
+2 ;;ADL;Update for CSV Project;;Mar 27, 2003
+3 ;
+4 ;called from ONE+2^DGPTSUDO
+5 FOR I=0:0
SET I=$ORDER(^DGPT(PTF,"M",I))
if I'>0
QUIT
IF $DATA(^DGPT(PTF,"M",I,"P"))
SET DGNODE=^("P")
SET DGSUDO(+$PIECE(DGNODE,"^",3))=I_"^"_$PIECE(DGNODE,"^",1)
+6 if '$DATA(DGSUDO)
GOTO Q
SET (DGSUNX,DGSUPR)=$ORDER(DGSUDO(0))
FOR XX=0:0
SET DGSUNX=$ORDER(DGSUDO(DGSUPR))
if DGSUNX'>0
QUIT
DO SAME
Q KILL DGSUPR,DGSUNX,DGNODE,DGSUDO,DG1,DG2,DGMV1,DGMV2,DGSUB,DGSUR,DGSURDT,%,I,J,X1,X2
QUIT
SAME IF $PIECE(DGSUDO(DGSUPR),"^",2)']""!($PIECE(DGSUDO(DGSUPR),"^",2)'=$PIECE(DGSUDO(DGSUNX),"^",2))
SET DGSUPR=DGSUNX
QUIT
+1 SET DG1=+$PIECE(DGSUDO(DGSUPR),"^",1)
SET DG2=+$PIECE(DGSUDO(DGSUNX),"^",1)
SET DGMV1=$SELECT($DATA(^DGPT(PTF,"M",+DG1,"P")):^("P"),1:"")
SET DGMV2=$SELECT($DATA(^DGPT(PTF,"M",+DG2,"P")):^("P"),1:"")
+2 ;Fiscal year 89 discharges are checked for a surgery performed while on Surgery Service if the DRG is a surgical DRG
+3 if '$PIECE($$DRG^ICDGTDRG($PIECE(DGSUDO(DGSUNX),"^",2),$$GETDATE^ICDGTDRG(PTF)),"^",6)
GOTO 88
+4 IF $DATA(^DGPT(PTF,70))
IF $PIECE(^DGPT(PTF,70),"^",1)<2881000
GOTO 88
+5 IF $PIECE(DGMV1,"^",2)'="S"&($PIECE(DGMV2,"^",2)'="S")
GOTO 88
+6 IF $PIECE(DGMV1,"^",2)="S"
SET I=DGADM
FOR J=0:0
SET J=$ORDER(DGSUDO(J))
if J=DGSUPR!(J'>0)
QUIT
SET I=J
+7 SET X1=$SELECT($PIECE(DGMV1,"^",2)="S":I,1:DGSUPR)
SET X2=$SELECT($PIECE(DGMV1,"^",2)="S":DGSUPR,1:DGSUNX)
SET X1=$PIECE(X1,".",1)
SET X2=$PIECE(X2,".",1)_.99
SET DGSUR=0
+8 FOR I=0:0
SET I=$ORDER(^DGPT(PTF,"S",I))
if I'>0
QUIT
SET DGSURDT=$SELECT($DATA(^DGPT(PTF,"S",I,0)):+^(0),1:9999999)
IF X1<DGSURDT&(DGSURDT<X2)
SET DGSUR=1
QUIT
+9 IF DGSUR
SET DGSUB=$SELECT($PIECE(DGMV1,"^",2)="S":DG1,1:DG2)
GOTO KILL
88 SET DGSUB=$SELECT($PIECE(DGMV1,"^",4)>$PIECE(DGMV2,"^",4):DG1,1:DG2)
KILL NEW DGFDA,DGMSG,FLD
+1 SET DGFDA(45.02,DGSUB_","_PTF_",",23)=$PIECE(DGMV1,"^",4)+$PIECE(DGMV2,"^",4)
+2 DO FILE^DIE("","DGFDA","DGMSG")
+3 IF DGSUB=DG1
Begin DoDot:1
+4 KILL DGFDA,DGMSG
+5 SET DGFDA(45.02,DG1_","_PTF_",",25)=$PIECE(DGMV2,"^",6)
+6 DO FILE^DIE("","DGFDA","DGMSG")
+7 KILL DGFDA,DGMSG
+8 FOR FLD=20:1:25
SET DGFDA(45.02,DG2_","_PTF_",",FLD)="@"
+9 DO FILE^DIE("","DGFDA","DGMSG")
+10 KILL DGSUDO(DGSUNX)
End DoDot:1
QUIT
+11 KILL DGFDA,DGMSG
+12 FOR FLD=20:1:25
SET DGFDA(45.02,DG1_","_PTF_",",FLD)="@"
+13 DO FILE^DIE("","DGFDA","DGMSG")
+14 KILL DGSUDO(DGSUPR)
+15 SET DGSUPR=DGSUNX
+16 QUIT
