PRS4P150 ;ALB/DBE - CORRECT ESR PAY PERIODS ;07/13/2017
;;4.0;PAID;**150**;Sep 21, 1995;Build 1
;;Per VA Directive 6402, this routine should not be modified
;
Q
;
; This routine will correct PT Physician Memorandums with incorrect
; pay period designations.
;
START ; Main Driver
;
K ^TMP($J)
N DA,DR,DIE,PRSMIEN,PRSOLDPPD,PRSNEWPPD,PRSPPIEN,PRSDASH,PRSTIME,Y,PRSPTP,PRSPTPNAME,%
D NOW^%DTC S Y=%
D DD^%DT S PRSTIME=Y
D BMES^XPDUTL("Routine PRS4P150 beginning at "_PRSTIME_".")
D MEMO
I $D(^TMP($J)) D DISPLAY
D BMES^XPDUTL("Routine PRS4P150 processing complete.")
K DA,DR,DIE,PRSMIEN,PRSOLDPPD,PRSNEWPPD,PRSPPIEN,PRSDASH,PRSTIME,Y,PRSPTP,^TMP($J),%,PRSPTPNAME
Q
;
MEMO ; Loop through memos - correct bad pay period records
K DA,DR,DIE
S PRSMIEN=0,PRSOLDPPD="",PRSIEN=""
F S PRSMIEN=$O(^PRST(458.7,PRSMIEN)) Q:'PRSMIEN D
.I '$D(^PRST(458.7,PRSMIEN,9)) Q
.F S PRSOLDPPD=$O(^PRST(458.7,PRSMIEN,9,"B",PRSOLDPPD)) Q:PRSOLDPPD="" S PRSPPIEN="" D
..I PRSOLDPPD'["17-" Q
..I PRSOLDPPD']"17-26" Q
..S PRSPPIEN=$O(^PRST(458.7,PRSMIEN,9,"B",PRSOLDPPD,PRSPPIEN)) Q:PRSPPIEN=""
..S PRSNEWPPD="" D Q:PRSNEWPPD=""
...S PRSNEWPPD=$S(PRSOLDPPD="17-27":"18-01",PRSOLDPPD="17-28":"18-02",PRSOLDPPD="17-29":"18-03",PRSOLDPPD="17-30":"18-04",PRSOLDPPD="17-31":"18-05",PRSOLDPPD="17-32":"18-06",PRSOLDPPD="17-33":"18-07",PRSOLDPPD="17-34":"18-08",1:PRSNEWPPD)
...S PRSNEWPPD=$S(PRSOLDPPD="17-35":"18-09",PRSOLDPPD="17-36":"18-10",PRSOLDPPD="17-37":"18-11",PRSOLDPPD="17-38":"18-12",PRSOLDPPD="17-39":"18-13",PRSOLDPPD="17-40":"18-14",PRSOLDPPD="17-41":"18-15",PRSOLDPPD="17-42":"18-16",1:PRSNEWPPD)
...S PRSNEWPPD=$S(PRSOLDPPD="17-43":"18-17",PRSOLDPPD="17-44":"18-18",PRSOLDPPD="17-45":"18-19",PRSOLDPPD="17-46":"18-20",PRSOLDPPD="17-47":"18-21",PRSOLDPPD="17-48":"18-22",PRSOLDPPD="17-49":"18-23",PRSOLDPPD="17-50":"18-24",1:PRSNEWPPD)
...S PRSNEWPPD=$S(PRSOLDPPD="17-51":"18-25",PRSOLDPPD="17-52":"18-26",1:PRSNEWPPD)
..S DA=PRSPPIEN,DA(1)=PRSMIEN,DR=".01///^S X=PRSNEWPPD",DIE="^PRST(458.7,PRSMIEN,9,"
..D ^DIE
..K DA,DR,DIE
..N PRSIEN,PRSPPI
..S PRSIEN=$P(^PRST(458.7,PRSMIEN,0),"^",1),PRSPPI=$O(^PRST(458,"B",PRSNEWPPD,"")) D
...Q:PRSPPI=""
...I PRSNEWPPD["18-" D PTP^PRSASR1(PRSIEN,PRSPPI) ;UPDATE MEMO WITH ESR HOURS
..S ^TMP($J,PRSMIEN)=$P(^PRST(458.7,PRSMIEN,0),"^",1)
Q
;
DISPLAY ; Display PT Physicians with corrected memorandums
S $P(PRSDASH,"-",53)="",PRSMIEN=""
D BMES^XPDUTL("Pay periods corrected for these Part-Time Physicians")
D MES^XPDUTL(PRSDASH)
; Note naked reference to ^TMP($J) in loop body
F S PRSMIEN=$O(^TMP($J,PRSMIEN)) Q:PRSMIEN="" D
.S PRSPTP=^(PRSMIEN) D MES^XPDUTL($P($G(^PRSPC(PRSPTP,0)),"^",1))
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRS4P150 2750 printed Dec 13, 2024@02:22:40 Page 2
PRS4P150 ;ALB/DBE - CORRECT ESR PAY PERIODS ;07/13/2017
+1 ;;4.0;PAID;**150**;Sep 21, 1995;Build 1
+2 ;;Per VA Directive 6402, this routine should not be modified
+3 ;
+4 QUIT
+5 ;
+6 ; This routine will correct PT Physician Memorandums with incorrect
+7 ; pay period designations.
+8 ;
START ; Main Driver
+1 ;
+2 KILL ^TMP($JOB)
+3 NEW DA,DR,DIE,PRSMIEN,PRSOLDPPD,PRSNEWPPD,PRSPPIEN,PRSDASH,PRSTIME,Y,PRSPTP,PRSPTPNAME,%
+4 DO NOW^%DTC
SET Y=%
+5 DO DD^%DT
SET PRSTIME=Y
+6 DO BMES^XPDUTL("Routine PRS4P150 beginning at "_PRSTIME_".")
+7 DO MEMO
+8 IF $DATA(^TMP($JOB))
DO DISPLAY
+9 DO BMES^XPDUTL("Routine PRS4P150 processing complete.")
+10 KILL DA,DR,DIE,PRSMIEN,PRSOLDPPD,PRSNEWPPD,PRSPPIEN,PRSDASH,PRSTIME,Y,PRSPTP,^TMP($JOB),%,PRSPTPNAME
+11 QUIT
+12 ;
MEMO ; Loop through memos - correct bad pay period records
+1 KILL DA,DR,DIE
+2 SET PRSMIEN=0
SET PRSOLDPPD=""
SET PRSIEN=""
+3 FOR
SET PRSMIEN=$ORDER(^PRST(458.7,PRSMIEN))
if 'PRSMIEN
QUIT
Begin DoDot:1
+4 IF '$DATA(^PRST(458.7,PRSMIEN,9))
QUIT
+5 FOR
SET PRSOLDPPD=$ORDER(^PRST(458.7,PRSMIEN,9,"B",PRSOLDPPD))
if PRSOLDPPD=""
QUIT
SET PRSPPIEN=""
Begin DoDot:2
+6 IF PRSOLDPPD'["17-"
QUIT
+7 IF PRSOLDPPD']"17-26"
QUIT
+8 SET PRSPPIEN=$ORDER(^PRST(458.7,PRSMIEN,9,"B",PRSOLDPPD,PRSPPIEN))
if PRSPPIEN=""
QUIT
+9 SET PRSNEWPPD=""
Begin DoDot:3
+10 SET PRSNEWPPD=$SELECT(PRSOLDPPD="17-27":"18-01",PRSOLDPPD="17-28":"18-02",PRSOLDPPD="17-29":"18-03",PRSOLDPPD="17-30":"18-04",PRSOLDPPD="17-31":"18-05",PRSOLDPPD="17-32":"18-06",PRSOLDPPD="17-33":"18-07",PRSOLDPPD="17-34":"1
8-08",1:PRSNEWPPD)
+11 SET PRSNEWPPD=$SELECT(PRSOLDPPD="17-35":"18-09",PRSOLDPPD="17-36":"18-10",PRSOLDPPD="17-37":"18-11",PRSOLDPPD="17-38":"18-12",PRSOLDPPD="17-39":"18-13",PRSOLDPPD="17-40":"18-14",PRSOLDPPD="17-41":"18-15",PRSOLDPPD="17-42":"1
8-16",1:PRSNEWPPD)
+12 SET PRSNEWPPD=$SELECT(PRSOLDPPD="17-43":"18-17",PRSOLDPPD="17-44":"18-18",PRSOLDPPD="17-45":"18-19",PRSOLDPPD="17-46":"18-20",PRSOLDPPD="17-47":"18-21",PRSOLDPPD="17-48":"18-22",PRSOLDPPD="17-49":"18-23",PRSOLDPPD="17-50":"1
8-24",1:PRSNEWPPD)
+13 SET PRSNEWPPD=$SELECT(PRSOLDPPD="17-51":"18-25",PRSOLDPPD="17-52":"18-26",1:PRSNEWPPD)
End DoDot:3
if PRSNEWPPD=""
QUIT
+14 SET DA=PRSPPIEN
SET DA(1)=PRSMIEN
SET DR=".01///^S X=PRSNEWPPD"
SET DIE="^PRST(458.7,PRSMIEN,9,"
+15 DO ^DIE
+16 KILL DA,DR,DIE
+17 NEW PRSIEN,PRSPPI
+18 SET PRSIEN=$PIECE(^PRST(458.7,PRSMIEN,0),"^",1)
SET PRSPPI=$ORDER(^PRST(458,"B",PRSNEWPPD,""))
Begin DoDot:3
+19 if PRSPPI=""
QUIT
+20 ;UPDATE MEMO WITH ESR HOURS
IF PRSNEWPPD["18-"
DO PTP^PRSASR1(PRSIEN,PRSPPI)
End DoDot:3
+21 SET ^TMP($JOB,PRSMIEN)=$PIECE(^PRST(458.7,PRSMIEN,0),"^",1)
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
DISPLAY ; Display PT Physicians with corrected memorandums
+1 SET $PIECE(PRSDASH,"-",53)=""
SET PRSMIEN=""
+2 DO BMES^XPDUTL("Pay periods corrected for these Part-Time Physicians")
+3 DO MES^XPDUTL(PRSDASH)
+4 ; Note naked reference to ^TMP($J) in loop body
+5 FOR
SET PRSMIEN=$ORDER(^TMP($JOB,PRSMIEN))
if PRSMIEN=""
QUIT
Begin DoDot:1
+6 SET PRSPTP=^(PRSMIEN)
DO MES^XPDUTL($PIECE($GET(^PRSPC(PRSPTP,0)),"^",1))
End DoDot:1
+7 QUIT
+8 ;
