PRSXP140 ;WCIOFO/RRG-CORRECT INCORRECT ESR PAY PERIODS ;08/05/2014
;;4.0;PAID;**140**;Sep 21, 1995;Build 6
;;Per VHA Directive 6402, this routine should not be modified.
;
Q
;
; This program will correct PT Physician Memorandums with incorrect
; pay period designations.
;
START ; Main Driver
;
K ^TMP($J)
N DA,DR,DIE,PRSMIEN,PRSOLDPPD,PRSNEWPPD,PRSPPIEN,DASH,TIME,Y,PRSPTP,PRSPTPNAME,%
D NOW^%DTC S Y=%
D DD^%DT S TIME=Y
D BMES^XPDUTL("Routine PRSXP140 beginning at "_TIME_".")
D MEMO
I $D(^TMP($J)) D DISPLAY
D BMES^XPDUTL("Routine PRSXP140 processing complete.")
K DA,DR,DIE,PRSMIEN,PRSOLDPPD,PRSNEWPPD,PRSPPIEN,DASH,TIME,Y,PRSPTP,^TMP($J),%,PRSPTPNAME
Q
;
MEMO ; Loop through memos - correct bad pay period records
K DA,DA(1),DR,DIE
S PRSMIEN=0,PRSOLDPPD="",PRSIEN=""
F S PRSMIEN=$O(^PRST(458.7,PRSMIEN)) Q:PRSMIEN]999999!(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'["12-" Q
. . I PRSOLDPPD']"12-27" Q
. . S PRSPPIEN=$O(^PRST(458.7,PRSMIEN,9,"B",PRSOLDPPD,PRSPPIEN)) Q:PRSPPIEN=""
. . S PRSNEWPPD="" D Q:PRSNEWPPD=""
. . . S PRSNEWPPD=$S(PRSOLDPPD="12-28":"13-01",PRSOLDPPD="12-29":"13-02",PRSOLDPPD="12-30":"13-03",PRSOLDPPD="12-31":"13-04",PRSOLDPPD="12-32":"13-05",PRSOLDPPD="12-33":"13-06",PRSOLDPPD="12-34":"13-07",PRSOLDPPD="12-35":"13-08",1:PRSNEWPPD)
. . . S PRSNEWPPD=$S(PRSOLDPPD="12-36":"13-09",PRSOLDPPD="12-37":"13-10",PRSOLDPPD="12-38":"13-11",PRSOLDPPD="12-39":"13-12",PRSOLDPPD="12-40":"13-13",PRSOLDPPD="12-41":"13-14",PRSOLDPPD="12-42":"13-15",PRSOLDPPD="12-43":"13-16",1:PRSNEWPPD)
. . . S PRSNEWPPD=$S(PRSOLDPPD="12-44":"13-17",PRSOLDPPD="12-45":"13-18",PRSOLDPPD="12-46":"13-19",PRSOLDPPD="12-47":"13-20",PRSOLDPPD="12-48":"13-21",PRSOLDPPD="12-49":"13-22",PRSOLDPPD="12-50":"13-23",PRSOLDPPD="12-51":"13-24",1:PRSNEWPPD)
. . . S PRSNEWPPD=$S(PRSOLDPPD="12-52":"13-25",PRSOLDPPD="12-53":"13-26",1:PRSNEWPPD)
. . S DA=PRSPPIEN,DA(1)=PRSMIEN,DR=".01///^S X=PRSNEWPPD",DIE="^PRST(458.7,PRSMIEN,9,"
. . D ^DIE
. . K DA,DA(1),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["13-" 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(DASH,"-",53)="",PRSMIEN=""
D BMES^XPDUTL("Pay periods corrected for these Part-Time Physicians")
D MES^XPDUTL(DASH)
; 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[HPRSXP140 2789 printed Dec 13, 2024@02:28:55 Page 2
PRSXP140 ;WCIOFO/RRG-CORRECT INCORRECT ESR PAY PERIODS ;08/05/2014
+1 ;;4.0;PAID;**140**;Sep 21, 1995;Build 6
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
+6 ; This program 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,DASH,TIME,Y,PRSPTP,PRSPTPNAME,%
+4 DO NOW^%DTC
SET Y=%
+5 DO DD^%DT
SET TIME=Y
+6 DO BMES^XPDUTL("Routine PRSXP140 beginning at "_TIME_".")
+7 DO MEMO
+8 IF $DATA(^TMP($JOB))
DO DISPLAY
+9 DO BMES^XPDUTL("Routine PRSXP140 processing complete.")
+10 KILL DA,DR,DIE,PRSMIEN,PRSOLDPPD,PRSNEWPPD,PRSPPIEN,DASH,TIME,Y,PRSPTP,^TMP($JOB),%,PRSPTPNAME
+11 QUIT
+12 ;
MEMO ; Loop through memos - correct bad pay period records
+1 KILL DA,DA(1),DR,DIE
+2 SET PRSMIEN=0
SET PRSOLDPPD=""
SET PRSIEN=""
+3 FOR
SET PRSMIEN=$ORDER(^PRST(458.7,PRSMIEN))
if PRSMIEN]999999!(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'["12-"
QUIT
+7 IF PRSOLDPPD']"12-27"
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="12-28":"13-01",PRSOLDPPD="12-29":"13-02",PRSOLDPPD="12-30":"13-03",PRSOLDPPD="12-31":"13-04",PRSOLDPPD="12-32":"13-05",PRSOLDPPD="12-33":"13-06",PRSOLDPPD="12-34":"13-07",PRSOLDPPD="12-35":"1
3-08",1:PRSNEWPPD)
+11 SET PRSNEWPPD=$SELECT(PRSOLDPPD="12-36":"13-09",PRSOLDPPD="12-37":"13-10",PRSOLDPPD="12-38":"13-11",PRSOLDPPD="12-39":"13-12",PRSOLDPPD="12-40":"13-13",PRSOLDPPD="12-41":"13-14",PRSOLDPPD="12-42":"13-15",PRSOLDPPD="12-43":"1
3-16",1:PRSNEWPPD)
+12 SET PRSNEWPPD=$SELECT(PRSOLDPPD="12-44":"13-17",PRSOLDPPD="12-45":"13-18",PRSOLDPPD="12-46":"13-19",PRSOLDPPD="12-47":"13-20",PRSOLDPPD="12-48":"13-21",PRSOLDPPD="12-49":"13-22",PRSOLDPPD="12-50":"13-23",PRSOLDPPD="12-51":"1
3-24",1:PRSNEWPPD)
+13 SET PRSNEWPPD=$SELECT(PRSOLDPPD="12-52":"13-25",PRSOLDPPD="12-53":"13-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,DA(1),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["13-"
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(DASH,"-",53)=""
SET PRSMIEN=""
+2 DO BMES^XPDUTL("Pay periods corrected for these Part-Time Physicians")
+3 DO MES^XPDUTL(DASH)
+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 ;
