- 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 Mar 13, 2025@21:09:53 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")
