- 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 Mar 13, 2025@21:07:50 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
