- 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 Jan 18, 2025@03:37:20 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