DG53208P.m

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 ---DG53208P   1290     printed  Apr 09, 2024@22:05:22                                                                                                                                                                                                    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