PRCAFUT ;WASH-ISC@ALTOONA/CLH-FMS Utilities ;10/8/96 10:50 AM
V ;;4.5;Accounts Receivable;**5,39,64,92,104,169,188,194,220,231,315,338**;Mar 20, 1995;Build 69
;;Per VA Directive 6402, this routine should not be modified.
CPLK(PRCABN) ;get control point from file 430 and set DR string to edit CP data
N DR,X,Y,QUIT,FUND,FTBL,CAT,CATTYP,CATTYPE,CP,BBFY,EBFY,DIC,BGFY,CPTBL,CC,SCC,EXIT,FYERROR
K PRCA("EXIT")
S PRCA("SITE")=$S($G(PRCABN):$P($P($G(^PRCA(430,PRCABN,0)),"^"),"-"),1:$$SITE^RCMSITE)
S CP=$P($G(^PRCA(430,PRCABN,11)),U)
S CAT=+$P($G(^PRCA(430,PRCABN,0)),U,2),CATTYP=$P($G(^PRCA(430.2,CAT,0)),U,13)
I CAT>39,CAT<45 D G END
.S TYPE="09" D CHKELEM,REV Q:$G(PRCA("EXIT"))
.S DR="257///^S X=$G(PRCA(""SITE""))"
.;I CAT'=42 S DR=DR_";258////1"
.D DIE
.Q
I CAT=47 D G END ;315
.S TYPE="02",FUND="0160R1" ; patch PRCA*4.5*338
.S DR="259///"_TYPE_";203///^S X=FUND"
.D DIE
.Q
D TYPE Q:$D(PRCA("EXIT"))
I CATTYP=2 K PRCA("EXIT") D G END
. ;reibursement logic (if there is such a thing)
. S DR="203" D DIE K DR I $D(Y) Q
. I '$D(FUND) S FUND=$P($G(^PRCA(430,PRCABN,11)),U,17) D I FUND=-1 S PRCA("EXIT")="" Q
.. N X,Y,DIC
.. S X=FUND,DIC="^PRCD(420.14,",DIC(0)="XMNZ",DIC("B")=FUND D ^DIC
.. I +Y<0 D FUND^PRCAFBDU D Q:FUND=-1
... S DIC="^PRCD(420.14,",DIC(0)="AEMNQZ",DIC("A")="FUND: ",DIC("B")=FUND
... D ^DIC
... S:+Y<0 FUND=-1 Q
.. S FUND=Y
.. S BBFY=$E($P(Y(0),U,3),3,4),EBFY=$E($P(Y(0),U,4),3,4)
..Q
.S PRCABN(1)=$O(^PRCA(430,+PRCABN,2,0))
.S PRCABN(2)=$G(^PRCA(430,+PRCABN,2,PRCABN(1),0))
.S PRCABN(4)=+$G(PRCABN(2))
.S X=BBFY D ^%DT S PRCABN(3)=$E(Y,1,3)
.K ^PRCA(430,PRCABN,2,PRCABN(1),0)
.K ^PRCA(430,PRCABN,2,"B",PRCABN(4),PRCABN(1))
.S ^PRCA(430,PRCABN,2,PRCABN(3),0)=PRCABN(2)
.S $P(^PRCA(430,PRCABN,2,PRCABN(3),0),"^")=BBFY
.S ^PRCA(430,PRCABN,2,"B",BBFY,PRCABN(3))=""
.D DOCREQ^PRC0C(+FUND,"REV","FTBL")
. I '$D(FTBL) S PRCA("EXIT")=1 D Q
.. W !,*7,"FMS REQUIRED FIELDS missing. Edit the IFCAP REQUIRED FIELDS table",!,"for FUND/FY combination."
.. Q
. S DR="259////^S X=CAT;257////^S X=$G(PRCA(""SITE""));201////^S X=BBFY;202////^S X=$S($G(EBFY)'=BBFY:EBFY,1:"""")"
. D DR
. Q
;Ask Beginning/end budget fiscal year
D FY^PRCAFUT1
I $D(FYERROR) S PRCA("EXIT")=1 Q
;S BGFY=$P(^PRCA(430,PRCABN,0),U,10),BGFY=$$FY^RCFN01(BGFY)
S DR="250;I '$D(CPTBL) D CPTBL^PRCAFUT;259////^S X=CAT;204////^S X=$P(CPTBL,U);206////^S X=$P(CPTBL,U,3)"
S DR=DR_";203////^S X=$P(CPTBL,U,5);201////^S X=$E($P(CPTBL,U,6),3,4)"
S DR(1,430,1)="202////^S X=$S($P(CPTBL,U,7)'=$P(CPTBL,U,6):$E($P(CPTBL,U,7),3,4),1:"""")"
S DR(1,430,2)="261////^S X=$P(CPTBL,U,10)"
S DA=PRCABN D ^DIE K DR
I $D(Y) S PRCA("EXIT")=1 Q
K DR
D FTBL Q:'$D(FTBL)
S (X,PRCABN(1))=$E($P(CPTBL,U,6),3,4)
D ^%DT S PRCABN(2)=$E(Y,1,3)
S PRCABN(3)=$O(^PRCA(430,+PRCABN,2,0))
S PRCABN(4)=$G(^PRCA(430,+PRCABN,2,PRCABN(3),0))
S PRCABN(5)=$E(PRCABN(4),1,2)
K ^PRCA(430,PRCABN,2,PRCABN(3),0)
K ^PRCA(430,PRCABN,2,"B",PRCABN(5),PRCABN(3))
S ^PRCA(430,PRCABN,2,PRCABN(2),0)=PRCABN(4)
S $P(^PRCA(430,PRCABN,2,PRCABN(2),0),"^")=PRCABN(1)
S ^PRCA(430,PRCABN,2,"B",PRCABN(1),PRCABN(2))=""
S $P(^PRCA(430,PRCABN,2,0),"^",3)=PRCABN(2)
Q
FTBL S FUND=$$FUND^PRC0C($P(CPTBL,U,5),$P(CPTBL,U,6))
D DOCREQ^PRC0C(+FUND,"SPE","FTBL")
I '$D(FTBL) W !!,*7,"UNABLE TO GET FMS-LINE FUND ACCOUNTING INFORMATION. CHECK CONTROL POINT." H 5 S PRCA("EXIT")=1 Q
S DR="257////^S X=$G(PRCA(""SITE""))"
DR I $$INTEG^RCFN01($G(PRCA("SITE"))) S DR=DR_";260"
I $G(FTBL("AO"))="Y" S DR=DR_";204"
I $G(FTBL("FCPRJ"))="Y" S DR=DR_";I '$D(CPTBL) D CPTBL^PRCAFUT;206////^S X=$P(CPTBL,U,3)"
I $G(FTBL("CC"))="Y" S DR=DR_";251;252////^S X=$G(SCC)"
I $G(FTBL("BOC"))="Y" S DR=DR_";253"
I $G(FTBL("SBOC"))="Y"!(CAT=20) S DR=DR_";254"
I $G(FTBL("JOB"))="Y" S DR=DR_";261"
I $G(FTBL("RC"))="Y" S DR=DR_";263"
I $G(FTBL("REV"))="Y" D DIE Q:$G(PRCA("EXIT")) D REV Q:$G(PRCA("EXIT"))
I $G(FTBL("SREV"))="Y" S DR=$S(DR="":"256",1:DR_";256")
I $G(FTBL("OC"))="Y" S DR=$S(DR="":"205",1:DR_";205")
I DR'="" D DIE
Q
DIE S DA=PRCABN,DIE="^PRCA(430," D ^DIE
END I $D(Y) S PRCA("EXIT")=1
K DR Q
;
RECTYP(BN) ;Refund or reimbursement
I '$D(BN),'$D(^PRCA(430,BN,0)) Q -1
Q $P($G(^PRCA(430,BN,11)),U,10)
;
REV ;lookup revenue by calling "C" xref
N DS,DIC,DIBTDH,HELP,I,IAT,OUT,RV,X,Y
S OUT=0,RV=$P($G(^PRCA(430,PRCABN,11)),U,6)
F D Q:OUT
.W !,"REVENUE SOURCE: "_$S(RV'="":RV_"// ",1:"") R X:DTIME
.I $E(X)="?",X?."?" D @($S($L(X)=1:"REVH1",1:"REVH2")) S DIC=347.3,DIC(0)="QE" D ^DIC Q:Y<1 Q
.I $E(X)="^",X?."^" S OUT=1,PRCA("EXIT")=1 Q
.I X="@" W "?? Required" Q
.I X="",RV'="" S OUT=1 Q
.I X="",RV="" W "??" D REVH1 Q
.I $D(^RC(347.3,"B",X)) D Q
..S DS=$P($G(^RC(347.3,+$O(^RC(347.3,"B",X,0)),0)),U,2),IAT=$P(^(0),U,3)
..W " "_DS W:IAT " INACTIVE" D REVDIE
.S DIC="^RC(347.3,",DIC(0)="QE",D="C" D IX^DIC I Y<1 D REVH1 Q
.S X=$P(Y,U,2) D REVDIE
S DR=""
Q
REVDIE S DA=PRCABN,DIE="^PRCA(430,",DR="255///"_X D ^DIE I $G(X)'="" S OUT=1 Q
D REVH1 Q
REVH1 S HELP("DIHELP",1)=$G(^DD(430,255,3)) D MSG^DIALOG("WH","",70,5,"HELP") Q
REVH2 D HELP^DIE(430,"",255,"D","HELP"),MSG^DIALOG("WH","",70,8,"HELP") Q
;
FUND ;get fund
N DIC,Y
S DIC="^PRCD(420.14,",DIC(0)="EMNQZ"
D ^DIC
I $D(DUOUT)!$D(DTOUT) S PRCA("EXIT")=1 Q
Q:+Y<0
S FUND=Y
S BBFY=$E($P(Y(0),U,3),3,4),EBFY=$E($P(Y(0),U,4),3,4)
Q
;
DISPLACC ;display account information
Q:'$D(PRCABN) NEW DIC,L,FR,TO,FLDS,IOP,X
R !!,"Press <RETURN> to continue: ",X:60
I X["^" S PRCA("EXIT")="" Q
S IOP=IO(0),DIC="^PRCA(430,",FLDS="[PRCA DISP AUDIT2]",(FR,TO)=PRCABN,L=0,BY="@NUMBER" D EN1^DIP
Q
;
CP ;lookup control point
N DIC
S DIC="^PRC(420,"_$S($D(PRCA("SITE")):PRCA("SITE"),1:$$SITE^RCMSITE)_",1,",DIC(0)="EMNQ",X=CP
D ^DIC
I +Y<0 K X,CP Q
S CP=+Y
Q
;
CC ;cost center
G CC^PRCAFBDU
;
BOC ;budget object code
G BOC^PRCAFBDU
;
TYPE ;ask if bill is a refund or reimbursement
W !!,"Building FMS Accounting Elements...",!
N DIR,Y,TYPE
I +$G(CAT)=1 S CAT="02",CATTYPE=2 D CHKELEM Q
I +$G(CAT)=10 S CAT=50,CATTYPE=2 D CHKELEM Q
I +$G(CAT)=47 S CAT="02" Q
D BDTRANS^PRCAFBDU
Q:$D(PRCA("EXIT"))
S CATTYP=$S(TYPE="01":"1",TYPE="20":"1",1:"2")
S CAT=TYPE ; I CAT>2 S CAT=$S(CAT=4:"20",1:"9")
D CHKELEM
Q
;
CHKELEM ;check for correct accounting line data
N I
Q:'$D(^PRCA(430,PRCABN,11))
I $G(CATTYP)=1 D Q
. F I=6,7 S $P(^PRCA(430,PRCABN,11),U,I)=""
. Q
Q:$G(TYPE)=10
F I=1:1:5,11:1:16,18:1:21 S $P(^PRCA(430,PRCABN,11),U,I)=""
S $P(^PRCA(430,PRCABN,11),U,15)="05"
Q
CPTBL ;build CP table
S:'$D(BGFY) BGFY=$$FY^RCFN01(DT)
S BGFY(1)=$S(BGFY>50:19,1:20)
S CPTBL=$$ACC^PRC0C($G(PRCA("SITE")),+CP_U_BGFY_U_BGFY(1)_BGFY)
I '$D(CPTBL) S CPTBL=""
Q
;
CPHLP ;executable help for cp prompt
N DIC,X,Y
S DIC="^PRC(420,"_$S($D(PRCA("SITE")):PRCA("SITE"),1:$$SITE^RCMSITE)_",1,",DIC(0)="EMQ",X="?" D ^DIC
Q
;
FND(BILL) ;Get fund for a bill
I '$D(^PRCA(430,BILL,0)) Q -1
I $D(^PRCA(430,BILL,11)),$P(^(11),"^",17)'="" Q $P(^(11),"^",17)
I $P(^PRCA(430,BILL,0),"^",18)'="" Q $E($P(^(0),"^",18),4,9)
Q -1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAFUT 7320 printed Oct 16, 2024@17:40:26 Page 2
PRCAFUT ;WASH-ISC@ALTOONA/CLH-FMS Utilities ;10/8/96 10:50 AM
V ;;4.5;Accounts Receivable;**5,39,64,92,104,169,188,194,220,231,315,338**;Mar 20, 1995;Build 69
+1 ;;Per VA Directive 6402, this routine should not be modified.
CPLK(PRCABN) ;get control point from file 430 and set DR string to edit CP data
+1 NEW DR,X,Y,QUIT,FUND,FTBL,CAT,CATTYP,CATTYPE,CP,BBFY,EBFY,DIC,BGFY,CPTBL,CC,SCC,EXIT,FYERROR
+2 KILL PRCA("EXIT")
+3 SET PRCA("SITE")=$SELECT($GET(PRCABN):$PIECE($PIECE($GET(^PRCA(430,PRCABN,0)),"^"),"-"),1:$$SITE^RCMSITE)
+4 SET CP=$PIECE($GET(^PRCA(430,PRCABN,11)),U)
+5 SET CAT=+$PIECE($GET(^PRCA(430,PRCABN,0)),U,2)
SET CATTYP=$PIECE($GET(^PRCA(430.2,CAT,0)),U,13)
+6 IF CAT>39
IF CAT<45
Begin DoDot:1
+7 SET TYPE="09"
DO CHKELEM
DO REV
if $GET(PRCA("EXIT"))
QUIT
+8 SET DR="257///^S X=$G(PRCA(""SITE""))"
+9 ;I CAT'=42 S DR=DR_";258////1"
+10 DO DIE
+11 QUIT
End DoDot:1
GOTO END
+12 ;315
IF CAT=47
Begin DoDot:1
+13 ; patch PRCA*4.5*338
SET TYPE="02"
SET FUND="0160R1"
+14 SET DR="259///"_TYPE_";203///^S X=FUND"
+15 DO DIE
+16 QUIT
End DoDot:1
GOTO END
+17 DO TYPE
if $DATA(PRCA("EXIT"))
QUIT
+18 IF CATTYP=2
KILL PRCA("EXIT")
Begin DoDot:1
+19 ;reibursement logic (if there is such a thing)
+20 SET DR="203"
DO DIE
KILL DR
IF $DATA(Y)
QUIT
+21 IF '$DATA(FUND)
SET FUND=$PIECE($GET(^PRCA(430,PRCABN,11)),U,17)
Begin DoDot:2
+22 NEW X,Y,DIC
+23 SET X=FUND
SET DIC="^PRCD(420.14,"
SET DIC(0)="XMNZ"
SET DIC("B")=FUND
DO ^DIC
+24 IF +Y<0
DO FUND^PRCAFBDU
Begin DoDot:3
+25 SET DIC="^PRCD(420.14,"
SET DIC(0)="AEMNQZ"
SET DIC("A")="FUND: "
SET DIC("B")=FUND
+26 DO ^DIC
+27 if +Y<0
SET FUND=-1
QUIT
End DoDot:3
if FUND=-1
QUIT
+28 SET FUND=Y
+29 SET BBFY=$EXTRACT($PIECE(Y(0),U,3),3,4)
SET EBFY=$EXTRACT($PIECE(Y(0),U,4),3,4)
+30 QUIT
End DoDot:2
IF FUND=-1
SET PRCA("EXIT")=""
QUIT
+31 SET PRCABN(1)=$ORDER(^PRCA(430,+PRCABN,2,0))
+32 SET PRCABN(2)=$GET(^PRCA(430,+PRCABN,2,PRCABN(1),0))
+33 SET PRCABN(4)=+$GET(PRCABN(2))
+34 SET X=BBFY
DO ^%DT
SET PRCABN(3)=$EXTRACT(Y,1,3)
+35 KILL ^PRCA(430,PRCABN,2,PRCABN(1),0)
+36 KILL ^PRCA(430,PRCABN,2,"B",PRCABN(4),PRCABN(1))
+37 SET ^PRCA(430,PRCABN,2,PRCABN(3),0)=PRCABN(2)
+38 SET $PIECE(^PRCA(430,PRCABN,2,PRCABN(3),0),"^")=BBFY
+39 SET ^PRCA(430,PRCABN,2,"B",BBFY,PRCABN(3))=""
+40 DO DOCREQ^PRC0C(+FUND,"REV","FTBL")
+41 IF '$DATA(FTBL)
SET PRCA("EXIT")=1
Begin DoDot:2
+42 WRITE !,*7,"FMS REQUIRED FIELDS missing. Edit the IFCAP REQUIRED FIELDS table",!,"for FUND/FY combination."
+43 QUIT
End DoDot:2
QUIT
+44 SET DR="259////^S X=CAT;257////^S X=$G(PRCA(""SITE""));201////^S X=BBFY;202////^S X=$S($G(EBFY)'=BBFY:EBFY,1:"""")"
+45 DO DR
+46 QUIT
End DoDot:1
GOTO END
+47 ;Ask Beginning/end budget fiscal year
+48 DO FY^PRCAFUT1
+49 IF $DATA(FYERROR)
SET PRCA("EXIT")=1
QUIT
+50 ;S BGFY=$P(^PRCA(430,PRCABN,0),U,10),BGFY=$$FY^RCFN01(BGFY)
+51 SET DR="250;I '$D(CPTBL) D CPTBL^PRCAFUT;259////^S X=CAT;204////^S X=$P(CPTBL,U);206////^S X=$P(CPTBL,U,3)"
+52 SET DR=DR_";203////^S X=$P(CPTBL,U,5);201////^S X=$E($P(CPTBL,U,6),3,4)"
+53 SET DR(1,430,1)="202////^S X=$S($P(CPTBL,U,7)'=$P(CPTBL,U,6):$E($P(CPTBL,U,7),3,4),1:"""")"
+54 SET DR(1,430,2)="261////^S X=$P(CPTBL,U,10)"
+55 SET DA=PRCABN
DO ^DIE
KILL DR
+56 IF $DATA(Y)
SET PRCA("EXIT")=1
QUIT
+57 KILL DR
+58 DO FTBL
if '$DATA(FTBL)
QUIT
+59 SET (X,PRCABN(1))=$EXTRACT($PIECE(CPTBL,U,6),3,4)
+60 DO ^%DT
SET PRCABN(2)=$EXTRACT(Y,1,3)
+61 SET PRCABN(3)=$ORDER(^PRCA(430,+PRCABN,2,0))
+62 SET PRCABN(4)=$GET(^PRCA(430,+PRCABN,2,PRCABN(3),0))
+63 SET PRCABN(5)=$EXTRACT(PRCABN(4),1,2)
+64 KILL ^PRCA(430,PRCABN,2,PRCABN(3),0)
+65 KILL ^PRCA(430,PRCABN,2,"B",PRCABN(5),PRCABN(3))
+66 SET ^PRCA(430,PRCABN,2,PRCABN(2),0)=PRCABN(4)
+67 SET $PIECE(^PRCA(430,PRCABN,2,PRCABN(2),0),"^")=PRCABN(1)
+68 SET ^PRCA(430,PRCABN,2,"B",PRCABN(1),PRCABN(2))=""
+69 SET $PIECE(^PRCA(430,PRCABN,2,0),"^",3)=PRCABN(2)
+70 QUIT
FTBL SET FUND=$$FUND^PRC0C($PIECE(CPTBL,U,5),$PIECE(CPTBL,U,6))
+1 DO DOCREQ^PRC0C(+FUND,"SPE","FTBL")
+2 IF '$DATA(FTBL)
WRITE !!,*7,"UNABLE TO GET FMS-LINE FUND ACCOUNTING INFORMATION. CHECK CONTROL POINT."
HANG 5
SET PRCA("EXIT")=1
QUIT
+3 SET DR="257////^S X=$G(PRCA(""SITE""))"
DR IF $$INTEG^RCFN01($GET(PRCA("SITE")))
SET DR=DR_";260"
+1 IF $GET(FTBL("AO"))="Y"
SET DR=DR_";204"
+2 IF $GET(FTBL("FCPRJ"))="Y"
SET DR=DR_";I '$D(CPTBL) D CPTBL^PRCAFUT;206////^S X=$P(CPTBL,U,3)"
+3 IF $GET(FTBL("CC"))="Y"
SET DR=DR_";251;252////^S X=$G(SCC)"
+4 IF $GET(FTBL("BOC"))="Y"
SET DR=DR_";253"
+5 IF $GET(FTBL("SBOC"))="Y"!(CAT=20)
SET DR=DR_";254"
+6 IF $GET(FTBL("JOB"))="Y"
SET DR=DR_";261"
+7 IF $GET(FTBL("RC"))="Y"
SET DR=DR_";263"
+8 IF $GET(FTBL("REV"))="Y"
DO DIE
if $GET(PRCA("EXIT"))
QUIT
DO REV
if $GET(PRCA("EXIT"))
QUIT
+9 IF $GET(FTBL("SREV"))="Y"
SET DR=$SELECT(DR="":"256",1:DR_";256")
+10 IF $GET(FTBL("OC"))="Y"
SET DR=$SELECT(DR="":"205",1:DR_";205")
+11 IF DR'=""
DO DIE
+12 QUIT
DIE SET DA=PRCABN
SET DIE="^PRCA(430,"
DO ^DIE
END IF $DATA(Y)
SET PRCA("EXIT")=1
+1 KILL DR
QUIT
+2 ;
RECTYP(BN) ;Refund or reimbursement
+1 IF '$DATA(BN)
IF '$DATA(^PRCA(430,BN,0))
QUIT -1
+2 QUIT $PIECE($GET(^PRCA(430,BN,11)),U,10)
+3 ;
REV ;lookup revenue by calling "C" xref
+1 NEW DS,DIC,DIBTDH,HELP,I,IAT,OUT,RV,X,Y
+2 SET OUT=0
SET RV=$PIECE($GET(^PRCA(430,PRCABN,11)),U,6)
+3 FOR
Begin DoDot:1
+4 WRITE !,"REVENUE SOURCE: "_$SELECT(RV'="":RV_"// ",1:"")
READ X:DTIME
+5 IF $EXTRACT(X)="?"
IF X?."?"
DO @($SELECT($LENGTH(X)=1:"REVH1",1:"REVH2"))
SET DIC=347.3
SET DIC(0)="QE"
DO ^DIC
if Y<1
QUIT
QUIT
+6 IF $EXTRACT(X)="^"
IF X?."^"
SET OUT=1
SET PRCA("EXIT")=1
QUIT
+7 IF X="@"
WRITE "?? Required"
QUIT
+8 IF X=""
IF RV'=""
SET OUT=1
QUIT
+9 IF X=""
IF RV=""
WRITE "??"
DO REVH1
QUIT
+10 IF $DATA(^RC(347.3,"B",X))
Begin DoDot:2
+11 SET DS=$PIECE($GET(^RC(347.3,+$ORDER(^RC(347.3,"B",X,0)),0)),U,2)
SET IAT=$PIECE(^(0),U,3)
+12 WRITE " "_DS
if IAT
WRITE " INACTIVE"
DO REVDIE
End DoDot:2
QUIT
+13 SET DIC="^RC(347.3,"
SET DIC(0)="QE"
SET D="C"
DO IX^DIC
IF Y<1
DO REVH1
QUIT
+14 SET X=$PIECE(Y,U,2)
DO REVDIE
End DoDot:1
if OUT
QUIT
+15 SET DR=""
+16 QUIT
REVDIE SET DA=PRCABN
SET DIE="^PRCA(430,"
SET DR="255///"_X
DO ^DIE
IF $GET(X)'=""
SET OUT=1
QUIT
+1 DO REVH1
QUIT
REVH1 SET HELP("DIHELP",1)=$GET(^DD(430,255,3))
DO MSG^DIALOG("WH","",70,5,"HELP")
QUIT
REVH2 DO HELP^DIE(430,"",255,"D","HELP")
DO MSG^DIALOG("WH","",70,8,"HELP")
QUIT
+1 ;
FUND ;get fund
+1 NEW DIC,Y
+2 SET DIC="^PRCD(420.14,"
SET DIC(0)="EMNQZ"
+3 DO ^DIC
+4 IF $DATA(DUOUT)!$DATA(DTOUT)
SET PRCA("EXIT")=1
QUIT
+5 if +Y<0
QUIT
+6 SET FUND=Y
+7 SET BBFY=$EXTRACT($PIECE(Y(0),U,3),3,4)
SET EBFY=$EXTRACT($PIECE(Y(0),U,4),3,4)
+8 QUIT
+9 ;
DISPLACC ;display account information
+1 if '$DATA(PRCABN)
QUIT
NEW DIC,L,FR,TO,FLDS,IOP,X
+2 READ !!,"Press <RETURN> to continue: ",X:60
+3 IF X["^"
SET PRCA("EXIT")=""
QUIT
+4 SET IOP=IO(0)
SET DIC="^PRCA(430,"
SET FLDS="[PRCA DISP AUDIT2]"
SET (FR,TO)=PRCABN
SET L=0
SET BY="@NUMBER"
DO EN1^DIP
+5 QUIT
+6 ;
CP ;lookup control point
+1 NEW DIC
+2 SET DIC="^PRC(420,"_$SELECT($DATA(PRCA("SITE")):PRCA("SITE"),1:$$SITE^RCMSITE)_",1,"
SET DIC(0)="EMNQ"
SET X=CP
+3 DO ^DIC
+4 IF +Y<0
KILL X,CP
QUIT
+5 SET CP=+Y
+6 QUIT
+7 ;
CC ;cost center
+1 GOTO CC^PRCAFBDU
+2 ;
BOC ;budget object code
+1 GOTO BOC^PRCAFBDU
+2 ;
TYPE ;ask if bill is a refund or reimbursement
+1 WRITE !!,"Building FMS Accounting Elements...",!
+2 NEW DIR,Y,TYPE
+3 IF +$GET(CAT)=1
SET CAT="02"
SET CATTYPE=2
DO CHKELEM
QUIT
+4 IF +$GET(CAT)=10
SET CAT=50
SET CATTYPE=2
DO CHKELEM
QUIT
+5 IF +$GET(CAT)=47
SET CAT="02"
QUIT
+6 DO BDTRANS^PRCAFBDU
+7 if $DATA(PRCA("EXIT"))
QUIT
+8 SET CATTYP=$SELECT(TYPE="01":"1",TYPE="20":"1",1:"2")
+9 ; I CAT>2 S CAT=$S(CAT=4:"20",1:"9")
SET CAT=TYPE
+10 DO CHKELEM
+11 QUIT
+12 ;
CHKELEM ;check for correct accounting line data
+1 NEW I
+2 if '$DATA(^PRCA(430,PRCABN,11))
QUIT
+3 IF $GET(CATTYP)=1
Begin DoDot:1
+4 FOR I=6,7
SET $PIECE(^PRCA(430,PRCABN,11),U,I)=""
+5 QUIT
End DoDot:1
QUIT
+6 if $GET(TYPE)=10
QUIT
+7 FOR I=1:1:5,11:1:16,18:1:21
SET $PIECE(^PRCA(430,PRCABN,11),U,I)=""
+8 SET $PIECE(^PRCA(430,PRCABN,11),U,15)="05"
+9 QUIT
CPTBL ;build CP table
+1 if '$DATA(BGFY)
SET BGFY=$$FY^RCFN01(DT)
+2 SET BGFY(1)=$SELECT(BGFY>50:19,1:20)
+3 SET CPTBL=$$ACC^PRC0C($GET(PRCA("SITE")),+CP_U_BGFY_U_BGFY(1)_BGFY)
+4 IF '$DATA(CPTBL)
SET CPTBL=""
+5 QUIT
+6 ;
CPHLP ;executable help for cp prompt
+1 NEW DIC,X,Y
+2 SET DIC="^PRC(420,"_$SELECT($DATA(PRCA("SITE")):PRCA("SITE"),1:$$SITE^RCMSITE)_",1,"
SET DIC(0)="EMQ"
SET X="?"
DO ^DIC
+3 QUIT
+4 ;
FND(BILL) ;Get fund for a bill
+1 IF '$DATA(^PRCA(430,BILL,0))
QUIT -1
+2 IF $DATA(^PRCA(430,BILL,11))
IF $PIECE(^(11),"^",17)'=""
QUIT $PIECE(^(11),"^",17)
+3 IF $PIECE(^PRCA(430,BILL,0),"^",18)'=""
QUIT $EXTRACT($PIECE(^(0),"^",18),4,9)
+4 QUIT -1
+5 ;
