Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRSPEEM

PRSPEEM.m

Go to the documentation of this file. 
  1. PRSPEEM ;HISC/MGD - ESR EXCEPTIONS FOR ENTIRE MEMORANDA ;06/15/05
  1.  ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  Q
  1. PAY ; Payroll Entry
  1.  S PRSTLV=7,QUITX=0
  1.  D T0
  1.  Q
  1.  ;
  1. SUP ; Supervisor Entry
  1.  ;
  1.  S PRSTLV=3,QUITX=0
  1. T0 K DIR,^TMP($J,"PRSPEEM"),^TMP($J,"PRSPEEM EMP")
  1.  D TOP ; print header
  1.  D OMIT ; Prompt to omit current Pay Period
  1.  I X="^" D EX Q
  1.  D TLCHK ; Check for Supervisor of just 1 or mult T&L
  1.  I MULT>1 D TL
  1.  I MULT=1 D
  1.  . S TL="ATL"_TLE
  1.  . D EMP
  1.  I '$D(^TMP($J,"PRSPEEM")) W !,"No exceptions found for input criteria." Q
  1.  D SCRN1
  1.  D EX
  1.  ;
  1.  Q
  1. OMIT ; Prompt for Omit current pay period
  1.  S DIR(0)="Y"
  1.  S DIR("A")="Would you like to omit the current pay period from this report"
  1.  D ^DIR K DIR
  1.  S OMIT=Y
  1.  Q
  1.  ;
  1. TLCHK ; Check for Supervisor of just 1 or mult T&L
  1.  S MULT=0,I=""
  1.  F  S I=$O(^PRST(455.5,"AS",DUZ,I)) Q:'I  D
  1.  . S MULT=MULT+1,TLI=I,TLE=$P(^PRST(455.5,I,0),U,1)
  1.  Q
  1.  ;
  1. TL ; Loop to enter T&Ls and employees
  1.  N SEL ; local array to hold selected t&ls and employees
  1.  S QUIT1=0
  1.  F  D  Q:QUIT1
  1.  . D ^PRSAUTL
  1.  . I 'TLI S QUIT1=1 Q
  1.  . I $D(SEL(TLI,"A")) D  Q
  1.  ..  W !!,?5,"You have already selected all the employees in T&L unit ",$G(TLE),"."
  1.  ..  W !,?5,"Select another T&L OR enter <return> to begin report."
  1.  . D EMP
  1.  Q
  1.  ;
  1.  ; Loop for individual employees in a T&L
  1. EMP S QUIT2=0
  1.  S DIR(0)="SM^A:All PT Physicians in the T&L;I:Individual PT Physicians"
  1.  S DIR("A")="Enter Choice"
  1.  D ^DIR K DIR
  1.  ; Loop for All employee in a T&L
  1.  I Y="A" D  Q
  1.  . K SEL(TLI) S SEL(TLI,"A")=""
  1.  . K ^TMP($J,"PRSPEEM",TLI)
  1.  . S EMP="",TL="ATL"_TLE
  1.  . F  S EMP=$O(^PRSPC(TL,EMP)) Q:EMP=""  D
  1.  . . S PRSIEN=$O(^PRSPC(TL,EMP,0))
  1.  . . Q:'PRSIEN
  1.  . . D MEM ; Check for memos w/ status = ACTIVE or RECONCILIATION STARTED
  1.  . . S QUIT2=1
  1.  Q:QUIT2
  1.  ;
  1.  S PPI=+$G(^PRST(458,"AD",DT)),PRSDT=DT,PTPF=1
  1.  F  D  Q:QUIT2
  1.  . K DIC
  1.  . S DIC("A")=$S('$D(SEL(TLI)):"Select EMPLOYEE: ",1:"Select Another EMPLOYEE: ")
  1.  . S DIC(0)="AEQM",DIC="^PRSPC(",D="ATL"_TLE
  1.  . S DIC("S")="I $P(^(0),""^"",8)=TLE,$D(^PRST(458.7,""B"",+Y)),'$D(SEL(TLI,+Y))"
  1.  . W !
  1.  . D IX^DIC S PRSIEN=+Y
  1.  . I X=""!(X="^") S QUIT2=1 Q
  1.  . S SEL(TLI,PRSIEN)=""
  1.  . D MEM
  1.  Q
  1.  ;
  1. MEM ; Check for memos w/ status of ACTIVE (2) or RECONCILIATION STARTED (3)
  1.  N PPI
  1.  S MIEN=""
  1.  F  S MIEN=$O(^PRST(458.7,"B",PRSIEN,MIEN)) Q:'MIEN  D
  1.  . S DATA0=$G(^PRST(458.7,MIEN,0))
  1.  . S STATUS=$P(DATA0,U,6)
  1.  . Q:STATUS'=2&(STATUS'=3)
  1.  . S TDAT=$P($G(^PRST(458.7,MIEN,4)),U,1)
  1.  . I TDAT S TDAT=+$G(^PRST(458,"AD",TDAT)) ; IEN of termination PP 
  1.  . ; Loop to check for any incomplete days in any PP of the memo
  1.  . S PP=0
  1.  . F I=1:1:26 S PPE=$P($G(^PRST(458.7,MIEN,9,I,0)),U) Q:PPE=""  D
  1.  . . S PPI=$O(^PRST(458,"B",PPE,0))
  1.  . . Q:'PPI
  1.  . . ; If the memo was terminated, only check ESRs up to and
  1.  . . ; including the Termination Date
  1.  . . Q:TDAT&(PPI>TDAT)  ; Don't look past termination PP
  1.  . . S PP=PP+1
  1.  . . S DATA1=$G(^PRST(458,PPI,1)) ; FileMan Dates
  1.  . . Q:'+$$MIEN^PRSPUT1(PRSIEN,$P(DATA1,U,I))
  1.  . . F DAY=1:1:14 D
  1.  . . . S ESRSTAT=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7)),U,1)
  1.  . . . Q:ESRSTAT>3
  1.  . . . S ESRSTATX=$$EXTERNAL^DILFD(458.02,146,"",ESRSTAT)
  1.  . . . I ESRSTATX="" S ESRSTATX="UNKNOWN"
  1.  . . . S Y=$P(DATA1,U,DAY)
  1.  . . . D DD^%DT
  1.  . . . S ^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP,DAY)=Y_U_ESRSTATX
  1.  . . I $D(^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP)) D
  1.  . . . S ^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP)=PPI_U_PPE
  1.  . ; if no exceptions found set up first pay pereiod with no data message
  1.  .   I '$D(^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN)) D
  1.  ..     S PPE=$P($G(^PRST(458.7,MIEN,9,1,0)),U)
  1.  ..     S PPI=$O(^PRST(458,"B",PPE,0))
  1.  ..     S ^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,1)=PPI_U_PPE_U_"*"
  1.  ..     S ^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,1,0)="no exceptions found fo r entire memo"
  1.  Q
  1.  ;
  1. TOP W:$E(IOST,1,2)="C-" @IOF
  1.  W !?26,"VA TIME & ATTENDANCE SYSTEM"
  1.  W !?22,"ESR EXCEPTIONS FOR ENTIRE MEMORANDA",!!
  1.  Q
  1.  ;
  1. TOP1 W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM"
  1.  S SCRTTLX="ESR EXCEPTIONS FOR ENTIRE MEMORANDA"
  1.  I OMIT S SCRTTLX=SCRTTLX_" - CURRENT PP OMITTED"
  1.  S $E(SCRTTL,$S(OMIT:12,1:22))=""
  1.  S SCRTTL=SCRTTL_SCRTTLX
  1.  W !,SCRTTL
  1.  Q
  1.  ;
  1. SCRN1 ; Loop through employees and display data
  1.  W:$E(IOST,1,2)="C-" @IOF
  1.  S TLI="",QUITX=0
  1.  F  S TLI=$O(^TMP($J,"PRSPEEM",TLI)) Q:'TLI  D  Q:QUITX
  1.  . S PRSIEN="",INDEX=1
  1.  . F  S PRSIEN=$O(^TMP($J,"PRSPEEM",TLI,PRSIEN)) Q:'PRSIEN  D  Q:QUITX
  1.  . . K ^TMP($J,"PRSPEEM EMP") ; Kill temporary employee array
  1.  . . S MIEN="",(EMPQT,LIST)=0
  1.  . . F  S MIEN=$O(^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN)) Q:'MIEN  D  Q:QUITX
  1.  . . . S PP="",DAYCNT=0
  1.  . . . F  S PP=$O(^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP)) Q:'PP  D  Q:QUITX
  1.  . . . . S DATA=^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP),LIST=LIST+1
  1.  . . . . S PPI=$P(DATA,U,1),PPE=$P(DATA,U,2)
  1.  . . . . S ITEM(LIST)=DATA
  1.  . . . . I DAYCNT=0 D  ; Display header prior to 1st PP in a memo
  1.  . . . . . S ARRAY="^TMP($J,""PRSPEEM EMP"","
  1.  . . . . . S SCRTTL="ESR EXCEPTIONS FOR ENTIRE MEMORANDA"
  1.  . . . . . D HDR^PRSPUT1(PRSIEN,SCRTTL,ARRAY,INDEX,PPI)
  1.  . . . . . D MEM^PRSPUT1(PRSIEN,MIEN,ARRAY)
  1.  . . . . . D AL^PRSPUT3(PRSIEN,ARRAY)
  1.  . . . . . S INDEX="",INDEX=$O(^TMP($J,"PRSPEEM EMP",INDEX),-1)
  1.  . . . . . S TEXT="",INDEX=INDEX+1
  1.  . . . . . D A1^PRSPUT1 ; Blank Line
  1.  . . . . . S TEXT=" #  Pay Period  Date          Status"
  1.  . . . . . D A1^PRSPUT1
  1.  . . . . . S TEXT="------------------------------------"
  1.  . . . . . D A1^PRSPUT1
  1.  . . . . I $P(DATA,U,3)="*" S TEXT="No exceptions found for entire memo" D A1^PRSPUT1 Q
  1.  . . . . S TEXT=$J(PP,2),$E(TEXT,5)="",TEXT=TEXT_PPE
  1.  . . . . F DAY=1:1:14 D  Q:QUITX
  1.  . . . . . Q:'$D(^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP,DAY))
  1.  . . . . . S DATA=^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP,DAY)
  1.  . . . . . S $E(TEXT,17)="",TEXT=TEXT_$P(DATA,U,1) ; External Date
  1.  . . . . . S $E(TEXT,31)="",TEXT=TEXT_$P(DATA,U,2) ; External Status
  1.  . . . . . S DAYCNT=DAYCNT+1
  1.  . . . . . D A1^PRSPUT1
  1.  . . . . . I $Y>(IOSL-3) D PSE
  1.  . . . Q:QUITX
  1.  . . . S $E(TEXT,31,36)="------",INDEX=INDEX+1
  1.  . . . D A1^PRSPUT1
  1.  . . . S $E(TEXT,20)="",TEXT=TEXT_"Total Days: "_DAYCNT
  1.  . . . D A1^PRSPUT1
  1.  . . . I $P(DATA,U,3)="*" D
  1.  . . . .  S QUITX=$$ASK^PRSLIB00(1)
  1.  . . . E  D
  1.  . . . .  D ACTION
  1.  . . . I $E(IOST,1,2)="C-" W @IOF
  1.  Q
  1.  ;
  1. ACTION ; Prompt for action
  1.  S EMPQT=0
  1.  F  D  Q:QUITX!(EMPQT)
  1.  . S TEXT="(P)rint list, (S)elect Item or press Enter to "
  1.  . S TEXT=TEXT_"continue to next employee"
  1.  . W !!,TEXT
  1.  . W !!,"Enter Choice: "
  1.  . R CHOICE:DT
  1.  . S CHOICE=$$UPPER^PRSRUTL(CHOICE)
  1.  . I CHOICE="" S EMPQT=1 Q   ; Go to next employee
  1.  . I CHOICE="^" S QUITX=1 Q  ; Terminate report
  1.  . I CHOICE'="P"&(CHOICE'="S") D  Q
  1.  . . W !!,"Enter P, S or ^ to Quit or press Enter to continue to next employee."
  1.  . I CHOICE="P" D  Q:EMPQT
  1.  . . D DVC1
  1.  . . I POP S EMPQT=1
  1.  . I CHOICE="S" D
  1.  . . F  D  Q:EMPQT!(QUITX)
  1.  . . . I $E(IOST,1,2)="C-" W @IOF
  1.  . . . F I=1:1 Q:'$D(ITEM(I))  W !,I,?5,$P(ITEM(I),U,2)
  1.  . . . W !!,"Select a number between 1 and ",LIST_" : "
  1.  . . . R ITEM:DT
  1.  . . . S ITEM=$$UPPER^PRSRUTL(ITEM)
  1.  . . . I ITEM="" S EMPQT=1 Q   ; Go to next employee
  1.  . . . I ITEM="^" S QUITX=1 Q  ; Terminate report
  1.  . . . Q:'$D(ITEM(ITEM))
  1.  . . . S PPI=+ITEM(ITEM)
  1.  . . . D DVC2
  1.  ;
  1.  Q
  1.  ;
  1. LOOP1 ; Loop to display Summary Screen with list of outstanding ESRs
  1.  I '$D(^TMP($J,"PRSPEEM EMP")) W !,"No part-time physician ESR Exceptions found for selected criteria." Q
  1.  S INDX=""
  1.  F  S INDX=$O(^TMP($J,"PRSPEEM EMP",INDX)) Q:'INDX  D
  1.  . S TEXT=^TMP($J,"PRSPEEM EMP",INDX)
  1.  . W !,TEXT
  1.  Q
  1.  ;
  1. DVC1 ; Display Summary Screen with list of outstanding ESRs
  1.  W !
  1.  K IOP,%ZIS
  1.  S %ZIS("A")="Select Device: ",%ZIS="MQ"
  1.  D ^%ZIS K %ZIS,IOP
  1.  Q:POP
  1.  I $D(IO("Q")) D  Q
  1.  .  S ZTRTN="LOOP1^PRSPEEM"
  1.  .  S ZTSAVE("^TMP($J,""PRSPEEM EMP"",")=""
  1.  .  S ZTDESC="PRS PTP EXCEPTS"
  1.  .  D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Canceled!")
  1.  .  K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
  1.  .  D HOME^%ZIS
  1.  U IO D LOOP1
  1.  D ^%ZISC K %ZIS,IOP
  1.  D H1 ; pause screen
  1.  Q
  1.  ;
  1. DVC2 ; Display PP ESR
  1.  W !
  1.  K IOP,%ZIS
  1.  S %ZIS("A")="Select Device: ",%ZIS="MQ"
  1.  D ^%ZIS K %ZIS,IOP
  1.  Q:POP
  1.  I $D(IO("Q")) D  Q
  1.  .  S ZTRTN="DIS^PRSPDESR"
  1.  .  S ZTSAVE("PRSIEN")="",ZTSAVE("PPI")="",ZTSAVE("PPE")=""
  1.  .  S ZTDESC="PRS PTP DISPLAY ESR"
  1.  .  D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Canceled!")
  1.  .  K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
  1.  .  D HOME^%ZIS
  1.  .  N HOLD S HOLD=$$ASK^PRSLIB00(1)
  1.  U IO D DIS^PRSPDESR
  1.  D ^%ZISC K %ZIS,IOP
  1.  D H1 ; pause screen
  1.  Q
  1.  ;
  1.  ;====================================================================
  1.  ;
  1. PSE ; Pause for screen breaks
  1.  W !
  1.  S DIR(0)="E",DIR("A")="Press RETURN to continue"
  1.  D ^DIR
  1.  I X="^" S QUITX=1 Q
  1.  W @IOF
  1.  Q
  1.  ; 
  1. H1 I $E(IOST,1,2)="C-" R !!,"Press RETURN to Continue.",X:DTIME S:'$T!(X["^") QT=1
  1.  Q
  1. EX ; Clean up variables
  1.  K ARRAY,CHOICE,D,DASH,DATA,DATA0,DATA1,DAY,DAYCNT,DFN
  1.  K EMP,EMPQT,ESRSTAT,ESRSTATX,I,IDAYS,INDEX,INDX,ITEM,LIST,MIEN
  1.  K MULT,OMIT,POP,PP,PPE,PPI,PRSAPGM,PRSDT,PRSIEN,PRSTLV,PTPF
  1.  K QT,QUIT1,QUIT2,QUITX,SCRTTL,SCRTTLX,STATUS,TDAT,TEXT,TL,TLE,TLI,X,Y
  1.  Q