SD53157P ;ALB/JLU;POST INIT FOR PATCH SD*5.3*157;10/15/98
;;5.3;Scheduling;**157**;Aug 13, 1993
;
EN ;Main entry point
N PARIEN,PCMM,PCMMOUT,PCMMERR,PCMMPAR
;
D FIND^DIC(3.8,"",.01,"X","SCMC PCMM REASSIGNMENT","","","","","PCMMOUT","PCMMERR")
;
;check for error from call
I $D(PCMMERR("DIERR")) D G EXIT
.D BMES^XPDUTL("An error has been recorded:")
.D MES^XPDUTL(PCMMERR("DIERR",1,"TEXT",1))
.Q
;
;check to see if the mail group was installed.
I +$G(PCMMOUT("DILIST",0))<1 D G EXIT
.D BMES^XPDUTL("Could not find the SCMC PCMM REASSIGNMENT mail group.")
.D MES^XPDUTL("The REASSIGNMENT MAIL GROUP parameter will not be populated. Consult")
.D MES^XPDUTL("National VISTA Support.")
.Q
;
;get scheduling parameter file entry
S PARIEN=$O(^SD(404.91,0))
I 'PARIEN D BMES^XPDUTL("No entry exists in the Scheduling Parameter file. No update occured.") G EXIT
I $P(^SD(404.91,PARIEN,"PCMM"),U,4)]"" D BMES^XPDUTL("REASSIGNMENT MAIL GROUP Parameter already populated. No updating performed.") G EXIT
;
D CLEAN
;stuffing mail group into pcmm parameter.
S PCMMPAR(404.91,PARIEN_",",804)="SCMC PCMM REASSIGNMENT"
D FILE^DIE("E","PCMMPAR","PCMMERR")
I $D(PCMMERR("DIERR")) D G EXIT
.D BMES^XPDUTL("The Scheduling Parameter file field REASSIGNMENT MAIL GROUP, could")
.D MES^XPDUTL("not be updated. The following error has occured.")
.D BMES^XPDUTL(PCMMERR("DIERR",1,"TEXT",1))
.Q
D BMES^XPDUTL("The Scheduling Parameter file field REASSIGNMENT MAIL GROUP has been updated.")
;
EXIT D CLEAN
Q
;
CLEAN ;
K PCMMERR("DIERR"),PCMMOUT("DILIST")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSD53157P 1619 printed Nov 22, 2024@17:54:57 Page 2
SD53157P ;ALB/JLU;POST INIT FOR PATCH SD*5.3*157;10/15/98
+1 ;;5.3;Scheduling;**157**;Aug 13, 1993
+2 ;
EN ;Main entry point
+1 NEW PARIEN,PCMM,PCMMOUT,PCMMERR,PCMMPAR
+2 ;
+3 DO FIND^DIC(3.8,"",.01,"X","SCMC PCMM REASSIGNMENT","","","","","PCMMOUT","PCMMERR")
+4 ;
+5 ;check for error from call
+6 IF $DATA(PCMMERR("DIERR"))
Begin DoDot:1
+7 DO BMES^XPDUTL("An error has been recorded:")
+8 DO MES^XPDUTL(PCMMERR("DIERR",1,"TEXT",1))
+9 QUIT
End DoDot:1
GOTO EXIT
+10 ;
+11 ;check to see if the mail group was installed.
+12 IF +$GET(PCMMOUT("DILIST",0))<1
Begin DoDot:1
+13 DO BMES^XPDUTL("Could not find the SCMC PCMM REASSIGNMENT mail group.")
+14 DO MES^XPDUTL("The REASSIGNMENT MAIL GROUP parameter will not be populated. Consult")
+15 DO MES^XPDUTL("National VISTA Support.")
+16 QUIT
End DoDot:1
GOTO EXIT
+17 ;
+18 ;get scheduling parameter file entry
+19 SET PARIEN=$ORDER(^SD(404.91,0))
+20 IF 'PARIEN
DO BMES^XPDUTL("No entry exists in the Scheduling Parameter file. No update occured.")
GOTO EXIT
+21 IF $PIECE(^SD(404.91,PARIEN,"PCMM"),U,4)]""
DO BMES^XPDUTL("REASSIGNMENT MAIL GROUP Parameter already populated. No updating performed.")
GOTO EXIT
+22 ;
+23 DO CLEAN
+24 ;stuffing mail group into pcmm parameter.
+25 SET PCMMPAR(404.91,PARIEN_",",804)="SCMC PCMM REASSIGNMENT"
+26 DO FILE^DIE("E","PCMMPAR","PCMMERR")
+27 IF $DATA(PCMMERR("DIERR"))
Begin DoDot:1
+28 DO BMES^XPDUTL("The Scheduling Parameter file field REASSIGNMENT MAIL GROUP, could")
+29 DO MES^XPDUTL("not be updated. The following error has occured.")
+30 DO BMES^XPDUTL(PCMMERR("DIERR",1,"TEXT",1))
+31 QUIT
End DoDot:1
GOTO EXIT
+32 DO BMES^XPDUTL("The Scheduling Parameter file field REASSIGNMENT MAIL GROUP has been updated.")
+33 ;
EXIT DO CLEAN
+1 QUIT
+2 ;
CLEAN ;
+1 KILL PCMMERR("DIERR"),PCMMOUT("DILIST")
+2 QUIT
