- 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 Mar 13, 2025@21:33:42 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
