PRSRUT0 ;HISC/JH,JAH-UTILITY ROUTINE FOR PAID ADDIM. REPORTS ;6/24/94
;;4.0;PAID;**2,17,114**;Sep 21, 1995;Build 6
;;Per VHA Directive 2004-038, this routine should not be modified.
QUE ;QUEUE FOR PAID REPORTS
S IOP="Q",%ZIS="Q" D ^%ZIS K %ZIS K:POP IO("Q") I POP S ZTSTOP=1 Q
I $D(IO("Q")) K IO("Q"),IO("C") S ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL,ZTSAVE("IOM")="" D ^%ZTLOAD S:'$D(ZTSK) (ZTSTOP,POP)=1
Q
QUE1 ;QUEUE FOR PAID REPORTS
S %ZIS="Q" D ^%ZIS K %ZIS K:POP IO("Q") S:POP ZTSTOP=0 Q:POP
I $D(IO("Q")) K IO("Q"),IO("C") S ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL D ^%ZTLOAD S:'$D(ZTSK) POP=1
Q
Q ;TERMINAL RESET FROM 132 TO 80 CHARS.
I $E(IOST)="C",IOM=132 S X="IORESET" D ENDR^%ZISS W @X D HOME^%ZIS K %,%T,%XX,%YY,IOHG,IOPAR,IORESET,IOUPAR
Q
;FOOT = Type of system this report is for,
;TYP = Type of report (T&L,T&A,BUDGET,MANPOWER,COST,...),
;TLUNIT = (T&L Unit,T&A Unit,Pay Period,FY,...),
F I=1:1 W ! Q:$Y=(IOSL-3)
Q
Q
CKTOUR(CK) N LL,M,K,KK S M=CK,CK="",KK=1 F K=1:4 S LL=$P(M,"^",K+2) Q:LL="" S %=$F(LVT,";"_LL_":") S:% $P(CK,"^",KK,KK+3)=$P(M,"^",K,K+3) S KK=$S(%:KK+4,1:KK)
Q
TYPSTF S DFN=$O(^PRSPC("SSN",PRSRSSN,0)) N PP D ^PRSAENT S SW(2)=$S($E(ENT,1,2)["D":77,1:73)
Q
TLESEL ;user select T&L units
; set up array:
; TLE(n)="T&L number ^ unit name"
; TLE(n,m) = "ien ^ member name"
; TLE= approving T&L unit
;
N A,B,C,D,E,F,X
; get duz of current user
S USR="",TLE="" D DUZ^PRSRUTL Q:SSN=""
TL ; Select T&L from those allowed
S:SSN'="" USR=$O(^PRSPC("SSN",SSN,0))
K DIC
;
;Z1 for T&L unit file x-ref lookup: T=TimeKeeper, S=Supervisor
S Z1=$S(PRSTLV=2:"T",PRSTLV="3":"S",PRSTLV=7:"S",1:"*")
I PRSR=1 S TLI=$O(^PRST(455.5,"A"_Z1,DUZ,0)) I TLI<1 W !!,*7,"No T&L Units have been assigned to you!" Q
Q:PRSR=3
SEL W ! S DIC="^PRST(455.5,"
S DIC(0)="AEMQ",DIC("A")="Select T&L: "
;screen checks:
; if payroll then all T&L's available OR
; if T&A supervisor then only T&L's that are assigned
S DIC("S")="I PRSR=2!(PRSR=1&($D(^PRST(455.5,Y,Z1,DUZ,0))))"
D ^DIC Q:$D(DTOUT)!$D(DUOUT)!(Y=-1) K DIC S X=$P(Y,"^",2)
D VALSEL I TLE="" W ?($X+2),$C(7),"??" G SEL
P1 ;S TLI=$P($G(^PRSPC(PRSRDUZ,0)),U,8)
Q
P2 S TLE=1,TLE(I)=$P($G(^PRST(455.5,TLI,0)),"^",1,2)
S TLI=$P($G(^PRSPC(PRSRDUZ,0)),U,8)
Q
VALSEL ; Validate input in form 001 or 211,234,333 or 221,2233,345-367,400
S C=0,D=1 F A=1:1 Q:$P(X,",",A)="" D
. I $P(X,",",A)'["-" S I=$P(X,",",A) S TLE(D)=I,D=D+1
. E S B=$P($P(X,",",A),"-"),C=$P($P(X,",",A),"-",2) F I=B:1:C S TLE(D)=I,D=D+1
. Q
CHKSEL ; Check selection array eliminating T&L units not assigned, if not Fiscal.
S TLE=D-1 S I=0 F II=1:1 S I=$O(TLE(I)) Q:I'>0 D
. I $L(TLE(I))<1!'($O(^PRST(455.5,"B",TLE(I),0))) D KILL Q
. S F=$O(^PRST(455.5,"B",TLE(I),0)) I PRSR=1,'$D(^PRST(455.5,F,Z1,DUZ,0)) D KILL
. E S $P(TLE(I),U,2)=$P(^PRST(455.5,F,0),U,2) D GET
. Q
S:D=1 TLE=D Q
KILL K TLE(D) S TLE=TLE-1 Q
ALL S DA=0 F I=1:1 S DA=$O(^PRST(455.5,"A"_Z1,DUZ,DA)) Q:DA'>0 D
. S TLE(I)=$P($G(^PRST(455.5,DA,0)),U,1,2) D GET
. Q
Q
GET S DA(1)="" F II=1:1 S DA(1)=$O(^PRSPC("ATL"_$P(TLE(I),U),DA(1))) Q:DA(1)="" D
. S TLE(I,II)=$O(^PRSPC("ATL"_$P(TLE(I),U),DA(1),0))_"^"_DA(1)
. Q
S TLE=$S(PRSRDUZ:$P($G(^PRSPC(PRSRDUZ,0)),U,8),1:"000"),SW=1 Q
MSG W !!,$C(7),"ENTER CODE(s), ONE OR MORE, SEPERATED BY COMMA(S) ( , ) or ( ALL ) .",! G SEL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSRUT0 3567 printed Sep 23, 2025@20:05:04 Page 2
PRSRUT0 ;HISC/JH,JAH-UTILITY ROUTINE FOR PAID ADDIM. REPORTS ;6/24/94
+1 ;;4.0;PAID;**2,17,114**;Sep 21, 1995;Build 6
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
QUE ;QUEUE FOR PAID REPORTS
+1 SET IOP="Q"
SET %ZIS="Q"
DO ^%ZIS
KILL %ZIS
if POP
KILL IO("Q")
IF POP
SET ZTSTOP=1
QUIT
+2 IF $DATA(IO("Q"))
KILL IO("Q"),IO("C")
SET ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
SET ZTSAVE("IOM")=""
DO ^%ZTLOAD
if '$DATA(ZTSK)
SET (ZTSTOP,POP)=1
+3 QUIT
QUE1 ;QUEUE FOR PAID REPORTS
+1 SET %ZIS="Q"
DO ^%ZIS
KILL %ZIS
if POP
KILL IO("Q")
if POP
SET ZTSTOP=0
if POP
QUIT
+2 IF $DATA(IO("Q"))
KILL IO("Q"),IO("C")
SET ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
DO ^%ZTLOAD
if '$DATA(ZTSK)
SET POP=1
+3 QUIT
Q ;TERMINAL RESET FROM 132 TO 80 CHARS.
+1 IF $EXTRACT(IOST)="C"
IF IOM=132
SET X="IORESET"
DO ENDR^%ZISS
WRITE @X
DO HOME^%ZIS
KILL %,%T,%XX,%YY,IOHG,IOPAR,IORESET,IOUPAR
+2 QUIT
+1 ;FOOT = Type of system this report is for,
+2 ;TYP = Type of report (T&L,T&A,BUDGET,MANPOWER,COST,...),
+3 ;TLUNIT = (T&L Unit,T&A Unit,Pay Period,FY,...),
+4 FOR I=1:1
WRITE !
if $Y=(IOSL-3)
QUIT
+1 QUIT
+1 QUIT
CKTOUR(CK) NEW LL,M,K,KK
SET M=CK
SET CK=""
SET KK=1
FOR K=1:4
SET LL=$PIECE(M,"^",K+2)
if LL=""
QUIT
SET %=$FIND(LVT,";"_LL_":")
if %
SET $PIECE(CK,"^",KK,KK+3)=$PIECE(M,"^",K,K+3)
SET KK=$SELECT(%:KK+4,1:KK)
+1 QUIT
TYPSTF SET DFN=$ORDER(^PRSPC("SSN",PRSRSSN,0))
NEW PP
DO ^PRSAENT
SET SW(2)=$SELECT($EXTRACT(ENT,1,2)["D":77,1:73)
+1 QUIT
TLESEL ;user select T&L units
+1 ; set up array:
+2 ; TLE(n)="T&L number ^ unit name"
+3 ; TLE(n,m) = "ien ^ member name"
+4 ; TLE= approving T&L unit
+5 ;
+6 NEW A,B,C,D,E,F,X
+7 ; get duz of current user
+8 SET USR=""
SET TLE=""
DO DUZ^PRSRUTL
if SSN=""
QUIT
TL ; Select T&L from those allowed
+1 if SSN'=""
SET USR=$ORDER(^PRSPC("SSN",SSN,0))
+2 KILL DIC
+3 ;
+4 ;Z1 for T&L unit file x-ref lookup: T=TimeKeeper, S=Supervisor
+5 SET Z1=$SELECT(PRSTLV=2:"T",PRSTLV="3":"S",PRSTLV=7:"S",1:"*")
+6 IF PRSR=1
SET TLI=$ORDER(^PRST(455.5,"A"_Z1,DUZ,0))
IF TLI<1
WRITE !!,*7,"No T&L Units have been assigned to you!"
QUIT
+7 if PRSR=3
QUIT
SEL WRITE !
SET DIC="^PRST(455.5,"
+1 SET DIC(0)="AEMQ"
SET DIC("A")="Select T&L: "
+2 ;screen checks:
+3 ; if payroll then all T&L's available OR
+4 ; if T&A supervisor then only T&L's that are assigned
+5 SET DIC("S")="I PRSR=2!(PRSR=1&($D(^PRST(455.5,Y,Z1,DUZ,0))))"
+6 DO ^DIC
if $DATA(DTOUT)!$DATA(DUOUT)!(Y=-1)
QUIT
KILL DIC
SET X=$PIECE(Y,"^",2)
+7 DO VALSEL
IF TLE=""
WRITE ?($X+2),$CHAR(7),"??"
GOTO SEL
P1 ;S TLI=$P($G(^PRSPC(PRSRDUZ,0)),U,8)
+1 QUIT
P2 SET TLE=1
SET TLE(I)=$PIECE($GET(^PRST(455.5,TLI,0)),"^",1,2)
+1 SET TLI=$PIECE($GET(^PRSPC(PRSRDUZ,0)),U,8)
+2 QUIT
VALSEL ; Validate input in form 001 or 211,234,333 or 221,2233,345-367,400
+1 SET C=0
SET D=1
FOR A=1:1
if $PIECE(X,",",A)=""
QUIT
Begin DoDot:1
+2 IF $PIECE(X,",",A)'["-"
SET I=$PIECE(X,",",A)
SET TLE(D)=I
SET D=D+1
+3 IF '$TEST
SET B=$PIECE($PIECE(X,",",A),"-")
SET C=$PIECE($PIECE(X,",",A),"-",2)
FOR I=B:1:C
SET TLE(D)=I
SET D=D+1
+4 QUIT
End DoDot:1
CHKSEL ; Check selection array eliminating T&L units not assigned, if not Fiscal.
+1 SET TLE=D-1
SET I=0
FOR II=1:1
SET I=$ORDER(TLE(I))
if I'>0
QUIT
Begin DoDot:1
+2 IF $LENGTH(TLE(I))<1!'($ORDER(^PRST(455.5,"B",TLE(I),0)))
DO KILL
QUIT
+3 SET F=$ORDER(^PRST(455.5,"B",TLE(I),0))
IF PRSR=1
IF '$DATA(^PRST(455.5,F,Z1,DUZ,0))
DO KILL
+4 IF '$TEST
SET $PIECE(TLE(I),U,2)=$PIECE(^PRST(455.5,F,0),U,2)
DO GET
+5 QUIT
End DoDot:1
+6 if D=1
SET TLE=D
QUIT
KILL KILL TLE(D)
SET TLE=TLE-1
QUIT
ALL SET DA=0
FOR I=1:1
SET DA=$ORDER(^PRST(455.5,"A"_Z1,DUZ,DA))
if DA'>0
QUIT
Begin DoDot:1
+1 SET TLE(I)=$PIECE($GET(^PRST(455.5,DA,0)),U,1,2)
DO GET
+2 QUIT
End DoDot:1
+3 QUIT
GET SET DA(1)=""
FOR II=1:1
SET DA(1)=$ORDER(^PRSPC("ATL"_$PIECE(TLE(I),U),DA(1)))
if DA(1)=""
QUIT
Begin DoDot:1
+1 SET TLE(I,II)=$ORDER(^PRSPC("ATL"_$PIECE(TLE(I),U),DA(1),0))_"^"_DA(1)
+2 QUIT
End DoDot:1
+3 SET TLE=$SELECT(PRSRDUZ:$PIECE($GET(^PRSPC(PRSRDUZ,0)),U,8),1:"000")
SET SW=1
QUIT
MSG WRITE !!,$CHAR(7),"ENTER CODE(s), ONE OR MORE, SEPERATED BY COMMA(S) ( , ) or ( ALL ) .",!
GOTO SEL
