DGPTFUP ;ALB/ABS,BOK - Updates Means Test, LOS, TRANSFER DRGs in PTF records ; 3/28/02 11:54am
;;5.3;Registration;**441,478**;Aug 13, 1993
ACTIVE ;this call should be queued to run nightly to update the LOS in active admission PTF records and the Means Test Indicator in Open PTF records
D NOW^%DTC S DT=X,U="^",(DGBGJ,DGLN)=1
F PTF=0:0 S PTF=$O(^DGPT("AS",0,PTF)) Q:PTF'>0 I $D(^DGPT(PTF,0)),$P(^(0),U,11)=1 S DFN=+^(0),DGADM=$P(^(0),U,2),DGPMCA=$O(^DGPM("APTT1",DFN,DGADM,0)),DGPMAN=$S($D(^DGPM(+DGPMCA,0)):^(0),1:"") I DGPMAN D:DGADM>2860700 MT^DGPTUTL D LOS
K DGADM,DGADIFN,PTF,DFN,DGLEAVE,DGMV,DGMVDT,DGPASS,DGTOT,DGTYPE,X,X1,X2,DGCUM,DGMT,DGBGJ,DGLN,DGPMAN,DGPMCA Q
LOS Q:'$D(^DGPT("AADA",DGADM,PTF))!('$D(^DGPT(PTF,"M",1,0))) I '$D(^DGPT(PTF,"M",1,"P")) S ^DGPT(PTF,"M",1,"P")=""
S DGMVDT=1,DGCUM=0 F X=1:0 S X=$O(^DGPT(PTF,"M",X)) Q:X'>0 I $D(^(X,"P")),$P(^("P"),"^",3)>DGMVDT S DGMVDT=$P(^("P"),"^",3),DGCUM=$P(^("P"),"^",6)
I DGMVDT'>1 S DGMVDT=DGADM
S (DGLEAVE,DGPASS)=0,X1=DT,X2=DGMVDT D ^%DTC S DGTOT=$S(X>0:X,1:1)
F DGMV=(DGMVDT-.1):0 S DGMV=$O(^DGPM("APTT2",DFN,DGMV)) Q:DGMV'>0 S X=$O(^DGPM("APTT2",DFN,DGMV,0)) I $S('$D(^DGPM(+X,0)):0,$P(^(0),"^",14)=DGPMCA:1,1:0) S DGTYPE=+$P(^(0),"^",18) I DGTYPE=1!(DGTYPE=2)!(DGTYPE=3) D ABSENT
S DGTOT=DGTOT-DGPASS-DGLEAVE
N DGFDA,DGMSG
S DGFDA(45.02,1_","_PTF_",",23)=DGTOT
S DGFDA(45.02,1_","_PTF_",",25)=DGTOT+DGCUM
D FILE^DIE("","DGFDA","DGMSG")
Q
ABSENT S X2=DGMV,X=$O(^DGPM("APTT2",DFN,DGMV)),X1=$S(X>0:X,1:DT) D ^%DTC I DGTYPE=1 S DGPASS=DGPASS+X Q
S DGLEAVE=DGLEAVE+X Q
;
;ADDING TRANSFER DRGs
ALL D DT^DICRW S U="^" W !?5,"===> PTF TRANSFER DRG update beginning..."
F PTF=0:0 S PTF=$O(^DGPT(PTF)) Q:PTF'>0 D UPDATE
G Q
;
SOME ;
W !!?2,"This option will recalculate the TRANSFER DRG's for all",!?2,"current fiscal year PTF records."
W !!?2,"Do you want to continue" S %=2 D YN^DICN Q:%=-1!(%=2)
I '% W !?2,"Answer 'YES' to begin recalculation or 'NO' to stop." G SOME
W !?5,"===> PTF partial TRANSFER DRG update beginning with "
W !?5," discharge dates for the current fiscal year..."
;
D DT^DICRW S U="^",DGFYDT=$S($E(DT,4,5)<10:($E(DT,1,3)-1),1:$E(DT,1,3))_1000
N DGD1SAV
F DGXREF="ADS","AADA" S DGD1SAV=0 F DGD1=$S(DGXREF="ADS":DGFYDT,1:0):0 S DGD1=$O(^DGPT(DGXREF,DGD1)) Q:'DGD1 Q:DGD1<DGD1SAV F PTF=0:0 S PTF=$O(^DGPT(DGXREF,DGD1,PTF)) Q:'PTF D UPDATE
Q W !!?5,"===> PTF TRANSFER DRG update complete"
K PTF,DGD1,DGFYDT,DGXREF Q
;
UPDATE ; -- update xfr drg's for PTF ifn
S DGD1SAV=DGD1
G UPDATEQ:'$D(^DGPT(PTF,0)) S DGNODE=^(0)
G UPDATEQ:$S($P(DGNODE,"^",11)>1:1,1:$P(DGNODE,"^",4))
D PM^DGPTUTL G UPDATEQ:'DGPMCA
K DGTDD,DGPRD,DGNXD F I=0:0 S I=$O(^DGPT(PTF,"M",I)) Q:I'>0 D
.N FLD,DGFDA,DGMSG
.F FLD=20:1:25 S DGFDA(45.02,I_","_PTF_",",FLD)="@"
.D FILE^DIE("","DGFDA","DGMSG")
S DFN=+DGNODE,DGADM=+$P(DGNODE,U,2)
D SUDO1^DGPTSUDO
W:'(PTF#300) !," TRANSFER DRG update in progress...on IFN ",PTF
UPDATEQ K DGPMCA,DGPMAN,DGNODE,DGADM,DFN Q
;
ZERO ;LOOK FOR MISSING 0 NODE IN 501 MULTIPLE
D LO^DGUTL F I=0:0 S I=$O(^DGPT(I)) Q:I'>0 S:'$D(^DGPT(I,0)) ^DGPT(I,0)="" I $D(^DGPT(I,"M")),'$D(^("M",0)) S ^(0)="^45.02AI"
K I Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFUP 3205 printed Sep 23, 2025@20:28:31 Page 2
DGPTFUP ;ALB/ABS,BOK - Updates Means Test, LOS, TRANSFER DRGs in PTF records ; 3/28/02 11:54am
+1 ;;5.3;Registration;**441,478**;Aug 13, 1993
ACTIVE ;this call should be queued to run nightly to update the LOS in active admission PTF records and the Means Test Indicator in Open PTF records
+1 DO NOW^%DTC
SET DT=X
SET U="^"
SET (DGBGJ,DGLN)=1
+2 FOR PTF=0:0
SET PTF=$ORDER(^DGPT("AS",0,PTF))
if PTF'>0
QUIT
IF $DATA(^DGPT(PTF,0))
IF $PIECE(^(0),U,11)=1
SET DFN=+^(0)
SET DGADM=$PIECE(^(0),U,2)
SET DGPMCA=$ORDER(^DGPM("APTT1",DFN,DGADM,0))
SET DGPMAN=$SELECT($DATA(^DGPM(+DGPMCA,0)):^(0),1:"")
IF DGPMAN
if DGADM>2860700
DO MT^DGPTUTL
DO LOS
+3 KILL DGADM,DGADIFN,PTF,DFN,DGLEAVE,DGMV,DGMVDT,DGPASS,DGTOT,DGTYPE,X,X1,X2,DGCUM,DGMT,DGBGJ,DGLN,DGPMAN,DGPMCA
QUIT
LOS if '$DATA(^DGPT("AADA",DGADM,PTF))!('$DATA(^DGPT(PTF,"M",1,0)))
QUIT
IF '$DATA(^DGPT(PTF,"M",1,"P"))
SET ^DGPT(PTF,"M",1,"P")=""
+1 SET DGMVDT=1
SET DGCUM=0
FOR X=1:0
SET X=$ORDER(^DGPT(PTF,"M",X))
if X'>0
QUIT
IF $DATA(^(X,"P"))
IF $PIECE(^("P"),"^",3)>DGMVDT
SET DGMVDT=$PIECE(^("P"),"^",3)
SET DGCUM=$PIECE(^("P"),"^",6)
+2 IF DGMVDT'>1
SET DGMVDT=DGADM
+3 SET (DGLEAVE,DGPASS)=0
SET X1=DT
SET X2=DGMVDT
DO ^%DTC
SET DGTOT=$SELECT(X>0:X,1:1)
+4 FOR DGMV=(DGMVDT-.1):0
SET DGMV=$ORDER(^DGPM("APTT2",DFN,DGMV))
if DGMV'>0
QUIT
SET X=$ORDER(^DGPM("APTT2",DFN,DGMV,0))
IF $SELECT('$DATA(^DGPM(+X,0)):0,$PIECE(^(0),"^",14)=DGPMCA:1,1:0)
SET DGTYPE=+$PIECE(^(0),"^",18)
IF DGTYPE=1!(DGTYPE=2)!(DGTYPE=3)
DO ABSENT
+5 SET DGTOT=DGTOT-DGPASS-DGLEAVE
+6 NEW DGFDA,DGMSG
+7 SET DGFDA(45.02,1_","_PTF_",",23)=DGTOT
+8 SET DGFDA(45.02,1_","_PTF_",",25)=DGTOT+DGCUM
+9 DO FILE^DIE("","DGFDA","DGMSG")
+10 QUIT
ABSENT SET X2=DGMV
SET X=$ORDER(^DGPM("APTT2",DFN,DGMV))
SET X1=$SELECT(X>0:X,1:DT)
DO ^%DTC
IF DGTYPE=1
SET DGPASS=DGPASS+X
QUIT
+1 SET DGLEAVE=DGLEAVE+X
QUIT
+2 ;
+3 ;ADDING TRANSFER DRGs
ALL DO DT^DICRW
SET U="^"
WRITE !?5,"===> PTF TRANSFER DRG update beginning..."
+1 FOR PTF=0:0
SET PTF=$ORDER(^DGPT(PTF))
if PTF'>0
QUIT
DO UPDATE
+2 GOTO Q
+3 ;
SOME ;
+1 WRITE !!?2,"This option will recalculate the TRANSFER DRG's for all",!?2,"current fiscal year PTF records."
+2 WRITE !!?2,"Do you want to continue"
SET %=2
DO YN^DICN
if %=-1!(%=2)
QUIT
+3 IF '%
WRITE !?2,"Answer 'YES' to begin recalculation or 'NO' to stop."
GOTO SOME
+4 WRITE !?5,"===> PTF partial TRANSFER DRG update beginning with "
+5 WRITE !?5," discharge dates for the current fiscal year..."
+6 ;
+7 DO DT^DICRW
SET U="^"
SET DGFYDT=$SELECT($EXTRACT(DT,4,5)<10:($EXTRACT(DT,1,3)-1),1:$EXTRACT(DT,1,3))_1000
+8 NEW DGD1SAV
+9 FOR DGXREF="ADS","AADA"
SET DGD1SAV=0
FOR DGD1=$SELECT(DGXREF="ADS":DGFYDT,1:0):0
SET DGD1=$ORDER(^DGPT(DGXREF,DGD1))
if 'DGD1
QUIT
if DGD1<DGD1SAV
QUIT
FOR PTF=0:0
SET PTF=$ORDER(^DGPT(DGXREF,DGD1,PTF))
if 'PTF
QUIT
DO UPDATE
Q WRITE !!?5,"===> PTF TRANSFER DRG update complete"
+1 KILL PTF,DGD1,DGFYDT,DGXREF
QUIT
+2 ;
UPDATE ; -- update xfr drg's for PTF ifn
+1 SET DGD1SAV=DGD1
+2 if '$DATA(^DGPT(PTF,0))
GOTO UPDATEQ
SET DGNODE=^(0)
+3 if $SELECT($PIECE(DGNODE,"^",11)>1:1,1:$PIECE(DGNODE,"^",4))
GOTO UPDATEQ
+4 DO PM^DGPTUTL
if 'DGPMCA
GOTO UPDATEQ
+5 KILL DGTDD,DGPRD,DGNXD
FOR I=0:0
SET I=$ORDER(^DGPT(PTF,"M",I))
if I'>0
QUIT
Begin DoDot:1
+6 NEW FLD,DGFDA,DGMSG
+7 FOR FLD=20:1:25
SET DGFDA(45.02,I_","_PTF_",",FLD)="@"
+8 DO FILE^DIE("","DGFDA","DGMSG")
End DoDot:1
+9 SET DFN=+DGNODE
SET DGADM=+$PIECE(DGNODE,U,2)
+10 DO SUDO1^DGPTSUDO
+11 if '(PTF#300)
WRITE !," TRANSFER DRG update in progress...on IFN ",PTF
UPDATEQ KILL DGPMCA,DGPMAN,DGNODE,DGADM,DFN
QUIT
+1 ;
ZERO ;LOOK FOR MISSING 0 NODE IN 501 MULTIPLE
+1 DO LO^DGUTL
FOR I=0:0
SET I=$ORDER(^DGPT(I))
if I'>0
QUIT
if '$DATA(^DGPT(I,0))
SET ^DGPT(I,0)=""
IF $DATA(^DGPT(I,"M"))
IF '$DATA(^("M",0))
SET ^(0)="^45.02AI"
+2 KILL I
QUIT
