Routine: SD53P297

SD53P297 ;ALB/JDS - Pre/Post-Install;15-Nov-2001 ; 8/8/05 2:01pm

 ;;5.3;Scheduling;**297**;Aug 13, 1993

ENV ;Main entry point for Environment check point.

 S XPDABORT=""

 I XPDABORT="" K XPDABORT

PRE ;Main entry point for Pre-init items.

N I

 F I=0:0 S I=$O(^SD(403.46,I)) Q:'I   I $P($G(^(I,0)),U,3)]"" D

 .S DIE="^SD(403.46,",DR=".03///@",DA=I D ^DIE

 F SCI=0:0 S SCI=$O(^SD(403.46,SCI)) Q:'SCI  D

 .F J=0:0 S J=$O(^SD(403.46,SCI,2,J)) Q:'J  S DIK="^SD(403.46,"_SCI_",2,",DA=J,DA(1)=SCI D ^DIK

POST ;Main entry point for Post-init items.

 D MES^XPDUTL("Updating Client/Server entries")

 N ENTRY,E608,LASTD

 K DGLEFDA

 I '$D(^SCTM(404.46,"B","1.3.0.0")) D

 .K DO S DIC(0)="LM",DIC("DR")=".02////1;.03////"_DT,DIC="^SCTM(404.46,",X="1.3.0.0" D FILE^DICN

 I '$D(^SCTM(404.45,"B","SD*5.3*297")) D

 .S ENTRY=$O(^SCTM(404.46,"B","1.3.0.0",0))

 .S DIC("DR")=".02////"_(+ENTRY)_";.03////"_DT_";.04////1",DIC(0)="LM"

 .K DO S X="SD*5.3*297",DIC="^SCTM(404.45," D FILE^DICN

 ;move 608M errors to retransmit and disappear

 D MES^XPDUTL("Setting 608M PCMM errors for correction")

 S E608=$O(^SCPT(404.472,"B","608M",0))

 F I=0:0 S I=$O(^SCPT(404.471,"ASTAT","RJ",I)) Q:'I  D

 .I $D(^SCPT(404.571,I,"ERR","B",+E608)) S DA=I,DIE="^SCPT(404.471,",DR=".04////M" D ^DIE

 D MES^XPDUTL("Moving Team Position Clinic to multiple")

 ;move associated clinics to multiple

 F I=0:0 S I=$O(^SCTM(404.57,I)) Q:'I  S ZERO=$G(^(I,0)) I $D(^SCTM(404.51,+$P(ZERO,U,2),0)) I $P(ZERO,U,9) D

 .S X=$P(ZERO,U,9) I $D(^SCTM(404.57,I,5,+X)) Q

 .I '$D(^SCTM(404.57,I,5,0)) S ^(0)="^404.575PA^^"

 .S DIC="^SCTM(404.57,"_I_",5,",DIC(0)="LM",DA(1)=I D ^DICN

 ;If before May set up as alpha site

 ;Set up provider inactivation date 6 months away

 D MES^XPDUTL("Setting up 6 month  for provider inactivations")

 S X1=DT,X2=180 D C^%DTC S X1=$E(X,1,5)_28

 F  S LASTD=X1,X2=1 D C^%DTC S X1=X Q:($E(LASTD,1,5)'=$E(X,1,5))

 I '$P($G(^SCTM(404.44,1,1)),U,9) S DIE="^SCTM(404.44,",DA=1,DR="19////"_LASTD D ^DIE

 I DT<3051215 D

 .S DIE="^SCTM(404.44,",DA=1,DR="18////3051215" D ^DIE

 ;set default auto inactivate team on

 S DIE="^SCTM(404.44,",DA=1,DR="20///YES" D ^DIE

 ;Set default notification to No

 F I=0:0 S I=$O(^SCTM(404.57,I)) Q:'I  S ZERO=$G(^(I,2)) I $P(ZERO,U,9)="" S DR="2.09////N",DIE="^SCTM(404.57,",DA=I D ^DIE

 S XPDIDTOT=+$O(^SCPT(404.43,"ADFN",""),-1) D MES^XPDUTL("Queuing Routine to Flag Inactive PCMM assignments")

 S ZTRTN="INACTIVE^SCMCTSK1",ZTIO="",ZTDTH=$H,ZTDESC="PCMM Inactive patients"  D ^%ZTLOAD

 D MES^XPDUTL("Task "_$G(ZTSK))

MEN S X="SCMC PCMM PROVIDER RPTS MENU",DIC="^DIC(19,",DIC(0)="M" D ^DIC S SD=+Y

 I SD>0 D

 .S X="SCMC MU MASS TEAM UNASSIGNMENT",DIC="^DIC(19,"_SD_",10,",DIC(0)="M",DA(1)=SD D ^DIC Q:Y'>0

 .S DA(1)=SD,DIK="^DIC(19,"_SD_",10,",DA=+Y D ^DIK

 S X="SDOUTPUT",DIC="^DIC(19,",DIC(0)="M" D ^DIC Q:Y'>0  S SD=+Y

 I '$D(^DIC(19,+Y,10,0)) Q

 S X="SCMC PCMM MAIN MENU",DIC="^DIC(19,"_SD_",10,",DIC(0)="LM",DA(1)=SD D ^DIC

 S X="SC PCMM REPORTS MENU",DIC="^DIC(19,"_SD_",10,",DIC(0)="M",DA(1)=SD D ^DIC Q:'Y

 S DA(1)=SD,DIK="^DIC(19,"_SD_",10,",DA=+Y D ^DIK

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSD53P297   3170     printed  Mar 13, 2025@21:51:06                                                                                                                                                                                                    Page 2

SD53P297  ;ALB/JDS - Pre/Post-Install;15-Nov-2001 ; 8/8/05 2:01pm

 +1       ;;5.3;Scheduling;**297**;Aug 13, 1993

 +2       ;

 +3       ;

ENV       ;Main entry point for Environment check point.

 +1       ;

 +2        SET XPDABORT=""

 +3        IF XPDABORT=""

               KILL XPDABORT

 +4        QUIT

 +5       ;

 +6       ;

PRE       ;Main entry point for Pre-init items.

 +1       ;

 +2        NEW I

 +3        FOR I=0:0

               SET I=$ORDER(^SD(403.46,I))

               if 'I

                   QUIT

               IF $PIECE($GET(^(I,0)),U,3)]""

                   Begin DoDot:1

 +4                    SET DIE="^SD(403.46,"

                       SET DR=".03///@"

                       SET DA=I

                       DO ^DIE

                   End DoDot:1

 +5        FOR SCI=0:0

               SET SCI=$ORDER(^SD(403.46,SCI))

               if 'SCI

                   QUIT

               Begin DoDot:1

 +6                FOR J=0:0

                       SET J=$ORDER(^SD(403.46,SCI,2,J))

                       if 'J

                           QUIT

                       SET DIK="^SD(403.46,"_SCI_",2,"

                       SET DA=J

                       SET DA(1)=SCI

                       DO ^DIK

               End DoDot:1

 +7        QUIT

 +8       ;

 +9       ;

POST      ;Main entry point for Post-init items.

 +1       ;

 +2        DO MES^XPDUTL("Updating Client/Server entries")

 +3        NEW ENTRY,E608,LASTD

 +4        KILL DGLEFDA

 +5        IF '$DATA(^SCTM(404.46,"B","1.3.0.0"))

               Begin DoDot:1

 +6                KILL DO

                   SET DIC(0)="LM"

                   SET DIC("DR")=".02////1;.03////"_DT

                   SET DIC="^SCTM(404.46,"

                   SET X="1.3.0.0"

                   DO FILE^DICN

               End DoDot:1

 +7        IF '$DATA(^SCTM(404.45,"B","SD*5.3*297"))

               Begin DoDot:1

 +8                SET ENTRY=$ORDER(^SCTM(404.46,"B","1.3.0.0",0))

 +9                SET DIC("DR")=".02////"_(+ENTRY)_";.03////"_DT_";.04////1"

                   SET DIC(0)="LM"

 +10               KILL DO

                   SET X="SD*5.3*297"

                   SET DIC="^SCTM(404.45,"

                   DO FILE^DICN

               End DoDot:1

 +11      ;move 608M errors to retransmit and disappear

 +12       DO MES^XPDUTL("Setting 608M PCMM errors for correction")

 +13       SET E608=$ORDER(^SCPT(404.472,"B","608M",0))

 +14       FOR I=0:0

               SET I=$ORDER(^SCPT(404.471,"ASTAT","RJ",I))

               if 'I

                   QUIT

               Begin DoDot:1

 +15               IF $DATA(^SCPT(404.571,I,"ERR","B",+E608))

                       SET DA=I

                       SET DIE="^SCPT(404.471,"

                       SET DR=".04////M"

                       DO ^DIE

               End DoDot:1

 +16       DO MES^XPDUTL("Moving Team Position Clinic to multiple")

 +17      ;move associated clinics to multiple

 +18       FOR I=0:0

               SET I=$ORDER(^SCTM(404.57,I))

               if 'I

                   QUIT

               SET ZERO=$GET(^(I,0))

               IF $DATA(^SCTM(404.51,+$PIECE(ZERO,U,2),0))

                   IF $PIECE(ZERO,U,9)

                       Begin DoDot:1

 +19                       SET X=$PIECE(ZERO,U,9)

                           IF $DATA(^SCTM(404.57,I,5,+X))

                               QUIT

 +20                       IF '$DATA(^SCTM(404.57,I,5,0))

                               SET ^(0)="^404.575PA^^"

 +21                       SET DIC="^SCTM(404.57,"_I_",5,"

                           SET DIC(0)="LM"

                           SET DA(1)=I

                           DO ^DICN

                       End DoDot:1

 +22      ;If before May set up as alpha site

 +23      ;Set up provider inactivation date 6 months away

 +24       DO MES^XPDUTL("Setting up 6 month  for provider inactivations")

 +25       SET X1=DT

           SET X2=180

           DO C^%DTC

           SET X1=$EXTRACT(X,1,5)_28

 +26       FOR

               SET LASTD=X1

               SET X2=1

               DO C^%DTC

               SET X1=X

               if ($EXTRACT(LASTD,1,5)'=$EXTRACT(X,1,5))

                   QUIT

 +27       IF '$PIECE($GET(^SCTM(404.44,1,1)),U,9)

               SET DIE="^SCTM(404.44,"

               SET DA=1

               SET DR="19////"_LASTD

               DO ^DIE

 +28       IF DT<3051215

               Begin DoDot:1

 +29               SET DIE="^SCTM(404.44,"

                   SET DA=1

                   SET DR="18////3051215"

                   DO ^DIE

               End DoDot:1

 +30      ;set default auto inactivate team on

 +31       SET DIE="^SCTM(404.44,"

           SET DA=1

           SET DR="20///YES"

           DO ^DIE

 +32      ;Set default notification to No

 +33       FOR I=0:0

               SET I=$ORDER(^SCTM(404.57,I))

               if 'I

                   QUIT

               SET ZERO=$GET(^(I,2))

               IF $PIECE(ZERO,U,9)=""

                   SET DR="2.09////N"

                   SET DIE="^SCTM(404.57,"

                   SET DA=I

                   DO ^DIE

 +34       SET XPDIDTOT=+$ORDER(^SCPT(404.43,"ADFN",""),-1)

           DO MES^XPDUTL("Queuing Routine to Flag Inactive PCMM assignments")

 +35       SET ZTRTN="INACTIVE^SCMCTSK1"

           SET ZTIO=""

           SET ZTDTH=$HOROLOG

           SET ZTDESC="PCMM Inactive patients"

           DO ^%ZTLOAD

 +36       DO MES^XPDUTL("Task "_$GET(ZTSK))

MEN        SET X="SCMC PCMM PROVIDER RPTS MENU"

           SET DIC="^DIC(19,"

           SET DIC(0)="M"

           DO ^DIC

           SET SD=+Y

 +1        IF SD>0

               Begin DoDot:1

 +2                SET X="SCMC MU MASS TEAM UNASSIGNMENT"

                   SET DIC="^DIC(19,"_SD_",10,"

                   SET DIC(0)="M"

                   SET DA(1)=SD

                   DO ^DIC

                   if Y'>0

                       QUIT

 +3                SET DA(1)=SD

                   SET DIK="^DIC(19,"_SD_",10,"

                   SET DA=+Y

                   DO ^DIK

               End DoDot:1

 +4        SET X="SDOUTPUT"

           SET DIC="^DIC(19,"

           SET DIC(0)="M"

           DO ^DIC

           if Y'>0

               QUIT

           SET SD=+Y

 +5        IF '$DATA(^DIC(19,+Y,10,0))

               QUIT

 +6        SET X="SCMC PCMM MAIN MENU"

           SET DIC="^DIC(19,"_SD_",10,"

           SET DIC(0)="LM"

           SET DA(1)=SD

           DO ^DIC

 +7        SET X="SC PCMM REPORTS MENU"

           SET DIC="^DIC(19,"_SD_",10,"

           SET DIC(0)="M"

           SET DA(1)=SD

           DO ^DIC

           if 'Y

               QUIT

 +8        SET DA(1)=SD

           SET DIK="^DIC(19,"_SD_",10,"

           SET DA=+Y

           DO ^DIK

 +9       ;

 +10      ;

 +11       QUIT

SD53P297.m