- 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 Mar 13, 2025@21:49:54 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
