PRSPUT1 ;WOIFO/MGD - PART TIME PHYSICIAN UTILITIES #1 ;05/17/05
;;4.0;PAID;**93**;Sep 21, 1995;Build 7
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;The following routine contains various utilities for the Part Time
;Physician functionality that was added as part of patch PRS*4.0*93.
;
;----------------------------------------------------------------------
; Determine the IEN of the PT Physician's memorandum if any for the
; current date or the date specified in the MDAT parameter.
; Input: PTPIEN - IEN of the PT Physician
; MDAT - Optional - date within memorandum in FileMan format
;
; Output: IEN^STATUS
; IEN - of the PT Phy's memorandum in the #458.7 file or 0
; STATUS - of the memorandum
;-----------------------------------------------------------------------
MIEN(PRSIEN,MDAT) ;
Q:'PRSIEN 0_"^"
N ENDAT,MDATA,QUIT,STATUS,STDAT,TDAT,MIEN
S MDAT=$G(MDAT,DT)
S (MIEN,QUIT)=0
F S MIEN=$O(^PRST(458.7,"B",PRSIEN,MIEN)) Q:'MIEN D Q:QUIT
. S MDATA=$G(^PRST(458.7,MIEN,0))
. S STDAT=$P(MDATA,U,2) ; START DATE OF MEMORANDUM
. S ENDAT=$P(MDATA,U,3) ; END DATE OF MEMORANDUM
. S STATUS=$P(MDATA,U,6) ; STATUS OF MEMORANDUM
. S TDAT=$P($G(^PRST(458.7,MIEN,4)),U,1) ; TERMINATION DATE
. I TDAT D
. . I TDAT<ENDAT S ENDAT=TDAT
. I MDAT'<STDAT,MDAT'>ENDAT S QUIT=1
I MIEN="" S MIEN=0,STATUS=0
Q MIEN_"^"_STATUS
;
;-----------------------------------------------------------------------
;Display information on a PT Physician's memoranda
; Input: PRSIEN - IEN of the PT Physician.
; SCRTTL - Title for the screen.
; ARRAY - The array where the message to be printed will be
; stored. (optional) If not specified, no array will
; be created.
; INDEX - The index where the array will start. (optional) This
; will be set to 1 if no index is passed.
; PPI - Optional: IEN of the desired PP. If supplied, the
; external format will be displayed on line
;
; Output: VA header, screen title and 10 fields to identify the PT Phy
; Array with the same data if the ARRAY parameter is passed.
;-----------------------------------------------------------------------
HDR(PRSIEN,SCRTTL,ARRAY,INDEX,PPI) ;
Q:'PRSIEN
S SCRTTL=$G(SCRTTL,"")
S ARRAY=$G(ARRAY,"")
I $G(INDEX)="",($G(ARRAY)'="") D INDEX
N C0,DATE,PPE,SSN,TAB,TEXT,X,YR
I $G(PPI)="" D ; If no PPI passed in get last PP in #459
. S PPE="A",PPE=$O(^PRST(459,PPE),-1)
. S PPE=$P($G(^PRST(459,PPE,0)),U,1)
I $G(PPI)>0 S PPE=$P($G(^PRST(458,PPI,0)),U,1)
S TEXT="PP:"_PPE,$E(TEXT,26)="",TEXT=TEXT_"VA TIME & ATTENDANCE SYSTEM"
D NOW^%DTC
S YR=%I(3)+1700,YR=$E(YR,3,4)
S DATE=%I(1)_"/"_%I(2)_"/"_YR
S $E(TEXT,73)="",TEXT=TEXT_DATE
D A1 ; Line #1
S TAB=39-($L(SCRTTL)\2)
S $E(TEXT,TAB)="",TEXT=TEXT_SCRTTL
D A1 ; Line #2
S C0=^PRSPC(PRSIEN,0)
S TEXT=$P(C0,U,1),$E(TEXT,70)=""
S SSN=$P(C0,U,9)
S SSN="XXX-XX-"_$E(SSN,6,9)
S TEXT=TEXT_SSN
D A1 ; Line #3
S TEXT="Pay Plan: "_$P(C0,"^",21)_" Duty Basis: "_$P(C0,"^",10)
S TEXT=TEXT_" FLSA: "_$P(C0,"^",12)_" Normal Hours: "
S TEXT=TEXT_$J($P(C0,"^",16),3)_" Comp/Flex: "
S TEXT=TEXT_$P($G(^PRSPC(PRSIEN,1)),"^",7)
D A1 ; Line #4
S TEXT="T&L: "_$P(C0,"^",8),$E(TEXT,69)=""
S TEXT=TEXT_"Station: "_$P(C0,"^",7)
D A1 ; Line #5
K INDEX,%I
Q
;
;-----------------------------------------------------------------------
; Display information on a PT Physician's memoranda
; Input: PRSIEN - IEN of the PT Physician
; MIEN - IEN of the PT Phy's memorandum in #458.7
; ARRAY - The array where the message to be printed will be
; stored. (Optional) If not specified, no array will
; be created.
; INDEX - The index where the array will start. (optional) This
; will be set to 1 if no index is passed.
; HRSCO - Carrryover Hours from a prior memorandum. (optional)
;
; Output: 4 line summary of the PT Phy's current memorandum
; Array with the same data if the ARRAY parameter is passed.
;-----------------------------------------------------------------------
MEM(PRSIEN,MIEN,ARRAY,INDEX,HRSCO) ;
Q:'PRSIEN&('MIEN)
I $G(INDEX)="",($G(ARRAY)'="") D INDEX
N AHRS,AHTCM,COHRS,DATA,EDAT,ENDDAT,HRSWK,HTSHBW,I,IEN458,LASTDAY,LASTPP
N LASTPPE,LPPP,NPHRS,OTHRS,POHC,POMC,POT,PPP,QUIT,TAB,TDAT,TDATEX,TEXT
N THRSWK,TTEXT,WPHRS
; Load 0 node from #458.7. Quit if it doesn't exist
S DATA=$G(^PRST(458.7,MIEN,0))
Q:DATA=""
; Determine last PP processed
S LASTPP="A"
S LASTPP=$O(^PRST(459,LASTPP),-1)
Q:'LASTPP
S LASTPPE=$P(^PRST(459,LASTPP,0),U,1)
S IEN458="",IEN458=$O(^PRST(458,"B",LASTPPE,IEN458))
Q:'IEN458
S LASTDAY=$P($G(^PRST(458,IEN458,2)),U,14)
S TTEXT="Memorandum & Leave Status thru PP "_LASTPPE_" Ending "_LASTDAY
S TAB=40-($L(TTEXT)\2)
S $E(TEXT,TAB)="",TEXT=TEXT_TTEXT
D A1 ; Line #1
S Y=$P(DATA,U,2) ; START DATE
D DD^%DT
S STDAT=Y
S (EDAT,Y)=$P(DATA,U,3) ; END DATE
D DD^%DT
S ENDDAT=Y
; Check for Termination
S (TDAT,Y)=+$G(^PRST(458.7,MIEN,4))
D DD^%DT
S TDATEX=Y ; Termination Date External
S AHRS=$P(DATA,U,4) ; AGREED HOURS
S COHRS=$P(DATA,U,9) ; CARRYOVER HOURS
S HRSCO=$G(HRSCO,0) ; HRS CARRIED OVER FROM PRIOR MEMO
S NPHRS=$P(DATA,U,12) ; NON-PAY HOURS
S WPHRS=$P(DATA,U,13) ; WITHOUT PAY HOURS
S THRSWK=0.00 ; TOTAL HOURS WORKED
S POMC=0.00 ; PERCENTAGE OF MEMORANDA COMPLETED
S POHC=0.00 ; PERCENTAGE OF HOURS COMPLETED
S AHTCM=0.00 ; AVERAGE HOURS TO COMPLETE MEMORANDUM
S POT=0.00 ; % OFF TARGET
S OTHRS=0.00 ; OFF TARGET HOURS
S HRSWK=0.00 ; HRS TOTAL FROM WORKED PAY PERIODS
;
S $E(TEXT,2)="",TEXT=TEXT_"Start Date: "_STDAT
S $E(TEXT,29,31)="| ",TEXT=TEXT_"Agreed Hours: "_$J(AHRS,7,2)
S $E(TEXT,55,57)="| ",TEXT=TEXT_" LWOP Hrs: "_$J(WPHRS,7,2)
D A1 ; Line #2
;
S LPPP=$$MEMCPP^PRSPUT3(MIEN)
S PPP=$P(LPPP,U,2),LPPP=$P(LPPP,U,1)
; Check to see if last PP certified in #458 is in #459
I LPPP'="",'$D(^PRST(459,"B",LPPP)) S PPP=PPP-1
; Loop to determine the total hours worked from multiple
F I=1:1:PPP D
. S HRSWK=HRSWK+$$GET1^DIQ(458.701,I_","_MIEN_",",1)
S THRSWK=HRSWK+COHRS+HRSCO ; Adjust for carryover hours
; Hrs That Should Have Been Worked - has any NP and WP included
S HTSHBW=((AHRS/26)*PPP)-NPHRS-WPHRS
S OTHRS=THRSWK-HTSHBW
S POHC=THRSWK/(AHRS-NPHRS-WPHRS)*100 ; Adjust % or Hrs Completed
; Only calculate the following if memo has started and not ended
I PPP,PPP<26 D
. I HTSHBW'=THRSWK D ; PTP has worked more or less than Ave Hrs/PP
. . I THRSWK'<(AHRS-NPHRS-WPHRS) S AHTCM=0
. . I THRSWK<(AHRS-NPHRS-WPHRS) S AHTCM=AHRS-THRSWK-NPHRS-WPHRS/(26-PPP)
. . S POT=(AHRS/26*PPP)-WPHRS-NPHRS
. . S POT=THRSWK-POT/POT,POT=POT*100
. I HTSHBW=THRSWK D ; PTP has worked exactly Ave Hrs/PP
. . S AHTCM=AHRS-THRSWK-WPHRS-NPHRS/(26-PPP)
. . S POT=0
I PPP=26 D ; Memo has ended
. S AHTCM=0
. S POT=(AHRS/26*PPP)-WPHRS-NPHRS
. S POT=THRSWK-POT/POT,POT=POT*100
I PPP=0 D ; 1st PP hasn't been processed
. S AHTCM=AHRS-COHRS/26
. S POT=0
I TDAT D
. S $E(TEXT,2)="",TEXT=TEXT_"TERMINATED: "_TDATEX
I TDAT=0 S $E(TEXT,4)="",TEXT=TEXT_"End Date: "_ENDDAT
S $E(TEXT,29,31)="| ",TEXT=TEXT_"Hours Worked: "_$J(HRSWK,7,2)
S $E(TEXT,55,57)="| ",TEXT=TEXT_" Non Pay Hrs: "_$J(NPHRS,7,2)
D A1 ; Line #3
;
S POMC=PPP_" of 26 PP = "_$J(100*(PPP/26),6,2)_"%"
I PPP<10 S $E(TEXT,6)="",TEXT=TEXT_POMC
I PPP>9 S $E(TEXT,5)="",TEXT=TEXT_POMC
S $E(TEXT,29,30)="| "
S TEXT=TEXT_"Carryover Hrs: "_$J($S(HRSCO:HRSCO,1:COHRS),7,2)
S $E(TEXT,55,57)="| ",TEXT=TEXT_"Off Target Hrs: "_$J(OTHRS,7,2)
D A1 ; Line #4
;
S TEXT="% Hrs Completed = "_$J(POHC,6,2)_"%"
S $E(TEXT,29,31)="| ",TEXT=TEXT_" Total Hrs: "
S TEXT=TEXT_$J(THRSWK,7,2)
S $E(TEXT,55,57)="| ",TEXT=TEXT_" Off Target %: "_$J(POT,7,2)
D A1 ; Line #5
;
I PPP<26 D
. S TEXT=(AHRS-NPHRS-WPHRS)-THRSWK,TEXT=TEXT/(26-PPP)
. S TEXT=$FN(TEXT,"",2)
. S TEXT=" Agreement will be met by averaging "_TEXT
. S TEXT=TEXT_" Hrs/PP during remainder of memo."
;
I PPP=26 D
. S $E(TEXT,30)="",TEXT=TEXT_"This memorandum has ended"
;
I TDAT D
. I LPPP'="" D
. . S LPPP=$O(^PRST(458,"B",LPPP,0))
. . S LPPP=$P($G(^PRST(458,LPPP,1)),U,14)
. . I TDAT'>LPPP D Q
. . . S TEXT="",$E(TEXT,30)="",TEXT=TEXT_"This memorandum has ended"
;
D A1 ; Line #6
K INDEX,Y
Q
;
A1 ; Set TEXT into the array
;
N A1
W !,TEXT
I $G(ARRAY)'="" D
. S A1="S "_ARRAY_INDEX_")="_""""_TEXT_""""
. X A1
. S INDEX=INDEX+1
S TEXT=""
Q
;
INDEX ; Get last index in array if not passed in
;
S INDEX="S INDEX=$O("_ARRAY_"""A""),-1)"
X INDEX
I 'INDEX S INDEX=1 Q
I INDEX S INDEX=INDEX+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSPUT1 8994 printed Dec 13, 2024@02:28:20 Page 2
PRSPUT1 ;WOIFO/MGD - PART TIME PHYSICIAN UTILITIES #1 ;05/17/05
+1 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;The following routine contains various utilities for the Part Time
+5 ;Physician functionality that was added as part of patch PRS*4.0*93.
+6 ;
+7 ;----------------------------------------------------------------------
+8 ; Determine the IEN of the PT Physician's memorandum if any for the
+9 ; current date or the date specified in the MDAT parameter.
+10 ; Input: PTPIEN - IEN of the PT Physician
+11 ; MDAT - Optional - date within memorandum in FileMan format
+12 ;
+13 ; Output: IEN^STATUS
+14 ; IEN - of the PT Phy's memorandum in the #458.7 file or 0
+15 ; STATUS - of the memorandum
+16 ;-----------------------------------------------------------------------
MIEN(PRSIEN,MDAT) ;
+1 if 'PRSIEN
QUIT 0_"^"
+2 NEW ENDAT,MDATA,QUIT,STATUS,STDAT,TDAT,MIEN
+3 SET MDAT=$GET(MDAT,DT)
+4 SET (MIEN,QUIT)=0
+5 FOR
SET MIEN=$ORDER(^PRST(458.7,"B",PRSIEN,MIEN))
if 'MIEN
QUIT
Begin DoDot:1
+6 SET MDATA=$GET(^PRST(458.7,MIEN,0))
+7 ; START DATE OF MEMORANDUM
SET STDAT=$PIECE(MDATA,U,2)
+8 ; END DATE OF MEMORANDUM
SET ENDAT=$PIECE(MDATA,U,3)
+9 ; STATUS OF MEMORANDUM
SET STATUS=$PIECE(MDATA,U,6)
+10 ; TERMINATION DATE
SET TDAT=$PIECE($GET(^PRST(458.7,MIEN,4)),U,1)
+11 IF TDAT
Begin DoDot:2
+12 IF TDAT<ENDAT
SET ENDAT=TDAT
End DoDot:2
+13 IF MDAT'<STDAT
IF MDAT'>ENDAT
SET QUIT=1
End DoDot:1
if QUIT
QUIT
+14 IF MIEN=""
SET MIEN=0
SET STATUS=0
+15 QUIT MIEN_"^"_STATUS
+16 ;
+17 ;-----------------------------------------------------------------------
+18 ;Display information on a PT Physician's memoranda
+19 ; Input: PRSIEN - IEN of the PT Physician.
+20 ; SCRTTL - Title for the screen.
+21 ; ARRAY - The array where the message to be printed will be
+22 ; stored. (optional) If not specified, no array will
+23 ; be created.
+24 ; INDEX - The index where the array will start. (optional) This
+25 ; will be set to 1 if no index is passed.
+26 ; PPI - Optional: IEN of the desired PP. If supplied, the
+27 ; external format will be displayed on line
+28 ;
+29 ; Output: VA header, screen title and 10 fields to identify the PT Phy
+30 ; Array with the same data if the ARRAY parameter is passed.
+31 ;-----------------------------------------------------------------------
HDR(PRSIEN,SCRTTL,ARRAY,INDEX,PPI) ;
+1 if 'PRSIEN
QUIT
+2 SET SCRTTL=$GET(SCRTTL,"")
+3 SET ARRAY=$GET(ARRAY,"")
+4 IF $GET(INDEX)=""
IF ($GET(ARRAY)'="")
DO INDEX
+5 NEW C0,DATE,PPE,SSN,TAB,TEXT,X,YR
+6 ; If no PPI passed in get last PP in #459
IF $GET(PPI)=""
Begin DoDot:1
+7 SET PPE="A"
SET PPE=$ORDER(^PRST(459,PPE),-1)
+8 SET PPE=$PIECE($GET(^PRST(459,PPE,0)),U,1)
End DoDot:1
+9 IF $GET(PPI)>0
SET PPE=$PIECE($GET(^PRST(458,PPI,0)),U,1)
+10 SET TEXT="PP:"_PPE
SET $EXTRACT(TEXT,26)=""
SET TEXT=TEXT_"VA TIME & ATTENDANCE SYSTEM"
+11 DO NOW^%DTC
+12 SET YR=%I(3)+1700
SET YR=$EXTRACT(YR,3,4)
+13 SET DATE=%I(1)_"/"_%I(2)_"/"_YR
+14 SET $EXTRACT(TEXT,73)=""
SET TEXT=TEXT_DATE
+15 ; Line #1
DO A1
+16 SET TAB=39-($LENGTH(SCRTTL)\2)
+17 SET $EXTRACT(TEXT,TAB)=""
SET TEXT=TEXT_SCRTTL
+18 ; Line #2
DO A1
+19 SET C0=^PRSPC(PRSIEN,0)
+20 SET TEXT=$PIECE(C0,U,1)
SET $EXTRACT(TEXT,70)=""
+21 SET SSN=$PIECE(C0,U,9)
+22 SET SSN="XXX-XX-"_$EXTRACT(SSN,6,9)
+23 SET TEXT=TEXT_SSN
+24 ; Line #3
DO A1
+25 SET TEXT="Pay Plan: "_$PIECE(C0,"^",21)_" Duty Basis: "_$PIECE(C0,"^",10)
+26 SET TEXT=TEXT_" FLSA: "_$PIECE(C0,"^",12)_" Normal Hours: "
+27 SET TEXT=TEXT_$JUSTIFY($PIECE(C0,"^",16),3)_" Comp/Flex: "
+28 SET TEXT=TEXT_$PIECE($GET(^PRSPC(PRSIEN,1)),"^",7)
+29 ; Line #4
DO A1
+30 SET TEXT="T&L: "_$PIECE(C0,"^",8)
SET $EXTRACT(TEXT,69)=""
+31 SET TEXT=TEXT_"Station: "_$PIECE(C0,"^",7)
+32 ; Line #5
DO A1
+33 KILL INDEX,%I
+34 QUIT
+35 ;
+36 ;-----------------------------------------------------------------------
+37 ; Display information on a PT Physician's memoranda
+38 ; Input: PRSIEN - IEN of the PT Physician
+39 ; MIEN - IEN of the PT Phy's memorandum in #458.7
+40 ; ARRAY - The array where the message to be printed will be
+41 ; stored. (Optional) If not specified, no array will
+42 ; be created.
+43 ; INDEX - The index where the array will start. (optional) This
+44 ; will be set to 1 if no index is passed.
+45 ; HRSCO - Carrryover Hours from a prior memorandum. (optional)
+46 ;
+47 ; Output: 4 line summary of the PT Phy's current memorandum
+48 ; Array with the same data if the ARRAY parameter is passed.
+49 ;-----------------------------------------------------------------------
MEM(PRSIEN,MIEN,ARRAY,INDEX,HRSCO) ;
+1 if 'PRSIEN&('MIEN)
QUIT
+2 IF $GET(INDEX)=""
IF ($GET(ARRAY)'="")
DO INDEX
+3 NEW AHRS,AHTCM,COHRS,DATA,EDAT,ENDDAT,HRSWK,HTSHBW,I,IEN458,LASTDAY,LASTPP
+4 NEW LASTPPE,LPPP,NPHRS,OTHRS,POHC,POMC,POT,PPP,QUIT,TAB,TDAT,TDATEX,TEXT
+5 NEW THRSWK,TTEXT,WPHRS
+6 ; Load 0 node from #458.7. Quit if it doesn't exist
+7 SET DATA=$GET(^PRST(458.7,MIEN,0))
+8 if DATA=""
QUIT
+9 ; Determine last PP processed
+10 SET LASTPP="A"
+11 SET LASTPP=$ORDER(^PRST(459,LASTPP),-1)
+12 if 'LASTPP
QUIT
+13 SET LASTPPE=$PIECE(^PRST(459,LASTPP,0),U,1)
+14 SET IEN458=""
SET IEN458=$ORDER(^PRST(458,"B",LASTPPE,IEN458))
+15 if 'IEN458
QUIT
+16 SET LASTDAY=$PIECE($GET(^PRST(458,IEN458,2)),U,14)
+17 SET TTEXT="Memorandum & Leave Status thru PP "_LASTPPE_" Ending "_LASTDAY
+18 SET TAB=40-($LENGTH(TTEXT)\2)
+19 SET $EXTRACT(TEXT,TAB)=""
SET TEXT=TEXT_TTEXT
+20 ; Line #1
DO A1
+21 ; START DATE
SET Y=$PIECE(DATA,U,2)
+22 DO DD^%DT
+23 SET STDAT=Y
+24 ; END DATE
SET (EDAT,Y)=$PIECE(DATA,U,3)
+25 DO DD^%DT
+26 SET ENDDAT=Y
+27 ; Check for Termination
+28 SET (TDAT,Y)=+$GET(^PRST(458.7,MIEN,4))
+29 DO DD^%DT
+30 ; Termination Date External
SET TDATEX=Y
+31 ; AGREED HOURS
SET AHRS=$PIECE(DATA,U,4)
+32 ; CARRYOVER HOURS
SET COHRS=$PIECE(DATA,U,9)
+33 ; HRS CARRIED OVER FROM PRIOR MEMO
SET HRSCO=$GET(HRSCO,0)
+34 ; NON-PAY HOURS
SET NPHRS=$PIECE(DATA,U,12)
+35 ; WITHOUT PAY HOURS
SET WPHRS=$PIECE(DATA,U,13)
+36 ; TOTAL HOURS WORKED
SET THRSWK=0.00
+37 ; PERCENTAGE OF MEMORANDA COMPLETED
SET POMC=0.00
+38 ; PERCENTAGE OF HOURS COMPLETED
SET POHC=0.00
+39 ; AVERAGE HOURS TO COMPLETE MEMORANDUM
SET AHTCM=0.00
+40 ; % OFF TARGET
SET POT=0.00
+41 ; OFF TARGET HOURS
SET OTHRS=0.00
+42 ; HRS TOTAL FROM WORKED PAY PERIODS
SET HRSWK=0.00
+43 ;
+44 SET $EXTRACT(TEXT,2)=""
SET TEXT=TEXT_"Start Date: "_STDAT
+45 SET $EXTRACT(TEXT,29,31)="| "
SET TEXT=TEXT_"Agreed Hours: "_$JUSTIFY(AHRS,7,2)
+46 SET $EXTRACT(TEXT,55,57)="| "
SET TEXT=TEXT_" LWOP Hrs: "_$JUSTIFY(WPHRS,7,2)
+47 ; Line #2
DO A1
+48 ;
+49 SET LPPP=$$MEMCPP^PRSPUT3(MIEN)
+50 SET PPP=$PIECE(LPPP,U,2)
SET LPPP=$PIECE(LPPP,U,1)
+51 ; Check to see if last PP certified in #458 is in #459
+52 IF LPPP'=""
IF '$DATA(^PRST(459,"B",LPPP))
SET PPP=PPP-1
+53 ; Loop to determine the total hours worked from multiple
+54 FOR I=1:1:PPP
Begin DoDot:1
+55 SET HRSWK=HRSWK+$$GET1^DIQ(458.701,I_","_MIEN_",",1)
End DoDot:1
+56 ; Adjust for carryover hours
SET THRSWK=HRSWK+COHRS+HRSCO
+57 ; Hrs That Should Have Been Worked - has any NP and WP included
+58 SET HTSHBW=((AHRS/26)*PPP)-NPHRS-WPHRS
+59 SET OTHRS=THRSWK-HTSHBW
+60 ; Adjust % or Hrs Completed
SET POHC=THRSWK/(AHRS-NPHRS-WPHRS)*100
+61 ; Only calculate the following if memo has started and not ended
+62 IF PPP
IF PPP<26
Begin DoDot:1
+63 ; PTP has worked more or less than Ave Hrs/PP
IF HTSHBW'=THRSWK
Begin DoDot:2
+64 IF THRSWK'<(AHRS-NPHRS-WPHRS)
SET AHTCM=0
+65 IF THRSWK<(AHRS-NPHRS-WPHRS)
SET AHTCM=AHRS-THRSWK-NPHRS-WPHRS/(26-PPP)
+66 SET POT=(AHRS/26*PPP)-WPHRS-NPHRS
+67 SET POT=THRSWK-POT/POT
SET POT=POT*100
End DoDot:2
+68 ; PTP has worked exactly Ave Hrs/PP
IF HTSHBW=THRSWK
Begin DoDot:2
+69 SET AHTCM=AHRS-THRSWK-WPHRS-NPHRS/(26-PPP)
+70 SET POT=0
End DoDot:2
End DoDot:1
+71 ; Memo has ended
IF PPP=26
Begin DoDot:1
+72 SET AHTCM=0
+73 SET POT=(AHRS/26*PPP)-WPHRS-NPHRS
+74 SET POT=THRSWK-POT/POT
SET POT=POT*100
End DoDot:1
+75 ; 1st PP hasn't been processed
IF PPP=0
Begin DoDot:1
+76 SET AHTCM=AHRS-COHRS/26
+77 SET POT=0
End DoDot:1
+78 IF TDAT
Begin DoDot:1
+79 SET $EXTRACT(TEXT,2)=""
SET TEXT=TEXT_"TERMINATED: "_TDATEX
End DoDot:1
+80 IF TDAT=0
SET $EXTRACT(TEXT,4)=""
SET TEXT=TEXT_"End Date: "_ENDDAT
+81 SET $EXTRACT(TEXT,29,31)="| "
SET TEXT=TEXT_"Hours Worked: "_$JUSTIFY(HRSWK,7,2)
+82 SET $EXTRACT(TEXT,55,57)="| "
SET TEXT=TEXT_" Non Pay Hrs: "_$JUSTIFY(NPHRS,7,2)
+83 ; Line #3
DO A1
+84 ;
+85 SET POMC=PPP_" of 26 PP = "_$JUSTIFY(100*(PPP/26),6,2)_"%"
+86 IF PPP<10
SET $EXTRACT(TEXT,6)=""
SET TEXT=TEXT_POMC
+87 IF PPP>9
SET $EXTRACT(TEXT,5)=""
SET TEXT=TEXT_POMC
+88 SET $EXTRACT(TEXT,29,30)="| "
+89 SET TEXT=TEXT_"Carryover Hrs: "_$JUSTIFY($SELECT(HRSCO:HRSCO,1:COHRS),7,2)
+90 SET $EXTRACT(TEXT,55,57)="| "
SET TEXT=TEXT_"Off Target Hrs: "_$JUSTIFY(OTHRS,7,2)
+91 ; Line #4
DO A1
+92 ;
+93 SET TEXT="% Hrs Completed = "_$JUSTIFY(POHC,6,2)_"%"
+94 SET $EXTRACT(TEXT,29,31)="| "
SET TEXT=TEXT_" Total Hrs: "
+95 SET TEXT=TEXT_$JUSTIFY(THRSWK,7,2)
+96 SET $EXTRACT(TEXT,55,57)="| "
SET TEXT=TEXT_" Off Target %: "_$JUSTIFY(POT,7,2)
+97 ; Line #5
DO A1
+98 ;
+99 IF PPP<26
Begin DoDot:1
+100 SET TEXT=(AHRS-NPHRS-WPHRS)-THRSWK
SET TEXT=TEXT/(26-PPP)
+101 SET TEXT=$FNUMBER(TEXT,"",2)
+102 SET TEXT=" Agreement will be met by averaging "_TEXT
+103 SET TEXT=TEXT_" Hrs/PP during remainder of memo."
End DoDot:1
+104 ;
+105 IF PPP=26
Begin DoDot:1
+106 SET $EXTRACT(TEXT,30)=""
SET TEXT=TEXT_"This memorandum has ended"
End DoDot:1
+107 ;
+108 IF TDAT
Begin DoDot:1
+109 IF LPPP'=""
Begin DoDot:2
+110 SET LPPP=$ORDER(^PRST(458,"B",LPPP,0))
+111 SET LPPP=$PIECE($GET(^PRST(458,LPPP,1)),U,14)
+112 IF TDAT'>LPPP
Begin DoDot:3
+113 SET TEXT=""
SET $EXTRACT(TEXT,30)=""
SET TEXT=TEXT_"This memorandum has ended"
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
+114 ;
+115 ; Line #6
DO A1
+116 KILL INDEX,Y
+117 QUIT
+118 ;
A1 ; Set TEXT into the array
+1 ;
+2 NEW A1
+3 WRITE !,TEXT
+4 IF $GET(ARRAY)'=""
Begin DoDot:1
+5 SET A1="S "_ARRAY_INDEX_")="_""""_TEXT_""""
+6 XECUTE A1
+7 SET INDEX=INDEX+1
End DoDot:1
+8 SET TEXT=""
+9 QUIT
+10 ;
INDEX ; Get last index in array if not passed in
+1 ;
+2 SET INDEX="S INDEX=$O("_ARRAY_"""A""),-1)"
+3 XECUTE INDEX
+4 IF 'INDEX
SET INDEX=1
QUIT
+5 IF INDEX
SET INDEX=INDEX+1
+6 QUIT
