- 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
