PRCH1D ;WISC/PLT-REMOVE PURCHASE CARD RECONCILIATION ;7/19/96 09:02
V ;;5.1;IFCAP;**117**;Oct 20, 2000;Build 2
;Per VHA Directive 10-93-142, this routine should not be modified.
QUIT ;invalid entry
;
EN ;remove reconcile purchase card order
N PRCA,PRCB,PRCQCD,PRCOPT,PRCRI,PRCDI,PRCDUZ,PRC,PRCC,PRCE,PRCF,PRCG,PRCVAL,PRCCP,PRCR,PRCSST,PRCSTC,PRCEDRM
N PRCSELF,PRCCN,PRCCNT,PCN
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")
S PRCSELF=1 I $D(^PRC(440.5,"MAA",DUZ)) D G EXIT:X=""!(X["^") S PRCSELF=Y
. D YN^PRC0A(.X,.Y,"Edit/Remove Reconciliation for your own purchase card orders","O","")
. QUIT
S PRCCN="" I PRCSELF=1 S PRCDUZ=DUZ G Q3
Q21 S X("S")="I $P(^(2),U,3)=PRC(""SITE""),$P(^(0),U,9)=DUZ!($P(^(0),U,10)=DUZ)"
S X("W")="W "" "",$P(^(0),U,11),"" "" W:$P(^(0),U,8) $P($G(^VA(200,$P(^(0),U,8),0)),U)"
D LOOKUP^PRC0B(.X,.Y,"440.5;^PRC(440.5,;","AEMOQS~~G^MAA^H^D","Select Purchase Credit Card/Holder: ")
I X["^"!(X="")!(Y<1) G Q1
S PRCRI(440.5)=+Y,PRCDUZ=$P(^PRC(440.5,PRCRI(440.5),0),U,8),PRCCN=$P(^(0),U)
Q3 ;select oracle cc-record
K DIRUT,PCSTAT
S X("S")="I ""RD""[$P(^(0),U,16),$P(^(0),U,8)=PRC(""SITE""),$P(^(0),U,4)=PRCCN&'PRCSELF!($P(^(0),U,17)="_PRCDUZ_"&PRCSELF)"
S X("W")="W:$X>20 ! W $P(^(0),U,1),"" "",$E($P(^(0),U,9),4,5)_""-""_$E($P(^(0),U,9),6,7)_""-""_$E($P(^(0),U,9),2,3),"" $"",$J($P(^(0),U,14),0,2) W:$D(^(6)) "" "",$P(^(6),U,1)"
W ! D LOOKUP^PRC0B(.X,.Y,"440.6;^PRCH(440.6,;","AEMOQS~~","Select Reconciled/Disputed C-Document/Purchase Card Order: ")
I Y<0!(X="") G EXIT
K X S PRCRI(440.6)=+Y,PRCRI(442)=$P($G(^PRCH(440.6,PRCRI(440.6),1)),"^",1),PCSTAT=$P($G(^PRCH(440.6,PRCRI(440.6),0)),"^",16)
I 'PRCRI(442) D EN^DDIOL("Not reconciled yet.") G Q3
;
;if the charge has been reconciled warn user before starting any changes
I $D(PRCRI(442)),$G(PCSTAT)="R"!($G(PCSTAT)="D") D G:X="NO"!(X["^")!(X="") Q3
. W $C(7),!!,?25,"**** WARNING ****"
. S DIR("A",1)=""
. S DIR("A",2)="This charge is reconciled. If you 'Edit' it, another approval will be needed."
. S DIR("A",3)="If you 'Remove' the reconciliation, you must reconcile the charge and your "
. S DIR("A",4)="Approving Official will have to approve it again."
. S DIR("A",5)=""
. S DIR("A",6)="Use the action code DD (Display Document) if no change is desired."
. S DIR("A",7)=""
. S DIR("A")="Do you want to continue"
. S DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR Q:$D(DIRUT)
D ACT
G Q3
;
;
EXIT QUIT
ACT S PRCE=^PRC(442,PRCRI(442),0),PRCCP=$P($G(^(23)),"^",16),PRCR=$P($G(^(23)),"^",15) S:PRCR="" PRCR="N"
S X(1)=$TR($J("",79)," ","_")
S X(2)=" Action Code: ED: Edit DO: Display Order ND: Next Document",X(3)=" RM: Remove DD: Display Document"
S Y(1)="Enter an action code"
D FT^PRC0A(.X,.Y,"Action","","")
I X["^"!(X="") QUIT
S Y=$$LU
I Y="ND" QUIT
I Y="DO" D G ACT
. N D0 S D0=PRCRI(442) D ^PRCHDP1
. QUIT
I Y="DD" D DD G ACT
S PRCEDRM="" I Y="ED" S PRCEDRM=1 D RC^PRCH1A1 QUIT
I Y'="RM" D EN^DDIOL("Invalid Action code, try again") G ACT
;remove conciliation
S PRCA=^PRCH(440.6,PRCRI(440.6),0),PRCB=$G(^(1))
D E20,ET
S PRCA=^PRCH(440.6,PRCRI(440.6),0),PRCB=$G(^(1))
S PRCRI(410)=$P(^PRC(442,PRCRI(442),0),"^",12)
D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"44///N;15////N;45///@")
D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"18///@;19///@;46///@;41///@;42///@")
;if final payment entry removed
I $P(PRCB,"^",4)="Y" D
. S PRCST=$P(PRCA,"^",20) D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"58///@;44///@;.5///"_PRCST)
. I PRCRI(410) D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"27////"_$P(PRCA,"^",19))
. S PRCRI=0 F S PRCRI=$O(^PRC(442,PRCRI(442),13,PRCRI)) QUIT:'PRCRI D:PRCRI ERS410^PRC0G(PRCRI_"^A")
. QUIT
S PRCC=$$FP^PRCH0A(PRCRI(442))
;if last payment entry removed
I $P(PRCC,"^",2)="" S PRCST=$P(PRCA,"^",20) D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"58///@;44///@;.5///"_PRCST) G Q9
;if not last payment entry removed
D:PRCRI(410)&PRCC
. N A,B
. S A=0,B=0 F S A=$O(^PRCH(440.6,"PO",PRCRI(442),A)) QUIT:'A S B=B+$P(^PRCH(440.6,A,0),"^",14)
. D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"27////"_B)
. QUIT
Q9 ;prompt status
K X
S X=+^PRC(442,PRCRI(442),7) S:X=40!(X=71) X=95 S X("B")=$P(^PRCD(442.3,X,0),"^")
S PRCVAL=",22,27,25,30,24,32,37,39,46,48,50,"
S:$O(^PRC(442,PRCRI(442),6,0)) PRCVAL=",22,27,25,26,30,31,23,24,29,32,34,37,38,39,44,46,47,48,49,50,51,"
S X("S")="N A S A=$P(^PRCD(442.3,+Y,0),U,2) I PRCVAL[("",""_A_"","")"
D LOOKUP^PRC0B(.X,.Y,"442.3;^PRCD(442.3,","AEMQ","AFTER Removing Change P.O. Status to: ")
I Y<0!(X="") D EN^DDIOL("The purchase card order status is required") G Q9
S PRCST=$P(^PRCD(442.3,+Y,0),"^",2)
D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),".5///"_PRCST)
K PCN QUIT
;
E20 D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"20")
QUIT
;
ET S A=$$DDA4406^PRCH0A(PRCRI(440.6)),B=$$DDA442^PRCH0A(PRCRI(442)),$P(B,"^",17)="",PRCBOC=$P(B,"^",21),$P(B,"^",33)=$P(A,"^",33)
I A'=B D
. I $E(PRCA,13,15)>490 D EN^DDIOL("Enter ET-Document by FMS-ON LINE!") QUIT
. D EN^DDIOL("Generating ET-document to FMS...")
. D ET^PRCH8A(.X,PRCRI(440.6)_"^"_PRCRI(442)_"^2^"_PRCBOC,"")
. I X D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"17////"_$P(X,"^"))
. QUIT
QUIT
;
;
DD ;dispaly document
N A
D PIECE^PRC0B("440.6;^PRC(440.6,;"_PRCRI(440.6),".01;8;13;31;44","E","A")
W !,"Reconcile Doc: ",$G(A(440.6,PRCRI(440.6),.01,"E")),?32,"Purchase Date: ",$G(A(440.6,PRCRI(440.6),8,"E")),?60,"$Amount: ",$J($G(A(440.6,PRCRI(440.6),13,"E")),0,2)
W !,"Final Payment: ",$G(A(440.6,PRCRI(440.6),44,"E"))
W !,"Vendor Name: ",$G(A(440.6,PRCRI(440.6),31,"E"))
QUIT
;
LU() ;lower to upper
QUIT $TR(Y,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCH1D 5911 printed Apr 09, 2024@21:07:39 Page 2
PRCH1D ;WISC/PLT-REMOVE PURCHASE CARD RECONCILIATION ;7/19/96 09:02
V ;;5.1;IFCAP;**117**;Oct 20, 2000;Build 2
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;invalid entry
QUIT
+3 ;
EN ;remove reconcile purchase card order
+1 NEW PRCA,PRCB,PRCQCD,PRCOPT,PRCRI,PRCDI,PRCDUZ,PRC,PRCC,PRCE,PRCF,PRCG,PRCVAL,PRCCP,PRCR,PRCSST,PRCSTC,PRCEDRM
+2 NEW PRCSELF,PRCCN,PRCCNT,PCN
+3 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")
+3 SET PRCSELF=1
IF $DATA(^PRC(440.5,"MAA",DUZ))
Begin DoDot:1
+4 DO YN^PRC0A(.X,.Y,"Edit/Remove Reconciliation for your own purchase card orders","O","")
+5 QUIT
End DoDot:1
if X=""!(X["^")
GOTO EXIT
SET PRCSELF=Y
+6 SET PRCCN=""
IF PRCSELF=1
SET PRCDUZ=DUZ
GOTO Q3
Q21 SET X("S")="I $P(^(2),U,3)=PRC(""SITE""),$P(^(0),U,9)=DUZ!($P(^(0),U,10)=DUZ)"
+1 SET X("W")="W "" "",$P(^(0),U,11),"" "" W:$P(^(0),U,8) $P($G(^VA(200,$P(^(0),U,8),0)),U)"
+2 DO LOOKUP^PRC0B(.X,.Y,"440.5;^PRC(440.5,;","AEMOQS~~G^MAA^H^D","Select Purchase Credit Card/Holder: ")
+3 IF X["^"!(X="")!(Y<1)
GOTO Q1
+4 SET PRCRI(440.5)=+Y
SET PRCDUZ=$PIECE(^PRC(440.5,PRCRI(440.5),0),U,8)
SET PRCCN=$PIECE(^(0),U)
Q3 ;select oracle cc-record
+1 KILL DIRUT,PCSTAT
+2 SET X("S")="I ""RD""[$P(^(0),U,16),$P(^(0),U,8)=PRC(""SITE""),$P(^(0),U,4)=PRCCN&'PRCSELF!($P(^(0),U,17)="_PRCDUZ_"&PRCSELF)"
+3 SET X("W")="W:$X>20 ! W $P(^(0),U,1),"" "",$E($P(^(0),U,9),4,5)_""-""_$E($P(^(0),U,9),6,7)_""-""_$E($P(^(0),U,9),2,3),"" $"",$J($P(^(0),U,14),0,2) W:$D(^(6)) "" "",$P(^(6),U,1)"
+4 WRITE !
DO LOOKUP^PRC0B(.X,.Y,"440.6;^PRCH(440.6,;","AEMOQS~~","Select Reconciled/Disputed C-Document/Purchase Card Order: ")
+5 IF Y<0!(X="")
GOTO EXIT
+6 KILL X
SET PRCRI(440.6)=+Y
SET PRCRI(442)=$PIECE($GET(^PRCH(440.6,PRCRI(440.6),1)),"^",1)
SET PCSTAT=$PIECE($GET(^PRCH(440.6,PRCRI(440.6),0)),"^",16)
+7 IF 'PRCRI(442)
DO EN^DDIOL("Not reconciled yet.")
GOTO Q3
+8 ;
+9 ;if the charge has been reconciled warn user before starting any changes
+10 IF $DATA(PRCRI(442))
IF $GET(PCSTAT)="R"!($GET(PCSTAT)="D")
Begin DoDot:1
+11 WRITE $CHAR(7),!!,?25,"**** WARNING ****"
+12 SET DIR("A",1)=""
+13 SET DIR("A",2)="This charge is reconciled. If you 'Edit' it, another approval will be needed."
+14 SET DIR("A",3)="If you 'Remove' the reconciliation, you must reconcile the charge and your "
+15 SET DIR("A",4)="Approving Official will have to approve it again."
+16 SET DIR("A",5)=""
+17 SET DIR("A",6)="Use the action code DD (Display Document) if no change is desired."
+18 SET DIR("A",7)=""
+19 SET DIR("A")="Do you want to continue"
+20 SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
End DoDot:1
if X="NO"!(X["^")!(X="")
GOTO Q3
+21 DO ACT
+22 GOTO Q3
+23 ;
+24 ;
EXIT QUIT
ACT SET PRCE=^PRC(442,PRCRI(442),0)
SET PRCCP=$PIECE($GET(^(23)),"^",16)
SET PRCR=$PIECE($GET(^(23)),"^",15)
if PRCR=""
SET PRCR="N"
+1 SET X(1)=$TRANSLATE($JUSTIFY("",79)," ","_")
+2 SET X(2)=" Action Code: ED: Edit DO: Display Order ND: Next Document"
SET X(3)=" RM: Remove DD: Display Document"
+3 SET Y(1)="Enter an action code"
+4 DO FT^PRC0A(.X,.Y,"Action","","")
+5 IF X["^"!(X="")
QUIT
+6 SET Y=$$LU
+7 IF Y="ND"
QUIT
+8 IF Y="DO"
Begin DoDot:1
+9 NEW D0
SET D0=PRCRI(442)
DO ^PRCHDP1
+10 QUIT
End DoDot:1
GOTO ACT
+11 IF Y="DD"
DO DD
GOTO ACT
+12 SET PRCEDRM=""
IF Y="ED"
SET PRCEDRM=1
DO RC^PRCH1A1
QUIT
+13 IF Y'="RM"
DO EN^DDIOL("Invalid Action code, try again")
GOTO ACT
+14 ;remove conciliation
+15 SET PRCA=^PRCH(440.6,PRCRI(440.6),0)
SET PRCB=$GET(^(1))
+16 DO E20
DO ET
+17 SET PRCA=^PRCH(440.6,PRCRI(440.6),0)
SET PRCB=$GET(^(1))
+18 SET PRCRI(410)=$PIECE(^PRC(442,PRCRI(442),0),"^",12)
+19 DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"44///N;15////N;45///@")
+20 DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"18///@;19///@;46///@;41///@;42///@")
+21 ;if final payment entry removed
+22 IF $PIECE(PRCB,"^",4)="Y"
Begin DoDot:1
+23 SET PRCST=$PIECE(PRCA,"^",20)
DO EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"58///@;44///@;.5///"_PRCST)
+24 IF PRCRI(410)
DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"27////"_$PIECE(PRCA,"^",19))
+25 SET PRCRI=0
FOR
SET PRCRI=$ORDER(^PRC(442,PRCRI(442),13,PRCRI))
if 'PRCRI
QUIT
if PRCRI
DO ERS410^PRC0G(PRCRI_"^A")
+26 QUIT
End DoDot:1
+27 SET PRCC=$$FP^PRCH0A(PRCRI(442))
+28 ;if last payment entry removed
+29 IF $PIECE(PRCC,"^",2)=""
SET PRCST=$PIECE(PRCA,"^",20)
DO EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"58///@;44///@;.5///"_PRCST)
GOTO Q9
+30 ;if not last payment entry removed
+31 if PRCRI(410)&PRCC
Begin DoDot:1
+32 NEW A,B
+33 SET A=0
SET B=0
FOR
SET A=$ORDER(^PRCH(440.6,"PO",PRCRI(442),A))
if 'A
QUIT
SET B=B+$PIECE(^PRCH(440.6,A,0),"^",14)
+34 DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"27////"_B)
+35 QUIT
End DoDot:1
Q9 ;prompt status
+1 KILL X
+2 SET X=+^PRC(442,PRCRI(442),7)
if X=40!(X=71)
SET X=95
SET X("B")=$PIECE(^PRCD(442.3,X,0),"^")
+3 SET PRCVAL=",22,27,25,30,24,32,37,39,46,48,50,"
+4 if $ORDER(^PRC(442,PRCRI(442),6,0))
SET PRCVAL=",22,27,25,26,30,31,23,24,29,32,34,37,38,39,44,46,47,48,49,50,51,"
+5 SET X("S")="N A S A=$P(^PRCD(442.3,+Y,0),U,2) I PRCVAL[("",""_A_"","")"
+6 DO LOOKUP^PRC0B(.X,.Y,"442.3;^PRCD(442.3,","AEMQ","AFTER Removing Change P.O. Status to: ")
+7 IF Y<0!(X="")
DO EN^DDIOL("The purchase card order status is required")
GOTO Q9
+8 SET PRCST=$PIECE(^PRCD(442.3,+Y,0),"^",2)
+9 DO EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),".5///"_PRCST)
+10 KILL PCN
QUIT
+11 ;
E20 DO EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"20")
+1 QUIT
+2 ;
ET SET A=$$DDA4406^PRCH0A(PRCRI(440.6))
SET B=$$DDA442^PRCH0A(PRCRI(442))
SET $PIECE(B,"^",17)=""
SET PRCBOC=$PIECE(B,"^",21)
SET $PIECE(B,"^",33)=$PIECE(A,"^",33)
+1 IF A'=B
Begin DoDot:1
+2 IF $EXTRACT(PRCA,13,15)>490
DO EN^DDIOL("Enter ET-Document by FMS-ON LINE!")
QUIT
+3 DO EN^DDIOL("Generating ET-document to FMS...")
+4 DO ET^PRCH8A(.X,PRCRI(440.6)_"^"_PRCRI(442)_"^2^"_PRCBOC,"")
+5 IF X
DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"17////"_$PIECE(X,"^"))
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
+9 ;
DD ;dispaly document
+1 NEW A
+2 DO PIECE^PRC0B("440.6;^PRC(440.6,;"_PRCRI(440.6),".01;8;13;31;44","E","A")
+3 WRITE !,"Reconcile Doc: ",$GET(A(440.6,PRCRI(440.6),.01,"E")),?32,"Purchase Date: ",$GET(A(440.6,PRCRI(440.6),8,"E")),?60,"$Amount: ",$JUSTIFY($GET(A(440.6,PRCRI(440.6),13,"E")),0,2)
+4 WRITE !,"Final Payment: ",$GET(A(440.6,PRCRI(440.6),44,"E"))
+5 WRITE !,"Vendor Name: ",$GET(A(440.6,PRCRI(440.6),31,"E"))
+6 QUIT
+7 ;
LU() ;lower to upper
+1 QUIT $TRANSLATE(Y,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
