PRCH1B ;WISC/PLT-PURCHASE CARD APPROVE REONCILIATION ; 03/01/96 1:27 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
QUIT ;invalid entry
;
EN ;approve reconciled purchase card orders
N PRCA,PRCB,PRCQCD,PRCOPT,PRCRI,PRCDI,PRCDUZ,PRC,PRCQT,PRCSEL,PRCSST,PRCSTC
N A,B,C
Q1 ;station
S PRCSST=1 D STA^PRCSUT S PRCSTC=SI G:$G(PRC("SITE"))=""!(Y<0)!(PRCSTC<1) EXIT
S PRCRI(420)=+PRC("SITE")
Q2 S B="O^1:All Purchase Card Users;2:Single Purchase Card User"
K X,Y S Y(1)="^W ""Enter an option number 1 to 2."""
D SC^PRC0A(.X,.Y,"Select Number",B,"")
S A=Y K X,Y
G EXIT:A=""!(A["^")
S PRCOPT=+A
I PRCOPT=1 G AUTO
Q3 ;select purchase card user
W !! S PRCDI="200;^VA(200,;"
S X("S")="I Y-DUZ,$D(^PRC(440.5,""MAAH"",DUZ,+Y))"
D LOOKUP^PRC0B(.X,.Y,PRCDI,"AEOQS","Select Purchase Card Order User: ")
I Y<0!(X="") S PRCQT="^" G Q2
K X S PRCRI(200)=+Y
D USER(PRCRI(200),PRCOPT)
D EN^DDIOL("Approving reconciliation for "_$P($G(^VA(200,PRCRI(200),0)),U)_" ends.")
G Q3
AUTO ;start auto
S PRCRI(200)="" F S PRCRI(200)=$O(^PRC(440.5,"MAAH",DUZ,PRCRI(200))) QUIT:'PRCRI(200) D:DUZ-PRCRI(200) USER(PRCRI(200),PRCOPT) QUIT:$D(DUOUT)!($G(X)["^")
K DUOUT
D EN^DDIOL("Approving reconciliation for all purchase card users ends.")
EXIT QUIT
;
USER(PRCA,PRCB) ;approve by user
N PRCRI,PRCC,PRCD,PRCOPT,PRCUSR,PRCCNT
N A,B,C,D,X,Y
S PRCRI(200)=PRCA,PRCUSR=$P($G(^VA(200,PRCA,0)),U,1),PRCOPT=PRCB
RL W ! K ^TMP("PRCHAPP",$J,PRCRI(200))
S PRCRI(442)=0,PRCCNT=0
F S PRCRI(442)=$O(^PRC(442,"MAPP",PRCRI(200)_"~",PRCRI(442))) QUIT:'PRCRI(442) I ^PRC(442,PRCRI(442),0)-PRC("SITE")=0 S C=$P(^(23),"^",8) I C,$P(^PRC(440.5,C,0),"^",10)=DUZ!($P(^(0),"^",9)=DUZ) D DISP QUIT:X["^"!$D(DUOUT)
I PRCCNT=0 G USEREXT
S PRCSEL=""
ACT S X(1)=$TR($J("",79)," ","_")
S X(2)=" Action Code: SL: Select DO: Display Order NU: Next User",X(3)=" AP: Approve RL: Relist Reconciled Orders DC: Display Charges"
S Y(1)="Enter an action code"
D FT^PRC0A(.X,.Y,"Action","",$S($G(PRCSEL)="":"SL",1:"")) QUIT:X["^"
S Y=$$LU
I Y="NU" QUIT
I Y="RL" G RL
DO I Y="DO"!(Y="DC") D G DO:Y="DO"!(Y="DC"),RL
. N PRCOPT
. S PRCOPT=Y
. S E="O^1:5^",Y(1)="Enter one sequence # to display the purchase order"
. D FT^PRC0A(.X,.Y,"Select Sequence # to Display (1-"_PRCCNT_")",E,"") QUIT:X["^"!(X="")
. I Y'?1.N!(Y<1)!(Y>PRCCNT) D EN^DDIOL("Invalid sequence #, try again!") S Y=PRCOPT QUIT
. N D0 S D0=$P(^TMP("PRCHAPP",$J,PRCRI(200),+Y),"^") D ^PRCHDP1:PRCOPT="DO",DC^PRCH1A(D0):PRCOPT="DC"
. S Y=""
. QUIT
I Y="AP" G APP:PRCSEL]"" D EN^DDIOL("No purchase orders selected") G ACT
I Y'="SL" D EN^DDIOL("Invalid Action code, try again") G ACT
Q11 S PRCSEL="",E="O^1:230^",Y(1)="Enter format: 'ALL', 'E/1,3,6-9,10' for exception, or '1,3,6-9,10' to approve"
D FT^PRC0A(.X,.Y,"Select Sequence #'s to approve (1-"_PRCCNT_")",E,"")
G USEREXT:X=""!(X["^")
S X=$$LU()
S PRCSEL=X
I X="ALL" G ACT
I X?1"E/".E S X=$E(X,3,999)
S Y="",C=0 F A=1:1 QUIT:$P(X,",",A,999)="" S B=$P(X,",",A) D
. I B?1.N,0<B,B'>PRCCNT I ","_Y_","'[(","_B_",") S C=C+1,$P(Y,",",C)=B QUIT
. I B?1.N1"-"1.N,$P(B,"-",2)>$P(B,"-"),0<B,B'>PRCCNT,0<$P(B,"-",2),$P(B,"-",2)'>PRCCNT I ","_Y_","'[(","_B_",") S C=C+1,$P(Y,",",C)=B QUIT
. QUIT
I Y="" W !,"Invalid selection, try again!" G Q11
S:PRCSEL?1"E/".E Y="E/"_Y G:PRCSEL=Y ACT
I X'=Y W !,"Warning: Invalid entries entered in the selection." W:Y]"" !,"The valid selection is: ",!,?3,"'",Y,"'"
S PRCSEL=Y G ACT
;
APP ;enter ESIG to approve
D ESIG^PRCUESIG(DUZ,.A)
I A=0!(A=3) D EN^DDIOL("Invalid Code Entered") G APP
I A=-1!(A=-2) D EN^DDIOL("NOT APPROVED") G USEREXT
I PRCSEL="ALL" D G USEREXT
. F PRCA=1:1:PRCCNT D APREC^PRCH1B1($P(^TMP("PRCHAPP",$J,PRCRI(200),PRCA),"^")) QUIT:X["^"!$D(DUOUT)
. QUIT
I PRCSEL?1"E/".E D G USEREXT
. S A=$E(PRCSEL,3,999) F B=1:1 QUIT:$P(A,",",B,999)="" S C=$P(A,",",B) D
.. I C?1.N S $P(^TMP("PRCHAPP",$J,PRCRI(200),C),"^",2)="E"
.. I C?1.N1"-"1.N F D=+C:1:$P(C,"-",2) S $P(^TMP("PRCHAPP",$J,PRCRI(200),D),"^",2)="E"
.. QUIT
. F PRCA=1:1:PRCCNT D:$P(^TMP("PRCHAPP",$J,PRCRI(200),PRCA),"^",2)'="E" APREC^PRCH1B1($P(^TMP("PRCHAPP",$J,PRCRI(200),PRCA),"^")) QUIT:X["^"!$D(DUOUT)
. QUIT
S A=PRCSEL F B=1:1 QUIT:$P(A,",",B,999)="" S C=$P(A,",",B) D
. I C?1.N S $P(^TMP("PRCHAPP",$J,PRCRI(200),C),"^",2)="A"
. I C?1.N1"-"1.N F D=+C:1:$P(C,"-",2) S $P(^TMP("PRCHAPP",$J,PRCRI(200),D),"^",2)="A"
. QUIT
F PRCA=1:1:PRCCNT D:$P(^TMP("PRCHAPP",$J,PRCRI(200),PRCA),"^",2)="A" APREC^PRCH1B1($P(^TMP("PRCHAPP",$J,PRCRI(200),PRCA),"^")) QUIT:X["^"!$D(DUOUT)
USEREXT K ^TMP("PRCHAPP",$J,PRCRI(200))
QUIT
;
DISP ;display purchase card order
N A,B,C,D,E
S PRCCNT=PRCCNT+1,^TMP("PRCHAPP",$J,PRCRI(200),PRCCNT)=PRCRI(442)
I PRCCNT=1 D EN^DDIOL("Start approving purchase card orders for "_PRCUSR),EN^DDIOL("Compiling user's reconciled purchase orders..."),EN^DDIOL("Seq# IFCAP PO # Vendor $Amount Credit Card Vendor $Amount")
S C="442;^PRC(442,;"_PRCRI(442)
K A D PIECE^PRC0B(C,".01;5;92","E","A")
S A=$G(A(442,PRCRI(442),.01,"E"))
S C=$G(A(442,PRCRI(442),92,"E"))
S E=$E($G(A(442,PRCRI(442),5,"E")),1,20)
I E="SIMPLIED" S D=$O(^PRC(442,PRCRI(442),2,0)) I D S D=$O(^PRC(442,PRCRI(442),2,D,1,0)) I D S E=^(D,0)
S B=$$FP^PRCH0A(PRCRI(442))
W !,$J(PRCCNT,4)," ",$P(A,U),?18,$E(E,1,20),?36,$J(C,8,2),?48,$E($P(B,"^",4),1,20),?69,$J($P(B,"^",2),8,2),$S($P(B,"^",2)-C:"*",1:"")
K A
S X="" I PRCCNT#20=0 S E="O^1:5^",Y(1)="Enter 'RETURN' to continue for listing or '^' to quit for selection." D FT^PRC0A(.X,.Y,"Hit 'RETURN' to continue for listing or '^' to quit for selection",E,"")
QUIT
;
LU() ;EV - low to upper
QUIT $TR(Y,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCH1B 5856 printed Oct 16, 2024@18:05:51 Page 2
PRCH1B ;WISC/PLT-PURCHASE CARD APPROVE REONCILIATION ; 03/01/96 1:27 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;invalid entry
QUIT
+3 ;
EN ;approve reconciled purchase card orders
+1 NEW PRCA,PRCB,PRCQCD,PRCOPT,PRCRI,PRCDI,PRCDUZ,PRC,PRCQT,PRCSEL,PRCSST,PRCSTC
+2 NEW A,B,C
Q1 ;station
+1 SET PRCSST=1
DO STA^PRCSUT
SET PRCSTC=SI
if $GET(PRC("SITE"))=""!(Y<0)!(PRCSTC<1)
GOTO EXIT
+2 SET PRCRI(420)=+PRC("SITE")
Q2 SET B="O^1:All Purchase Card Users;2:Single Purchase Card User"
+1 KILL X,Y
SET Y(1)="^W ""Enter an option number 1 to 2."""
+2 DO SC^PRC0A(.X,.Y,"Select Number",B,"")
+3 SET A=Y
KILL X,Y
+4 if A=""!(A["^")
GOTO EXIT
+5 SET PRCOPT=+A
+6 IF PRCOPT=1
GOTO AUTO
Q3 ;select purchase card user
+1 WRITE !!
SET PRCDI="200;^VA(200,;"
+2 SET X("S")="I Y-DUZ,$D(^PRC(440.5,""MAAH"",DUZ,+Y))"
+3 DO LOOKUP^PRC0B(.X,.Y,PRCDI,"AEOQS","Select Purchase Card Order User: ")
+4 IF Y<0!(X="")
SET PRCQT="^"
GOTO Q2
+5 KILL X
SET PRCRI(200)=+Y
+6 DO USER(PRCRI(200),PRCOPT)
+7 DO EN^DDIOL("Approving reconciliation for "_$PIECE($GET(^VA(200,PRCRI(200),0)),U)_" ends.")
+8 GOTO Q3
AUTO ;start auto
+1 SET PRCRI(200)=""
FOR
SET PRCRI(200)=$ORDER(^PRC(440.5,"MAAH",DUZ,PRCRI(200)))
if 'PRCRI(200)
QUIT
if DUZ-PRCRI(200)
DO USER(PRCRI(200),PRCOPT)
if $DATA(DUOUT)!($GET(X)["^")
QUIT
+2 KILL DUOUT
+3 DO EN^DDIOL("Approving reconciliation for all purchase card users ends.")
EXIT QUIT
+1 ;
USER(PRCA,PRCB) ;approve by user
+1 NEW PRCRI,PRCC,PRCD,PRCOPT,PRCUSR,PRCCNT
+2 NEW A,B,C,D,X,Y
+3 SET PRCRI(200)=PRCA
SET PRCUSR=$PIECE($GET(^VA(200,PRCA,0)),U,1)
SET PRCOPT=PRCB
RL WRITE !
KILL ^TMP("PRCHAPP",$JOB,PRCRI(200))
+1 SET PRCRI(442)=0
SET PRCCNT=0
+2 FOR
SET PRCRI(442)=$ORDER(^PRC(442,"MAPP",PRCRI(200)_"~",PRCRI(442)))
if 'PRCRI(442)
QUIT
IF ^PRC(442,PRCRI(442),0)-PRC("SITE")=0
SET C=$PIECE(^(23),"^",8)
IF C
IF $PIECE(^PRC(440.5,C,0),"^",10)=DUZ!($PIECE(^(0),"^",9)=DUZ)
DO DISP
if X["^"!$DATA(DUOUT)
QUIT
+3 IF PRCCNT=0
GOTO USEREXT
+4 SET PRCSEL=""
ACT SET X(1)=$TRANSLATE($JUSTIFY("",79)," ","_")
+1 SET X(2)=" Action Code: SL: Select DO: Display Order NU: Next User"
SET X(3)=" AP: Approve RL: Relist Reconciled Orders DC: Display Charges"
+2 SET Y(1)="Enter an action code"
+3 DO FT^PRC0A(.X,.Y,"Action","",$SELECT($GET(PRCSEL)="":"SL",1:""))
if X["^"
QUIT
+4 SET Y=$$LU
+5 IF Y="NU"
QUIT
+6 IF Y="RL"
GOTO RL
DO IF Y="DO"!(Y="DC")
Begin DoDot:1
+1 NEW PRCOPT
+2 SET PRCOPT=Y
+3 SET E="O^1:5^"
SET Y(1)="Enter one sequence # to display the purchase order"
+4 DO FT^PRC0A(.X,.Y,"Select Sequence # to Display (1-"_PRCCNT_")",E,"")
if X["^"!(X="")
QUIT
+5 IF Y'?1.N!(Y<1)!(Y>PRCCNT)
DO EN^DDIOL("Invalid sequence #, try again!")
SET Y=PRCOPT
QUIT
+6 NEW D0
SET D0=$PIECE(^TMP("PRCHAPP",$JOB,PRCRI(200),+Y),"^")
if PRCOPT="DO"
DO ^PRCHDP1
if PRCOPT="DC"
DO DC^PRCH1A(D0)
+7 SET Y=""
+8 QUIT
End DoDot:1
if Y="DO"!(Y="DC")
GOTO DO
GOTO RL
+9 IF Y="AP"
if PRCSEL]""
GOTO APP
DO EN^DDIOL("No purchase orders selected")
GOTO ACT
+10 IF Y'="SL"
DO EN^DDIOL("Invalid Action code, try again")
GOTO ACT
Q11 SET PRCSEL=""
SET E="O^1:230^"
SET Y(1)="Enter format: 'ALL', 'E/1,3,6-9,10' for exception, or '1,3,6-9,10' to approve"
+1 DO FT^PRC0A(.X,.Y,"Select Sequence #'s to approve (1-"_PRCCNT_")",E,"")
+2 if X=""!(X["^")
GOTO USEREXT
+3 SET X=$$LU()
+4 SET PRCSEL=X
+5 IF X="ALL"
GOTO ACT
+6 IF X?1"E/".E
SET X=$EXTRACT(X,3,999)
+7 SET Y=""
SET C=0
FOR A=1:1
if $PIECE(X,",",A,999)=""
QUIT
SET B=$PIECE(X,",",A)
Begin DoDot:1
+8 IF B?1.N
IF 0<B
IF B'>PRCCNT
IF ","_Y_","'[(","_B_",")
SET C=C+1
SET $PIECE(Y,",",C)=B
QUIT
+9 IF B?1.N1"-"1.N
IF $PIECE(B,"-",2)>$PIECE(B,"-")
IF 0<B
IF B'>PRCCNT
IF 0<$PIECE(B,"-",2)
IF $PIECE(B,"-",2)'>PRCCNT
IF ","_Y_","'[(","_B_",")
SET C=C+1
SET $PIECE(Y,",",C)=B
QUIT
+10 QUIT
End DoDot:1
+11 IF Y=""
WRITE !,"Invalid selection, try again!"
GOTO Q11
+12 if PRCSEL?1"E/".E
SET Y="E/"_Y
if PRCSEL=Y
GOTO ACT
+13 IF X'=Y
WRITE !,"Warning: Invalid entries entered in the selection."
if Y]""
WRITE !,"The valid selection is: ",!,?3,"'",Y,"'"
+14 SET PRCSEL=Y
GOTO ACT
+15 ;
APP ;enter ESIG to approve
+1 DO ESIG^PRCUESIG(DUZ,.A)
+2 IF A=0!(A=3)
DO EN^DDIOL("Invalid Code Entered")
GOTO APP
+3 IF A=-1!(A=-2)
DO EN^DDIOL("NOT APPROVED")
GOTO USEREXT
+4 IF PRCSEL="ALL"
Begin DoDot:1
+5 FOR PRCA=1:1:PRCCNT
DO APREC^PRCH1B1($PIECE(^TMP("PRCHAPP",$JOB,PRCRI(200),PRCA),"^"))
if X["^"!$DATA(DUOUT)
QUIT
+6 QUIT
End DoDot:1
GOTO USEREXT
+7 IF PRCSEL?1"E/".E
Begin DoDot:1
+8 SET A=$EXTRACT(PRCSEL,3,999)
FOR B=1:1
if $PIECE(A,",",B,999)=""
QUIT
SET C=$PIECE(A,",",B)
Begin DoDot:2
+9 IF C?1.N
SET $PIECE(^TMP("PRCHAPP",$JOB,PRCRI(200),C),"^",2)="E"
+10 IF C?1.N1"-"1.N
FOR D=+C:1:$PIECE(C,"-",2)
SET $PIECE(^TMP("PRCHAPP",$JOB,PRCRI(200),D),"^",2)="E"
+11 QUIT
End DoDot:2
+12 FOR PRCA=1:1:PRCCNT
if $PIECE(^TMP("PRCHAPP",$JOB,PRCRI(200),PRCA),"^",2)'="E"
DO APREC^PRCH1B1($PIECE(^TMP("PRCHAPP",$JOB,PRCRI(200),PRCA),"^"))
if X["^"!$DATA(DUOUT)
QUIT
+13 QUIT
End DoDot:1
GOTO USEREXT
+14 SET A=PRCSEL
FOR B=1:1
if $PIECE(A,",",B,999)=""
QUIT
SET C=$PIECE(A,",",B)
Begin DoDot:1
+15 IF C?1.N
SET $PIECE(^TMP("PRCHAPP",$JOB,PRCRI(200),C),"^",2)="A"
+16 IF C?1.N1"-"1.N
FOR D=+C:1:$PIECE(C,"-",2)
SET $PIECE(^TMP("PRCHAPP",$JOB,PRCRI(200),D),"^",2)="A"
+17 QUIT
End DoDot:1
+18 FOR PRCA=1:1:PRCCNT
if $PIECE(^TMP("PRCHAPP",$JOB,PRCRI(200),PRCA),"^",2)="A"
DO APREC^PRCH1B1($PIECE(^TMP("PRCHAPP",$JOB,PRCRI(200),PRCA),"^"))
if X["^"!$DATA(DUOUT)
QUIT
USEREXT KILL ^TMP("PRCHAPP",$JOB,PRCRI(200))
+1 QUIT
+2 ;
DISP ;display purchase card order
+1 NEW A,B,C,D,E
+2 SET PRCCNT=PRCCNT+1
SET ^TMP("PRCHAPP",$JOB,PRCRI(200),PRCCNT)=PRCRI(442)
+3 IF PRCCNT=1
DO EN^DDIOL("Start approving purchase card orders for "_PRCUSR)
DO EN^DDIOL("Compiling user's reconciled purchase orders...")
DO EN^DDIOL("Seq# IFCAP PO # Vendor $Amount Credit Card Vendor $Amount")
+4 SET C="442;^PRC(442,;"_PRCRI(442)
+5 KILL A
DO PIECE^PRC0B(C,".01;5;92","E","A")
+6 SET A=$GET(A(442,PRCRI(442),.01,"E"))
+7 SET C=$GET(A(442,PRCRI(442),92,"E"))
+8 SET E=$EXTRACT($GET(A(442,PRCRI(442),5,"E")),1,20)
+9 IF E="SIMPLIED"
SET D=$ORDER(^PRC(442,PRCRI(442),2,0))
IF D
SET D=$ORDER(^PRC(442,PRCRI(442),2,D,1,0))
IF D
SET E=^(D,0)
+10 SET B=$$FP^PRCH0A(PRCRI(442))
+11 WRITE !,$JUSTIFY(PRCCNT,4)," ",$PIECE(A,U),?18,$EXTRACT(E,1,20),?36,$JUSTIFY(C,8,2),?48,$EXTRACT($PIECE(B,"^",4),1,20),?69,$JUSTIFY($PIECE(B,"^",2),8,2),$SELECT($PIECE(B,"^",2)-C:"*",1:"")
+12 KILL A
+13 SET X=""
IF PRCCNT#20=0
SET E="O^1:5^"
SET Y(1)="Enter 'RETURN' to continue for listing or '^' to quit for selection."
DO FT^PRC0A(.X,.Y,"Hit 'RETURN' to continue for listing or '^' to quit for selection",E,"")
+14 QUIT
+15 ;
LU() ;EV - low to upper
+1 QUIT $TRANSLATE(Y,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
