SDRR5.m

SDRR5 ;10N20/MAH; RECALL REMINDER Remove and Replace Providers and Clinics; 01/22/2008

 ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20

 ;This routine was written per requests from VISN20 sites

 ;^SD(403.5 -- RECALL REMINDERS FILE

 ;403.54 -- RECALL REMINDERS PROVIDERS FILE

 ;44 -- HOSPITAL LOCATION FILE

 ;Used in option [SDRR CONVERT ENTRIES]

STRT S (NIEN,OIEN,SDT,EDT,OHIEN,NHIEN,FLAG,OLDC,NEWC)=""

 S DIC="^SD(403.54,",DIC(0)="AEQMZ",DIC("A")="Select Retiring Provider: " D ^DIC G:Y<0 QUIT S OIEN=+Y,OPROV=$P(^SD(403.54,OIEN,0),"^",1),SDRROLD=$$NAME^XUSER(OPROV,"F")

 S DIC="^SD(403.54,",DIC(0)="AEQMZ",DIC("A")="Select New Provider: " D ^DIC G:Y<0 QUIT S NIEN=+Y,OPROV=$P(^SD(403.54,NIEN,0),"^",1),SDRRNEW=$$NAME^XUSER(OPROV,"F")

 W !,?1,"Do you want to change Clinic names that the recall is pointed to: " S %=2 D YN^DICN I %=2 G SELDT

 K %

CLINC S DIC="^SC(",DIC(0)="AEQMZ",DIC("A")="Select Retiring Clinic: " D ^DIC G:Y<0 CLEAN S OHIEN=+Y,OLDC=$$GET1^DIQ(44,OHIEN_",",.01)

 S DIC="^SC(",DIC(0)="AEQMZ",DIC("A")="Select New Clinic: " D ^DIC G:Y<0 CLEAN S NHIEN=+Y,FLAG="C",NEWC=$$GET1^DIQ(44,NHIEN_",",.01)

CLEAN ;CLINIC NOT SELECTED BUT CHECK

 I FLAG'["C" W !,?1,"You have selected not to move clinic recall applications to a different clinic is this correct: " S %=2 D YN^DICN I %=2 G CLINC

SELDT S %DT="AEX",%DT("A")="Start with RECALL DATE: " D ^%DT Q:Y<0  S SDT=Y,%DT("A")="End with RECALL DATE: " D ^%DT I Y<SDT W $C(7),"  ??" G SELDT

 S EDT=Y S EDT=EDT_".9999"

 W !!,?5,"****You will be converting all Clinic Recalls for****"

 W !!,?3,SDRROLD_" -They will be converted to- "_SDRRNEW

 I NEWC'="" W !,?3,OLDC_" Clinic will be converted to "_NEWC_" Clinic"

 I FLAG["C" S D0=0 F  S D0=$O(^SD(403.5,"C",OIEN,D0)) Q:D0'>0  D

 .S RD=$P($G(^SD(403.5,D0,0)),"^",6) Q:RD<SDT!(RD>EDT)  S DIE="^SD(403.5," S DA=D0,DR="4///^S X=""`""_NIEN;4.5///^S X=""`""_NHIEN" D ^DIE K DIE,DR,DA

 I FLAG="" S D0=0 F  S D0=$O(^SD(403.5,"C",OIEN,D0)) Q:D0'>0  D

 .S RD=$P($G(^SD(403.5,D0,0)),"^",6) Q:RD<SDT!(RD>EDT)  S DIE="^SD(403.5," S DA=D0,DR="4///^S X=""`""_NIEN" D ^DIE K DIE,DR,DA

QUIT K Y,OIEN,NIEN,FLAG,OPROV,SDT,RD,EDT,SDRRNEW,SDRROLD,D0,NEWC,NHIEN,OHIEN,OLDC,X,DIC,FLAG,%DT

SDRR5     ;10N20/MAH; RECALL REMINDER Remove and Replace Providers and Clinics; 01/22/2008

 +1       ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20

 +2       ;This routine was written per requests from VISN20 sites

 +3       ;^SD(403.5 -- RECALL REMINDERS FILE

 +4       ;403.54 -- RECALL REMINDERS PROVIDERS FILE

 +5       ;44 -- HOSPITAL LOCATION FILE

 +6       ;Used in option [SDRR CONVERT ENTRIES]

STRT       SET (NIEN,OIEN,SDT,EDT,OHIEN,NHIEN,FLAG,OLDC,NEWC)=""

 +1        SET DIC="^SD(403.54,"

           SET DIC(0)="AEQMZ"

           SET DIC("A")="Select Retiring Provider: "

           DO ^DIC

           IF Y<0

               GOTO QUIT

           SET OIEN=+Y

           SET OPROV=$PIECE(^SD(403.54,OIEN,0),"^",1)

           SET SDRROLD=$$NAME^XUSER(OPROV,"F")

 +2        SET DIC="^SD(403.54,"

           SET DIC(0)="AEQMZ"

           SET DIC("A")="Select New Provider: "

           DO ^DIC

           IF Y<0

               GOTO QUIT

           SET NIEN=+Y

           SET OPROV=$PIECE(^SD(403.54,NIEN,0),"^",1)

           SET SDRRNEW=$$NAME^XUSER(OPROV,"F")

 +3        WRITE !,?1,"Do you want to change Clinic names that the recall is pointed to: "

           SET %=2

           DO YN^DICN

           IF %=2

               GOTO SELDT

 +4        KILL %

CLINC      SET DIC="^SC("

           SET DIC(0)="AEQMZ"

           SET DIC("A")="Select Retiring Clinic: "

           DO ^DIC

           IF Y<0

               GOTO CLEAN

           SET OHIEN=+Y

           SET OLDC=$$GET1^DIQ(44,OHIEN_",",.01)

 +1        SET DIC="^SC("

           SET DIC(0)="AEQMZ"

           SET DIC("A")="Select New Clinic: "

           DO ^DIC

           IF Y<0

               GOTO CLEAN

           SET NHIEN=+Y

           SET FLAG="C"

           SET NEWC=$$GET1^DIQ(44,NHIEN_",",.01)

CLEAN     ;CLINIC NOT SELECTED BUT CHECK

 +1        IF FLAG'["C"

               WRITE !,?1,"You have selected not to move clinic recall applications to a different clinic is this correct: "

               SET %=2

               DO YN^DICN

               IF %=2

                   GOTO CLINC

SELDT      SET %DT="AEX"

           SET %DT("A")="Start with RECALL DATE: "

           DO ^%DT

           IF Y<0

               QUIT 

           SET SDT=Y

           SET %DT("A")="End with RECALL DATE: "

           DO ^%DT

           IF Y<SDT

               WRITE $CHAR(7),"  ??"

               GOTO SELDT

 +1        SET EDT=Y

           SET EDT=EDT_".9999"

 +2        WRITE !!,?5,"****You will be converting all Clinic Recalls for****"

 +3        WRITE !!,?3,SDRROLD_" -They will be converted to- "_SDRRNEW

 +4        IF NEWC'=""

               WRITE !,?3,OLDC_" Clinic will be converted to "_NEWC_" Clinic"

 +5        IF FLAG["C"

               SET D0=0

               FOR 

                   SET D0=$ORDER(^SD(403.5,"C",OIEN,D0))

                   IF D0'>0

                       QUIT 

                   Begin DoDot:1

 +6                    SET RD=$PIECE($GET(^SD(403.5,D0,0)),"^",6)

                       IF RD<SDT!(RD>EDT)

                           QUIT 

                       SET DIE="^SD(403.5,"

                       SET DA=D0

                       SET DR="4///^S X=""`""_NIEN;4.5///^S X=""`""_NHIEN"

                       DO ^DIE

                       KILL DIE,DR,DA

                   End DoDot:1

 +7        IF FLAG=""

               SET D0=0

               FOR 

                   SET D0=$ORDER(^SD(403.5,"C",OIEN,D0))

                   IF D0'>0

                       QUIT 

                   Begin DoDot:1

 +8                    SET RD=$PIECE($GET(^SD(403.5,D0,0)),"^",6)

                       IF RD<SDT!(RD>EDT)

                           QUIT 

                       SET DIE="^SD(403.5,"

                       SET DA=D0

                       SET DR="4///^S X=""`""_NIEN"

                       DO ^DIE

                       KILL DIE,DR,DA

                   End DoDot:1

QUIT       KILL Y,OIEN,NIEN,FLAG,OPROV,SDT,RD,EDT,SDRRNEW,SDRROLD,D0,NEWC,NHIEN,OHIEN,OLDC,X,DIC,FLAG,%DT