DG53208P ;ALB/JDS - PATCH 208 POST INIT ; 11 NOV 1998
;;5.3;Registration;**208**;Aug 13, 1993
;
N DGI S DGI=$$NEWCP^XPDUTL("DGASIH","POST^DG53208P","")
Q
POST N A,B,DA,XPDIDTOT,ASIHTYP,DATE,DIK,PAT,DGI,DR,Y,DIE,DGEGL,DGRCDT
S DGEGL=+$G(^DG(43,1,"GL"))
S ASIHTYP=42,DGI=$$PARCP^XPDUTL("DGASIH"),XPDIDTOT=+$P($G(^DGPM(0)),U,4) S:DGI'>0 DGI=0 S DGRCDT=+$P(DGI,U,2),DGI=+DGI
D MES^XPDUTL("Checking for WHILE ASIH discharges incorrectly linked to an Admission")
F S DGI=$O(^DGPM(DGI)) Q:DGI'>0 S:('(DGI#100)) B=$$UPCP^XPDUTL("DGASIH",DGI_U_DGRCDT) D:('(DGI#100)) UPDATE^XPDID(DGI) I $P($G(^DGPM(DGI,0)),U,18)=ASIHTYP D
.S A=$G(^DGPM(DGI,0)) I $P($G(^DGPM(+$P(A,U,14),0)),U,17)=DGI Q
.S Y=+A D OLDEST(Y) X ^DD("DD") S DATE=Y S PAT=$P($G(^DPT(+$P(A,U,3),0)),U)
.N DGADM,DGDIS S DGADM=+$P($G(^DGPM(DGI,0)),U,14),DGDIS=+$P($G(^DGPM(+DGADM,0)),U,17)
.D MES^XPDUTL("Deleting Patient Movement number "_DGI_" "_DATE_" "_PAT)
.S DIK="^DGPM(",DA=DGI D ^DIK I $G(DGDIS) S DIE="^DGPM(",DR=".17////"_DGDIS,DA=DGADM D ^DIE
S Y=$P(DGRCDT,".") X ^DD("DD") D MES^XPDUTL($S(DGRCDT:"G&L should be recalculated back to "_Y,1:"G&L does not need to be recalculated")) H 5
Q
OLDEST(Y) ;get earliest date to recalculate
I Y<DGEGL Q
I Y<2981001 Q
I 'DGRCDT!(Y<DGRCDT) S DGRCDT=Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53208P 1290 printed Dec 13, 2024@02:36:37 Page 2
DG53208P ;ALB/JDS - PATCH 208 POST INIT ; 11 NOV 1998
+1 ;;5.3;Registration;**208**;Aug 13, 1993
+2 ;
+3 NEW DGI
SET DGI=$$NEWCP^XPDUTL("DGASIH","POST^DG53208P","")
+4 QUIT
POST NEW A,B,DA,XPDIDTOT,ASIHTYP,DATE,DIK,PAT,DGI,DR,Y,DIE,DGEGL,DGRCDT
+1 SET DGEGL=+$GET(^DG(43,1,"GL"))
+2 SET ASIHTYP=42
SET DGI=$$PARCP^XPDUTL("DGASIH")
SET XPDIDTOT=+$PIECE($GET(^DGPM(0)),U,4)
if DGI'>0
SET DGI=0
SET DGRCDT=+$PIECE(DGI,U,2)
SET DGI=+DGI
+3 DO MES^XPDUTL("Checking for WHILE ASIH discharges incorrectly linked to an Admission")
+4 FOR
SET DGI=$ORDER(^DGPM(DGI))
if DGI'>0
QUIT
if ('(DGI#100))
SET B=$$UPCP^XPDUTL("DGASIH",DGI_U_DGRCDT)
if ('(DGI#100))
DO UPDATE^XPDID(DGI)
IF $PIECE($GET(^DGPM(DGI,0)),U,18)=ASIHTYP
Begin DoDot:1
+5 SET A=$GET(^DGPM(DGI,0))
IF $PIECE($GET(^DGPM(+$PIECE(A,U,14),0)),U,17)=DGI
QUIT
+6 SET Y=+A
DO OLDEST(Y)
XECUTE ^DD("DD")
SET DATE=Y
SET PAT=$PIECE($GET(^DPT(+$PIECE(A,U,3),0)),U)
+7 NEW DGADM,DGDIS
SET DGADM=+$PIECE($GET(^DGPM(DGI,0)),U,14)
SET DGDIS=+$PIECE($GET(^DGPM(+DGADM,0)),U,17)
+8 DO MES^XPDUTL("Deleting Patient Movement number "_DGI_" "_DATE_" "_PAT)
+9 SET DIK="^DGPM("
SET DA=DGI
DO ^DIK
IF $GET(DGDIS)
SET DIE="^DGPM("
SET DR=".17////"_DGDIS
SET DA=DGADM
DO ^DIE
End DoDot:1
+10 SET Y=$PIECE(DGRCDT,".")
XECUTE ^DD("DD")
DO MES^XPDUTL($SELECT(DGRCDT:"G&L should be recalculated back to "_Y,1:"G&L does not need to be recalculated"))
HANG 5
+11 QUIT
OLDEST(Y) ;get earliest date to recalculate
+1 IF Y<DGEGL
QUIT
+2 IF Y<2981001
QUIT
+3 IF 'DGRCDT!(Y<DGRCDT)
SET DGRCDT=Y
