SDRR5 ;10N20/MAH; RECALL REMINDER Remove and Replace Providers and Clinics; 01/22/2008
;;5.3;Scheduling;**536,582**;Aug 13, 1993;Build 3
;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"
;SD*582 following changed to check for selected old 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)),U,6) Q:RD<SDT!(RD>EDT) I $P($G(^(0)),U,2)=OHIEN D
..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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDRR5 2290 printed Nov 22, 2024@18:10:23 Page 2
SDRR5 ;10N20/MAH; RECALL REMINDER Remove and Replace Providers and Clinics; 01/22/2008
+1 ;;5.3;Scheduling;**536,582**;Aug 13, 1993;Build 3
+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 ;SD*582 following changed to check for selected old clinic
+6 IF FLAG["C"
SET D0=0
FOR
SET D0=$ORDER(^SD(403.5,"C",OIEN,D0))
if D0'>0
QUIT
Begin DoDot:1
+7 SET RD=$PIECE($GET(^SD(403.5,D0,0)),U,6)
if RD<SDT!(RD>EDT)
QUIT
IF $PIECE($GET(^(0)),U,2)=OHIEN
Begin DoDot:2
+8 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:2
End DoDot:1
+9 IF FLAG=""
SET D0=0
FOR
SET D0=$ORDER(^SD(403.5,"C",OIEN,D0))
if D0'>0
QUIT
Begin DoDot:1
+10 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
