PRCFDIC ;WISC/LEM-LOOK UP INVOICES BY P.O. OR VENDOR ;8/18/94 14:20
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
PO ; LOOK UP INVOICES BY P.O.
K DA,DR,X,Y
;S PRCF("PO")=$G(X) Q:X=""
PO1 S X=$G(PRCF("PO")) Q:X=""
N MULT,VIEW S MULT=0,I="" I $D(^PRCF(421.5,"D",X)) D
. F S I=$O(^PRCF(421.5,"D",X,I)) Q:I="" S MULT=MULT+1 Q:MULT>1
. Q
N DIC,D S DIC="^PRCF(421.5,",DIC(0)="EZ",D="D"
S X=$P(X,"-",1,2)
D IX^DIC Q:Y<0 S VIEW=+Y
I VIEW=$G(PRCF("CIDA")) S X=" ("_+Y_" - THIS Invoice.)*" D MSG^PRCFQ
I VIEW D VIEW G PO1:MULT>1
Q
VENDOR ; LOOK UP INVOICES BY VENDOR
S X=$G(PRCF("VENDA")) Q:X=""
N MULT,VIEW S MULT=0,I="" I $D(^PRCF(421.5,"C",X)) D
. F S I=$O(^PRCF(421.5,"C",X,I)) Q:I="" S MULT=MULT+1 Q:MULT>1
. Q
N DIC S DIC="^PRCF(421.5,",DIC(0)="EZ",D="C"
D IX^DIC Q:Y<0 S VIEW=+Y
I VIEW=$G(PRCF("CIDA")) S X=" ("_+Y_" - THIS Invoice.)*" D MSG^PRCFQ
I VIEW D VIEW G VENDOR:MULT>1
Q
VIEW ;VIEW INDIVIDUAL CERTIFIED INVOICE
S (FR,TO)=$P(Y,"^",2),L=0,BY="@.01;",FLDS="[CAPTIONED]",IOP="HOME"
D WAIT^PRCFYN,EN1^DIP
OUTV K DIC,DA,DR,X,Y
Q
DUP ; Look for Duplicate Invoice(s)
K PRCF("DUP") S PRCF("DUP")=0 Q:'$G(PRCF("CIDA"))
Q:'$G(PRCF("VENDA")) Q:'$D(^PRCF(421.5,"C",PRCF("VENDA")))
S PRCF("INVNO")=$P($G(^PRCF(421.5,PRCF("CIDA"),0)),U,3)
Q:PRCF("INVNO")=""
N X S X="Checking for duplicate invoices . . .*" D MSG^PRCFQ
N I S I="" F S I=$O(^PRCF(421.5,"C",PRCF("VENDA"),I)) Q:I="" D
. Q:I=PRCF("CIDA")
. I PRCF("INVNO")=$P($G(^PRCF(421.5,I,0)),U,3) D
. . S PRCF("DUP")=PRCF("DUP")+1
. . N CIDNO S CIDNO=$P($G(^PRCF(421.5,I,0)),U,1)
. . S PRCF("DUP",CIDNO)=""
. . Q
. Q
I PRCF("DUP")=0 N X S X="none found.*" D MSG^PRCFQ Q
S X="WARNING! Identical invoices numbers for this vendor were found in the following Tracking ID#s:*"
D MSG^PRCFQ S I="" F S I=$O(PRCF("DUP",I)) Q:I="" W !?10,I
W !! S X="Please review these records and check for duplicate invoices.*"
D MSG^PRCFQ
Q
PPT ; Load Prompt Payment Terms from File 442
Q:'$G(PRCF("CIDA")) Q:'$G(PRCF("PODA"))
Q:$D(^PRCF(421.5,PRCF("CIDA"),6)) Q:'$D(^PRC(442,PRCF("PODA"),5,1,0))
N PPT S PPT=$G(^PRC(442,PRCF("PODA"),5,1,0))
N PCT,DAYS S PCT=$P(PPT,U,1),DAYS=$P(PPT,U,2)
S ^PRCF(421.5,PRCF("CIDA"),6,0)="^421.531A^1^1"
S ^PRCF(421.5,PRCF("CIDA"),6,1,0)="1^^"_PCT_"^^"_DAYS
S ^PRCF(421.5,PRCF("CIDA"),6,"B",1,1)=""
Q
INPUT N X0 S X0=$TR(X,"net","NET")
I X]"",$E("NET",1,$L(X0))=X0 S X=0 Q
; Native FileMan Input Transform follows:
K:+X'=X!(X>99.999)!(X<0)!(X?.E1"."4N.N) X
Q
OUTPUT I Y?1"0"."."."0" S Y="NET"
Q
N DA S DA(1)=$G(PRCF("CIDA")) Q:DA(1)=""
N NODE S NODE=$G(^PRCF(421.5,DA(1),5,0))
I NODE="" S ^PRCF(421.5,DA(1),5,0)=U_$P(^DD(421.5,41,0),U,2)
N CTR,I S (CTR,I)=0 F S I=$O(PRCFD(I)) Q:I'>0 D
. S CTR=$S(I=991:CTR,1:CTR+1),CTR=$S(CTR=991:992,1:CTR)
. N DIC S DIC="^PRCF(421.5,"_DA(1)_",5,",DIC(0)="L"
. S X=$P(PRCFD(I),U,1),AMT=+$P(PRCFD(I),U,2)
. K DD,DO D FILE^DICN I Y'>0 W "ERROR" Q
. N DIE S DIE=DIC,DA=+Y,FMSL=$S(I=991:991,1:CTR)
. N DR S DR="1////^S X=AMT;2////^S X=FMSL" D ^DIE
. Q
Q
DISC ; COMPUTE FMS LINE LIQ AMT FROM TOTAL AMT & DISCOUNT TERMS
; INPUT: PRCF("CIDA") - IEN FOR PAYMENT/INVOICE TRACKING RECORD
; PRCFA("LAMT") - FMS LINE AMOUNT FOR THIS INVOICE
; OUTPUT: PRCFA("LIQ") - FMS COMPUTED LIQUIDATION AMOUNT
Q:'$D(PRCF("CIDA"))!'$D(PRCFA("LAMT"))
N I,DISC,HIGHDISC S (HIGHDISC,I)=0
F S I=$O(^PRCF(421.5,PRCF("CIDA"),6,I)) Q:+I'=I D
. S DISC=+$P($G(^PRCF(421.5,PRCF("CIDA"),6,I,0)),U,3)
. I DISC>HIGHDISC S HIGHDISC=DISC
. Q
S PRCFA("LIQ")=$FN(1-(HIGHDISC/100)*PRCFA("LAMT"),"",2)
Q
SUM ;
; INPUT: PRCF("CIDA") - IEN FOR PAYMENT/INVOICE TRACKING RECORD
; PRCFA("CAMT") - TOTAL INVOICE AMOUNT CERTIFIED FOR PAYMENT
; OUTPUT: OK - 1 IF SUM OF LINE AMOUNTS = TOTAL AMOUNT CERTIFIED
; - 0 IF AMOUNTS NOT EQUAL
Q:'$D(PRCF("CIDA"))!'$D(PRCF("CAMT"))
N I,LAMT S (I,OK,PRCF("TAMT"))=0
F S I=$O(^PRCF(421.5,PRCF("CIDA"),5,I)) Q:+I'=I D
. S LAMT=+$P($G(^PRCF(421.5,PRCF("CIDA"),5,I,0)),U,2)
. S PRCF("TAMT")=PRCF("TAMT")+LAMT
. Q
I PRCF("CAMT")/100=PRCF("TAMT") S OK=1
Q
SCREEN ; CHECK BOC
I $G(X) I $D(PRCFX("SA",X))
Q
LOOKUP(X,PARTIAL) ; X = STA-PAT # - LOOKUP returns next available PARTIAL #.
N DIC S DIC="^PRCF(421.9,",DIC(0)="O" K DD,DO D ^DIC
I Y<0 D FILE^DICN
I +Y,$P(Y,U,3)=1 S PARTIAL="01",$P(^PRCF(421.9,+Y,0),U,2)="01" Q
S P=$P($G(^PRCF(421.9,+Y,0)),U,2),P=P+1
S P="00"_P,P=$E(P,$L(P)-1,$L(P))
S PARTIAL=P,$P(^PRCF(421.9,+Y,0),U,2)=P
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFDIC 4614 printed Dec 13, 2024@02:03:02 Page 2
PRCFDIC ;WISC/LEM-LOOK UP INVOICES BY P.O. OR VENDOR ;8/18/94 14:20
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
PO ; LOOK UP INVOICES BY P.O.
+1 KILL DA,DR,X,Y
+2 ;S PRCF("PO")=$G(X) Q:X=""
PO1 SET X=$GET(PRCF("PO"))
if X=""
QUIT
+1 NEW MULT,VIEW
SET MULT=0
SET I=""
IF $DATA(^PRCF(421.5,"D",X))
Begin DoDot:1
+2 FOR
SET I=$ORDER(^PRCF(421.5,"D",X,I))
if I=""
QUIT
SET MULT=MULT+1
if MULT>1
QUIT
+3 QUIT
End DoDot:1
+4 NEW DIC,D
SET DIC="^PRCF(421.5,"
SET DIC(0)="EZ"
SET D="D"
+5 SET X=$PIECE(X,"-",1,2)
+6 DO IX^DIC
if Y<0
QUIT
SET VIEW=+Y
+7 IF VIEW=$GET(PRCF("CIDA"))
SET X=" ("_+Y_" - THIS Invoice.)*"
DO MSG^PRCFQ
+8 IF VIEW
DO VIEW
if MULT>1
GOTO PO1
+9 QUIT
VENDOR ; LOOK UP INVOICES BY VENDOR
+1 SET X=$GET(PRCF("VENDA"))
if X=""
QUIT
+2 NEW MULT,VIEW
SET MULT=0
SET I=""
IF $DATA(^PRCF(421.5,"C",X))
Begin DoDot:1
+3 FOR
SET I=$ORDER(^PRCF(421.5,"C",X,I))
if I=""
QUIT
SET MULT=MULT+1
if MULT>1
QUIT
+4 QUIT
End DoDot:1
+5 NEW DIC
SET DIC="^PRCF(421.5,"
SET DIC(0)="EZ"
SET D="C"
+6 DO IX^DIC
if Y<0
QUIT
SET VIEW=+Y
+7 IF VIEW=$GET(PRCF("CIDA"))
SET X=" ("_+Y_" - THIS Invoice.)*"
DO MSG^PRCFQ
+8 IF VIEW
DO VIEW
if MULT>1
GOTO VENDOR
+9 QUIT
VIEW ;VIEW INDIVIDUAL CERTIFIED INVOICE
+1 SET (FR,TO)=$PIECE(Y,"^",2)
SET L=0
SET BY="@.01;"
SET FLDS="[CAPTIONED]"
SET IOP="HOME"
+2 DO WAIT^PRCFYN
DO EN1^DIP
OUTV KILL DIC,DA,DR,X,Y
+1 QUIT
DUP ; Look for Duplicate Invoice(s)
+1 KILL PRCF("DUP")
SET PRCF("DUP")=0
if '$GET(PRCF("CIDA"))
QUIT
+2 if '$GET(PRCF("VENDA"))
QUIT
if '$DATA(^PRCF(421.5,"C",PRCF("VENDA")))
QUIT
+3 SET PRCF("INVNO")=$PIECE($GET(^PRCF(421.5,PRCF("CIDA"),0)),U,3)
+4 if PRCF("INVNO")=""
QUIT
+5 NEW X
SET X="Checking for duplicate invoices . . .*"
DO MSG^PRCFQ
+6 NEW I
SET I=""
FOR
SET I=$ORDER(^PRCF(421.5,"C",PRCF("VENDA"),I))
if I=""
QUIT
Begin DoDot:1
+7 if I=PRCF("CIDA")
QUIT
+8 IF PRCF("INVNO")=$PIECE($GET(^PRCF(421.5,I,0)),U,3)
Begin DoDot:2
+9 SET PRCF("DUP")=PRCF("DUP")+1
+10 NEW CIDNO
SET CIDNO=$PIECE($GET(^PRCF(421.5,I,0)),U,1)
+11 SET PRCF("DUP",CIDNO)=""
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 IF PRCF("DUP")=0
NEW X
SET X="none found.*"
DO MSG^PRCFQ
QUIT
+15 SET X="WARNING! Identical invoices numbers for this vendor were found in the following Tracking ID#s:*"
+16 DO MSG^PRCFQ
SET I=""
FOR
SET I=$ORDER(PRCF("DUP",I))
if I=""
QUIT
WRITE !?10,I
+17 WRITE !!
SET X="Please review these records and check for duplicate invoices.*"
+18 DO MSG^PRCFQ
+19 QUIT
PPT ; Load Prompt Payment Terms from File 442
+1 if '$GET(PRCF("CIDA"))
QUIT
if '$GET(PRCF("PODA"))
QUIT
+2 if $DATA(^PRCF(421.5,PRCF("CIDA"),6))
QUIT
if '$DATA(^PRC(442,PRCF("PODA"),5,1,0))
QUIT
+3 NEW PPT
SET PPT=$GET(^PRC(442,PRCF("PODA"),5,1,0))
+4 NEW PCT,DAYS
SET PCT=$PIECE(PPT,U,1)
SET DAYS=$PIECE(PPT,U,2)
+5 SET ^PRCF(421.5,PRCF("CIDA"),6,0)="^421.531A^1^1"
+6 SET ^PRCF(421.5,PRCF("CIDA"),6,1,0)="1^^"_PCT_"^^"_DAYS
+7 SET ^PRCF(421.5,PRCF("CIDA"),6,"B",1,1)=""
+8 QUIT
INPUT NEW X0
SET X0=$TRANSLATE(X,"net","NET")
+1 IF X]""
IF $EXTRACT("NET",1,$LENGTH(X0))=X0
SET X=0
QUIT
+2 ; Native FileMan Input Transform follows:
+3 if +X'=X!(X>99.999)!(X<0)!(X?.E1"."4N.N)
KILL X
+4 QUIT
OUTPUT IF Y?1"0"."."."0"
SET Y="NET"
+1 QUIT
+2 NEW DA
SET DA(1)=$GET(PRCF("CIDA"))
if DA(1)=""
QUIT
+3 NEW NODE
SET NODE=$GET(^PRCF(421.5,DA(1),5,0))
+4 IF NODE=""
SET ^PRCF(421.5,DA(1),5,0)=U_$PIECE(^DD(421.5,41,0),U,2)
+5 NEW CTR,I
SET (CTR,I)=0
FOR
SET I=$ORDER(PRCFD(I))
if I'>0
QUIT
Begin DoDot:1
+6 SET CTR=$SELECT(I=991:CTR,1:CTR+1)
SET CTR=$SELECT(CTR=991:992,1:CTR)
+7 NEW DIC
SET DIC="^PRCF(421.5,"_DA(1)_",5,"
SET DIC(0)="L"
+8 SET X=$PIECE(PRCFD(I),U,1)
SET AMT=+$PIECE(PRCFD(I),U,2)
+9 KILL DD,DO
DO FILE^DICN
IF Y'>0
WRITE "ERROR"
QUIT
+10 NEW DIE
SET DIE=DIC
SET DA=+Y
SET FMSL=$SELECT(I=991:991,1:CTR)
+11 NEW DR
SET DR="1////^S X=AMT;2////^S X=FMSL"
DO ^DIE
+12 QUIT
End DoDot:1
+13 QUIT
DISC ; COMPUTE FMS LINE LIQ AMT FROM TOTAL AMT & DISCOUNT TERMS
+1 ; INPUT: PRCF("CIDA") - IEN FOR PAYMENT/INVOICE TRACKING RECORD
+2 ; PRCFA("LAMT") - FMS LINE AMOUNT FOR THIS INVOICE
+3 ; OUTPUT: PRCFA("LIQ") - FMS COMPUTED LIQUIDATION AMOUNT
+4 if '$DATA(PRCF("CIDA"))!'$DATA(PRCFA("LAMT"))
QUIT
+5 NEW I,DISC,HIGHDISC
SET (HIGHDISC,I)=0
+6 FOR
SET I=$ORDER(^PRCF(421.5,PRCF("CIDA"),6,I))
if +I'=I
QUIT
Begin DoDot:1
+7 SET DISC=+$PIECE($GET(^PRCF(421.5,PRCF("CIDA"),6,I,0)),U,3)
+8 IF DISC>HIGHDISC
SET HIGHDISC=DISC
+9 QUIT
End DoDot:1
+10 SET PRCFA("LIQ")=$FNUMBER(1-(HIGHDISC/100)*PRCFA("LAMT"),"",2)
+11 QUIT
SUM ;
+1 ; INPUT: PRCF("CIDA") - IEN FOR PAYMENT/INVOICE TRACKING RECORD
+2 ; PRCFA("CAMT") - TOTAL INVOICE AMOUNT CERTIFIED FOR PAYMENT
+3 ; OUTPUT: OK - 1 IF SUM OF LINE AMOUNTS = TOTAL AMOUNT CERTIFIED
+4 ; - 0 IF AMOUNTS NOT EQUAL
+5 if '$DATA(PRCF("CIDA"))!'$DATA(PRCF("CAMT"))
QUIT
+6 NEW I,LAMT
SET (I,OK,PRCF("TAMT"))=0
+7 FOR
SET I=$ORDER(^PRCF(421.5,PRCF("CIDA"),5,I))
if +I'=I
QUIT
Begin DoDot:1
+8 SET LAMT=+$PIECE($GET(^PRCF(421.5,PRCF("CIDA"),5,I,0)),U,2)
+9 SET PRCF("TAMT")=PRCF("TAMT")+LAMT
+10 QUIT
End DoDot:1
+11 IF PRCF("CAMT")/100=PRCF("TAMT")
SET OK=1
+12 QUIT
SCREEN ; CHECK BOC
+1 IF $GET(X)
IF $DATA(PRCFX("SA",X))
+2 QUIT
LOOKUP(X,PARTIAL) ; X = STA-PAT # - LOOKUP returns next available PARTIAL #.
+1 NEW DIC
SET DIC="^PRCF(421.9,"
SET DIC(0)="O"
KILL DD,DO
DO ^DIC
+2 IF Y<0
DO FILE^DICN
+3 IF +Y
IF $PIECE(Y,U,3)=1
SET PARTIAL="01"
SET $PIECE(^PRCF(421.9,+Y,0),U,2)="01"
QUIT
+4 SET P=$PIECE($GET(^PRCF(421.9,+Y,0)),U,2)
SET P=P+1
+5 SET P="00"_P
SET P=$EXTRACT(P,$LENGTH(P)-1,$LENGTH(P))
+6 SET PARTIAL=P
SET $PIECE(^PRCF(421.9,+Y,0),U,2)=P
+7 QUIT
