Routine: DG5385PT

DG5385PT ;ALB/ABR -POST-INIT TS CLEANUP FOR PATCH 85 ; 4/10/96

 ;;5.3;Registration;**85**;Aug 13, 1993

 ;Variables:

 ;  DGI = Division

 ;  DGJ = Treating Specialty

 ;  DGK = Census Date

 ;  DGX = Kill flag

 ;  DGY = # of days since previous TS census entry

POST ; entry point for post-install  - set up checkpoints

N %

 S %=$$NEWCP^XPDUTL("DGTSI","EN^DG5385PT",0) ; call-back routine for KIDS

 S %=$$NEWCP^XPDUTL("DGTSJ"),%=$$NEWCP^XPDUTL("DGTSK")

EN ;

 N DGI,DGJ,DGK,DGK1,DGX,DGY,%

 D BMES^XPDUTL(" >>Treating Specialty Census clean-up")

 ; retrieve values in checkpoints, step back for $O function

 S DGI=+$$PARCP^XPDUTL("DGTSI"),DGJ=+$$PARCP^XPDUTL("DGTSJ"),DGK=+$$PARCP^XPDUTL("DGTSK")

 I DGK,'+$G(^DG(40.8,DGI,"TS",DGJ,"C",DGK,0)) S DGK=DGK-.001

 S:DGI DGI=DGI-.001 S:DGJ DGJ=DGJ-.001 ; if post-install has previously started, set DGI and DGJ back, so that $O will return values at time of failure

LOOP ; step thru division file, treating specialty census nodes to find problems

 F  S DGI=$O(^DG(40.8,DGI)) Q:'DGI  S %=$$UPCP^XPDUTL("DGTSI",DGI) F  S DGJ=+$O(^DG(40.8,DGI,"TS",+DGJ)),%=$$UPCP^XPDUTL("DGTSJ",DGJ) Q:'DGJ  S DGX=1 D  S DGK=0,%=$$UPCP^XPDUTL("DGTSK",DGK)

 .S:'DGK DGK=+$O(^DG(40.8,DGI,"TS",+DGJ,"C",+DGK))

 .F  S DGK1=DGK,DGK=+$O(^DG(40.8,DGI,"TS",+DGJ,"C",+DGK)),%=$$UPCP^XPDUTL("DGTSK",DGK) S DGY=$$DTCK(DGK,DGK1) Q:DGY=1  D  I DGX D FLG

 ..I 'DGY S $P(^DG(40.8,DGI,"TS",DGJ,"C",DGK,0),U)=DGK,^DG(40.8,DGI,"TS",DGJ,"C","B",DGK,DGK)=""

 ..; update DGK ckpt after file is updated, so $O finds next node to be considered.

FLG ;kills 0 x-refs

 K ^DG(40.8,DGI,"TS",DGJ,"C","B",0) S DGX=0

DTCK(X1,X2) ;  checks for 2 sequential dates

N X

 ;   X1 = current date being checked  (DGK)

 ;   X2 = previous date checked  (DGK1)

 S X=0

 I 'X1 S X=1 G Q

 I +$G(^DG(40.8,DGI,"TS",DGJ,"C",DGK,0))=DGK D ^%DTC

Q Q X

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG5385PT   1901     printed  Apr 09, 2024@21:53:25                                                                                                                                                                                                    Page 2

DG5385PT  ;ALB/ABR -POST-INIT TS CLEANUP FOR PATCH 85 ; 4/10/96

 +1       ;;5.3;Registration;**85**;Aug 13, 1993

 +2       ;

 +3       ;Variables:

 +4       ;  DGI = Division

 +5       ;  DGJ = Treating Specialty

 +6       ;  DGK = Census Date

 +7       ;  DGX = Kill flag

 +8       ;  DGY = # of days since previous TS census entry

 +9       ;

POST      ; entry point for post-install  - set up checkpoints

 +1        NEW %

 +2       ; call-back routine for KIDS

           SET %=$$NEWCP^XPDUTL("DGTSI","EN^DG5385PT",0)

 +3        SET %=$$NEWCP^XPDUTL("DGTSJ")

           SET %=$$NEWCP^XPDUTL("DGTSK")

 +4        QUIT

 +5       ;

EN        ;

 +1        NEW DGI,DGJ,DGK,DGK1,DGX,DGY,%

 +2       ;

 +3        DO BMES^XPDUTL(" >>Treating Specialty Census clean-up")

 +4       ;

 +5       ; retrieve values in checkpoints, step back for $O function

 +6        SET DGI=+$$PARCP^XPDUTL("DGTSI")

           SET DGJ=+$$PARCP^XPDUTL("DGTSJ")

           SET DGK=+$$PARCP^XPDUTL("DGTSK")

 +7        IF DGK

               IF '+$GET(^DG(40.8,DGI,"TS",DGJ,"C",DGK,0))

                   SET DGK=DGK-.001

 +8       ; if post-install has previously started, set DGI and DGJ back, so that $O will return values at time of failure

           if DGI

               SET DGI=DGI-.001

           if DGJ

               SET DGJ=DGJ-.001

 +9       ;

LOOP      ; step thru division file, treating specialty census nodes to find problems

 +1        FOR

               SET DGI=$ORDER(^DG(40.8,DGI))

               if 'DGI

                   QUIT

               SET %=$$UPCP^XPDUTL("DGTSI",DGI)

FOR

                   SET DGJ=+$ORDER(^DG(40.8,DGI,"TS",+DGJ))

                   SET %=$$UPCP^XPDUTL("DGTSJ",DGJ)

                   if 'DGJ

                       QUIT

                   SET DGX=1

                   Begin DoDot:1

 +2                    if 'DGK

                           SET DGK=+$ORDER(^DG(40.8,DGI,"TS",+DGJ,"C",+DGK))

 +3                    FOR

                           SET DGK1=DGK

                           SET DGK=+$ORDER(^DG(40.8,DGI,"TS",+DGJ,"C",+DGK))

                           SET %=$$UPCP^XPDUTL("DGTSK",DGK)

                           SET DGY=$$DTCK(DGK,DGK1)

                           if DGY=1

                               QUIT

                           Begin DoDot:2

 +4                            IF 'DGY

                                   SET $PIECE(^DG(40.8,DGI,"TS",DGJ,"C",DGK,0),U)=DGK

                                   SET ^DG(40.8,DGI,"TS",DGJ,"C","B",DGK,DGK)=""

 +5       ; update DGK ckpt after file is updated, so $O finds next node to be considered.

                           End DoDot:2

                           IF DGX

                               DO FLG

                   End DoDot:1

                   SET DGK=0

                   SET %=$$UPCP^XPDUTL("DGTSK",DGK)

 +6        QUIT

 +7       ;

FLG       ;kills 0 x-refs

 +1        KILL ^DG(40.8,DGI,"TS",DGJ,"C","B",0)

           SET DGX=0

 +2        QUIT

 +3       ;

DTCK(X1,X2) ;  checks for 2 sequential dates

 +1        NEW X

 +2       ;   X1 = current date being checked  (DGK)

 +3       ;   X2 = previous date checked  (DGK1)

 +4        SET X=0

 +5        IF 'X1

               SET X=1

               GOTO Q

 +6        IF +$GET(^DG(40.8,DGI,"TS",DGJ,"C",DGK,0))=DGK

               DO ^%DTC

Q          QUIT X

DG5385PT.m