- RCBEUTRA ;WISC/RFJ-utilties for transactions (in file 433) ;1 Jun 00
- ;;4.5;Accounts Receivable;**153,169,204,326,332**;Mar 20, 1995;Build 40
- ;;Per VA Directive 6402, this routine should not be modified.
- Q
- ;
- ;
- ADD433(BILLDA,TRANTYPE) ; add a new transaction to file 433 (silent)
- ; return: ien of 433 transaction or 0^error msg
- ; : ^prca(433,ien) will be locked if entry selected
- ; Input - optional variable RCDUZ for the processed by user. SET in ^RCDPEAP from MARKED FOR AUTOPOST USER. PRCA*4.5*326
- N %I,DA,DATA0,DD,DIC,DICR,DIE,DINUM,DIW,DLAYGO,DO,I,RCTRANDA,REFCODE,X,Y
- ;
- ; find next available transaction number
- ; add an extra level of locks, some operating systems do not process
- ; the locks correctly if they happen at the same time.
- L +^PRCA(433,"ADDNEWENTRY"):DILOCKTM
- I '$T Q "0^Another user is adding an AR Transaction, please try again later."
- ; start with last entry in file
- ; -> if no data is in the entry, lock it
- ; -> if the lock works and no data was added (prior to the lock)
- ; -> then you have the entry.
- ; -> otherwise, unlock it and start over
- F DINUM=$P(^PRCA(433,0),"^",3)+1:1 I '$D(^PRCA(433,DINUM)) L +^PRCA(433,DINUM):DILOCKTM Q:$T&('$D(^PRCA(433,DINUM))) L -^PRCA(433,DINUM)
- L -^PRCA(433,"ADDNEWENTRY")
- ;
- ; add entry to file
- S RCTRANDA=DINUM,(DIC,DIE)="^PRCA(433,",DIC(0)="L",DLAYGO=433,X=DINUM
- ; build DR string, 42=processed by (use postmaster if queued)
- S DIC("DR")="42////"_$S($G(RCDUZ):RCDUZ,$D(ZTQUEUED):.5,1:DUZ)_";" ; PRCA*4.5*326 Use RCDUZ if defined
- S DIC("DR")=DIC("DR")_".03////"_BILLDA_";" ;bill ien
- S DIC("DR")=DIC("DR")_"12////"_TRANTYPE_";" ;transaction type
- S DATA0=$G(^PRCA(430,BILLDA,0))
- ; appropriation symbol
- I $P(DATA0,"^",18)'="" S DIC("DR")=DIC("DR")_"8////"_$P(DATA0,"^",18)_";"
- ; segment
- I $P(DATA0,"^",21)'="" S DIC("DR")=DIC("DR")_"6////"_$P(DATA0,"^",21)_";"
- ; test for referral code
- S REFCODE=$P($G(^PRCA(430,BILLDA,6)),"^",5)
- I REFCODE'="" S REFCODE=$S(REFCODE="DC":"RC",1:REFCODE),DIC("DR")=DIC("DR")_"7////"_REFCODE_";"
- ; file it
- D FILE^DICN
- I Y=-1 L -^PRCA(433,RCTRANDA) Q "0^UNABLE TO ADD A NEW ENTRY TO FILE 433"
- Q RCTRANDA
- ;
- ;
- FY433(RCTRANDA) ; transfer fiscal year multiple from 430 to 433
- ; bill number must be stored in file 433, field .03 before calling
- N BILLDA,FY,FYDATA
- S BILLDA=+$P($G(^PRCA(433,RCTRANDA,0)),"^",2) I 'BILLDA Q
- K ^PRCA(433,RCTRANDA,4)
- S FY=0 F S FY=$O(^PRCA(430,BILLDA,2,FY)) Q:'FY D
- . S FYDATA=$G(^PRCA(430,BILLDA,2,FY,0)) I $P(FYDATA,"^")="" Q
- . S ^PRCA(433,RCTRANDA,4,FY,0)=$P(FYDATA,"^",1,3)_"^1"
- . S ^PRCA(433,RCTRANDA,4,"B",$P(FYDATA,"^"),FY)=""
- ;
- S ^PRCA(433,RCTRANDA,4,0)="^433.01I^"_$P($G(^PRCA(430,BILLDA,2,0)),"^",3,4)
- Q
- ;
- ;
- FYMULT(RCTRANDA) ; apply payment to fy multiple, oldest first
- N AMOUNT,FYDA,FYAMOUNT
- ; transfer fy multiple if not there
- I '$D(^PRCA(433,RCTRANDA,4)) D FY433(RCTRANDA)
- ; amount is principal amount
- S AMOUNT=$P($$TRANVALU^RCDPBTLM(RCTRANDA),"^",2) I 'AMOUNT Q
- ;
- ; the transaction value is minus, decrease principal
- I AMOUNT<0 D Q
- . S AMOUNT=-AMOUNT
- . S FYDA=0 F S FYDA=$O(^PRCA(433,RCTRANDA,4,FYDA)) Q:'FYDA D I 'AMOUNT Q
- . . S FYAMOUNT=$P($G(^PRCA(433,RCTRANDA,4,FYDA,0)),"^",2)
- . . ; fy amount is greater than transaction amount
- . . I FYAMOUNT>AMOUNT D Q
- . . . S $P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",2)=FYAMOUNT-AMOUNT
- . . . S $P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",5)=AMOUNT
- . . . S AMOUNT=0
- . . ; fy amount not greater than total amount
- . . S $P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",2)=0
- . . S $P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",5)=FYAMOUNT
- . . S AMOUNT=AMOUNT-FYAMOUNT
- . ; move back to 430
- . D FYMULT^RCBEUBIL(RCTRANDA)
- ;
- ; the transaction value is plus, increase principal
- S FYDA=$O(^PRCA(433,RCTRANDA,4,999),-1) I 'FYDA Q
- S $P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",2)=$P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",2)+AMOUNT
- S $P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",5)=AMOUNT
- ; move back to 430
- D FYMULT^RCBEUBIL(RCTRANDA)
- Q
- ;
- ;
- EDIT433(RCTRANDA,DR) ; edit the field in 433 with the DR string passed
- I '$D(^PRCA(433,RCTRANDA)) Q
- N %,D,D0,D1,DA,DDH,DI,DIC,DIE,DQ,J,X,Y
- S (DIC,DIE)="^PRCA(433,",DA=RCTRANDA
- D ^DIE
- ; user pressed up-arrow
- I $D(Y) Q "0^TRANSACTION NOT COMPLETELY PROCESSED"
- Q 1
- ;
- ;
- PROCESS(RCTRANDA) ; mark transaction as processed
- I '$D(^PRCA(433,RCTRANDA,0)) Q
- N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
- S (DIC,DIE)="^PRCA(433,",DA=RCTRANDA
- S DR="3////0;4////2;"
- D ^DIE
- Q
- ;
- ;
- INCOMPLE(RCTRANDA) ; opposite of processed, make a transaction incomplete
- I '$D(^PRCA(433,RCTRANDA,0)) Q
- N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
- S (DIC,DIE)="^PRCA(433,",DA=RCTRANDA
- S DR="4////1;"
- D ^DIE
- Q
- ;
- ;
- DEL433(RCTRANDA,COMMENT,ARCHIVE) ; delete (mark incomplete) in file 433
- ; comment is the user comment in field 41 (default USER CANCELLED)
- ; archive is set to 1 if called to archive transaction
- I '$D(^PRCA(433,RCTRANDA,0)) Q
- N %,D,D0,DA,DI,DIC,DIE,DQ,DR,J,RCBILLDA,X,Y
- ;
- S (DIC,DIE)="^PRCA(433,",DA=RCTRANDA
- ; build DR string
- S DR=""
- S DR=DR_"4////1;" ;transaction status incomplete
- S DR=DR_"10////1;" ;incomplete transaction flag
- S DR=DR_"11///T;" ;transaction date
- I $G(COMMENT)="" S COMMENT="USER CANCELLED"
- S DR=DR_"41///"_COMMENT_";"
- ; brief comment
- S RCBILLDA=$P($G(^PRCA(433,RCTRANDA,0)),"^",2)
- S DR=DR_"5.02////SYSTEM "_$S($G(ARCHIVE):"ARCHIVED",1:"INACTIVATED")_$S(RCBILLDA:" (BILL "_$P($G(^PRCA(430,RCBILLDA,0)),"^")_")",1:"")_";"
- D ^DIE
- ; since the bill number (field .03) is required, it must be manually removed
- I RCBILLDA S $P(^PRCA(433,RCTRANDA,0),"^",2)="" K ^PRCA(433,"C",RCBILLDA,RCTRANDA)
- ; remove fy multiple
- K ^PRCA(433,RCTRANDA,4)
- Q
- ;
- ;
- ADDCOMM(RCTRANDA,COMMENT) ; automatically put a comment on a transaction
- ; comment in the array comment(1)=first line
- ; comment(2)=second line
- N CURRLINE,LINE
- ; get the last line
- S CURRLINE=$O(^PRCA(433,RCTRANDA,7,99999999),-1)
- ; if comment already on transaction, add a blank line and
- ; date time of new comment
- I CURRLINE D
- . S CURRLINE=CURRLINE+1,^PRCA(433,RCTRANDA,7,CURRLINE,0)=" "
- . S CURRLINE=CURRLINE+1,^PRCA(433,RCTRANDA,7,CURRLINE,0)="Comment added on: "_$$FMTE^XLFDT($$NOW^XLFDT)
- ; add new lines
- F LINE=1:1 Q:'$D(COMMENT(LINE)) S ^PRCA(433,RCTRANDA,7,CURRLINE+LINE,0)=COMMENT(LINE)
- ; set the 0th node
- S ^PRCA(433,RCTRANDA,7,0)="^^"_(CURRLINE+LINE-1)_"^"_(CURRLINE+LINE-1)_"^"_DT_"^"
- Q
- FMSDATE(X) ;Finds the next month & year and sets the date for transmission
- ;of the document to FMS. If DT is after EOAM and the document has not
- ;been previously transmitted, the date will be set to the first of the
- ;next month. If the DT is after the EOAM and the document is being
- ;re-transmitted, the the date of transmission will be DT. The flag REGEN
- ;is set in the source code if the document is being
- ;re-transmitted, thus will have a transmission date of DT.
- I $G(REFMS) G QUIT
- I DT>$$LDATE^RCRJR(DT) S X=$E($$FPS^RCAMFN01(X,1),1,5)_"01"
- QUIT Q X
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCBEUTRA 7210 printed Jan 18, 2025@02:44:10 Page 2
- RCBEUTRA ;WISC/RFJ-utilties for transactions (in file 433) ;1 Jun 00
- +1 ;;4.5;Accounts Receivable;**153,169,204,326,332**;Mar 20, 1995;Build 40
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 QUIT
- +4 ;
- +5 ;
- ADD433(BILLDA,TRANTYPE) ; add a new transaction to file 433 (silent)
- +1 ; return: ien of 433 transaction or 0^error msg
- +2 ; : ^prca(433,ien) will be locked if entry selected
- +3 ; Input - optional variable RCDUZ for the processed by user. SET in ^RCDPEAP from MARKED FOR AUTOPOST USER. PRCA*4.5*326
- +4 NEW %I,DA,DATA0,DD,DIC,DICR,DIE,DINUM,DIW,DLAYGO,DO,I,RCTRANDA,REFCODE,X,Y
- +5 ;
- +6 ; find next available transaction number
- +7 ; add an extra level of locks, some operating systems do not process
- +8 ; the locks correctly if they happen at the same time.
- +9 LOCK +^PRCA(433,"ADDNEWENTRY"):DILOCKTM
- +10 IF '$TEST
- QUIT "0^Another user is adding an AR Transaction, please try again later."
- +11 ; start with last entry in file
- +12 ; -> if no data is in the entry, lock it
- +13 ; -> if the lock works and no data was added (prior to the lock)
- +14 ; -> then you have the entry.
- +15 ; -> otherwise, unlock it and start over
- +16 FOR DINUM=$PIECE(^PRCA(433,0),"^",3)+1:1
- IF '$DATA(^PRCA(433,DINUM))
- LOCK +^PRCA(433,DINUM):DILOCKTM
- if $TEST&('$DATA(^PRCA(433,DINUM)))
- QUIT
- LOCK -^PRCA(433,DINUM)
- +17 LOCK -^PRCA(433,"ADDNEWENTRY")
- +18 ;
- +19 ; add entry to file
- +20 SET RCTRANDA=DINUM
- SET (DIC,DIE)="^PRCA(433,"
- SET DIC(0)="L"
- SET DLAYGO=433
- SET X=DINUM
- +21 ; build DR string, 42=processed by (use postmaster if queued)
- +22 ; PRCA*4.5*326 Use RCDUZ if defined
- SET DIC("DR")="42////"_$SELECT($GET(RCDUZ):RCDUZ,$DATA(ZTQUEUED):.5,1:DUZ)_";"
- +23 ;bill ien
- SET DIC("DR")=DIC("DR")_".03////"_BILLDA_";"
- +24 ;transaction type
- SET DIC("DR")=DIC("DR")_"12////"_TRANTYPE_";"
- +25 SET DATA0=$GET(^PRCA(430,BILLDA,0))
- +26 ; appropriation symbol
- +27 IF $PIECE(DATA0,"^",18)'=""
- SET DIC("DR")=DIC("DR")_"8////"_$PIECE(DATA0,"^",18)_";"
- +28 ; segment
- +29 IF $PIECE(DATA0,"^",21)'=""
- SET DIC("DR")=DIC("DR")_"6////"_$PIECE(DATA0,"^",21)_";"
- +30 ; test for referral code
- +31 SET REFCODE=$PIECE($GET(^PRCA(430,BILLDA,6)),"^",5)
- +32 IF REFCODE'=""
- SET REFCODE=$SELECT(REFCODE="DC":"RC",1:REFCODE)
- SET DIC("DR")=DIC("DR")_"7////"_REFCODE_";"
- +33 ; file it
- +34 DO FILE^DICN
- +35 IF Y=-1
- LOCK -^PRCA(433,RCTRANDA)
- QUIT "0^UNABLE TO ADD A NEW ENTRY TO FILE 433"
- +36 QUIT RCTRANDA
- +37 ;
- +38 ;
- FY433(RCTRANDA) ; transfer fiscal year multiple from 430 to 433
- +1 ; bill number must be stored in file 433, field .03 before calling
- +2 NEW BILLDA,FY,FYDATA
- +3 SET BILLDA=+$PIECE($GET(^PRCA(433,RCTRANDA,0)),"^",2)
- IF 'BILLDA
- QUIT
- +4 KILL ^PRCA(433,RCTRANDA,4)
- +5 SET FY=0
- FOR
- SET FY=$ORDER(^PRCA(430,BILLDA,2,FY))
- if 'FY
- QUIT
- Begin DoDot:1
- +6 SET FYDATA=$GET(^PRCA(430,BILLDA,2,FY,0))
- IF $PIECE(FYDATA,"^")=""
- QUIT
- +7 SET ^PRCA(433,RCTRANDA,4,FY,0)=$PIECE(FYDATA,"^",1,3)_"^1"
- +8 SET ^PRCA(433,RCTRANDA,4,"B",$PIECE(FYDATA,"^"),FY)=""
- End DoDot:1
- +9 ;
- +10 SET ^PRCA(433,RCTRANDA,4,0)="^433.01I^"_$PIECE($GET(^PRCA(430,BILLDA,2,0)),"^",3,4)
- +11 QUIT
- +12 ;
- +13 ;
- FYMULT(RCTRANDA) ; apply payment to fy multiple, oldest first
- +1 NEW AMOUNT,FYDA,FYAMOUNT
- +2 ; transfer fy multiple if not there
- +3 IF '$DATA(^PRCA(433,RCTRANDA,4))
- DO FY433(RCTRANDA)
- +4 ; amount is principal amount
- +5 SET AMOUNT=$PIECE($$TRANVALU^RCDPBTLM(RCTRANDA),"^",2)
- IF 'AMOUNT
- QUIT
- +6 ;
- +7 ; the transaction value is minus, decrease principal
- +8 IF AMOUNT<0
- Begin DoDot:1
- +9 SET AMOUNT=-AMOUNT
- +10 SET FYDA=0
- FOR
- SET FYDA=$ORDER(^PRCA(433,RCTRANDA,4,FYDA))
- if 'FYDA
- QUIT
- Begin DoDot:2
- +11 SET FYAMOUNT=$PIECE($GET(^PRCA(433,RCTRANDA,4,FYDA,0)),"^",2)
- +12 ; fy amount is greater than transaction amount
- +13 IF FYAMOUNT>AMOUNT
- Begin DoDot:3
- +14 SET $PIECE(^PRCA(433,RCTRANDA,4,FYDA,0),"^",2)=FYAMOUNT-AMOUNT
- +15 SET $PIECE(^PRCA(433,RCTRANDA,4,FYDA,0),"^",5)=AMOUNT
- +16 SET AMOUNT=0
- End DoDot:3
- QUIT
- +17 ; fy amount not greater than total amount
- +18 SET $PIECE(^PRCA(433,RCTRANDA,4,FYDA,0),"^",2)=0
- +19 SET $PIECE(^PRCA(433,RCTRANDA,4,FYDA,0),"^",5)=FYAMOUNT
- +20 SET AMOUNT=AMOUNT-FYAMOUNT
- End DoDot:2
- IF 'AMOUNT
- QUIT
- +21 ; move back to 430
- +22 DO FYMULT^RCBEUBIL(RCTRANDA)
- End DoDot:1
- QUIT
- +23 ;
- +24 ; the transaction value is plus, increase principal
- +25 SET FYDA=$ORDER(^PRCA(433,RCTRANDA,4,999),-1)
- IF 'FYDA
- QUIT
- +26 SET $PIECE(^PRCA(433,RCTRANDA,4,FYDA,0),"^",2)=$PIECE(^PRCA(433,RCTRANDA,4,FYDA,0),"^",2)+AMOUNT
- +27 SET $PIECE(^PRCA(433,RCTRANDA,4,FYDA,0),"^",5)=AMOUNT
- +28 ; move back to 430
- +29 DO FYMULT^RCBEUBIL(RCTRANDA)
- +30 QUIT
- +31 ;
- +32 ;
- EDIT433(RCTRANDA,DR) ; edit the field in 433 with the DR string passed
- +1 IF '$DATA(^PRCA(433,RCTRANDA))
- QUIT
- +2 NEW %,D,D0,D1,DA,DDH,DI,DIC,DIE,DQ,J,X,Y
- +3 SET (DIC,DIE)="^PRCA(433,"
- SET DA=RCTRANDA
- +4 DO ^DIE
- +5 ; user pressed up-arrow
- +6 IF $DATA(Y)
- QUIT "0^TRANSACTION NOT COMPLETELY PROCESSED"
- +7 QUIT 1
- +8 ;
- +9 ;
- PROCESS(RCTRANDA) ; mark transaction as processed
- +1 IF '$DATA(^PRCA(433,RCTRANDA,0))
- QUIT
- +2 NEW D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
- +3 SET (DIC,DIE)="^PRCA(433,"
- SET DA=RCTRANDA
- +4 SET DR="3////0;4////2;"
- +5 DO ^DIE
- +6 QUIT
- +7 ;
- +8 ;
- INCOMPLE(RCTRANDA) ; opposite of processed, make a transaction incomplete
- +1 IF '$DATA(^PRCA(433,RCTRANDA,0))
- QUIT
- +2 NEW D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
- +3 SET (DIC,DIE)="^PRCA(433,"
- SET DA=RCTRANDA
- +4 SET DR="4////1;"
- +5 DO ^DIE
- +6 QUIT
- +7 ;
- +8 ;
- DEL433(RCTRANDA,COMMENT,ARCHIVE) ; delete (mark incomplete) in file 433
- +1 ; comment is the user comment in field 41 (default USER CANCELLED)
- +2 ; archive is set to 1 if called to archive transaction
- +3 IF '$DATA(^PRCA(433,RCTRANDA,0))
- QUIT
- +4 NEW %,D,D0,DA,DI,DIC,DIE,DQ,DR,J,RCBILLDA,X,Y
- +5 ;
- +6 SET (DIC,DIE)="^PRCA(433,"
- SET DA=RCTRANDA
- +7 ; build DR string
- +8 SET DR=""
- +9 ;transaction status incomplete
- SET DR=DR_"4////1;"
- +10 ;incomplete transaction flag
- SET DR=DR_"10////1;"
- +11 ;transaction date
- SET DR=DR_"11///T;"
- +12 IF $GET(COMMENT)=""
- SET COMMENT="USER CANCELLED"
- +13 SET DR=DR_"41///"_COMMENT_";"
- +14 ; brief comment
- +15 SET RCBILLDA=$PIECE($GET(^PRCA(433,RCTRANDA,0)),"^",2)
- +16 SET DR=DR_"5.02////SYSTEM "_$SELECT($GET(ARCHIVE):"ARCHIVED",1:"INACTIVATED")_$SELECT(RCBILLDA:" (BILL "_$PIECE($GET(^PRCA(430,RCBILLDA,0)),"^")_")",1:"")_";"
- +17 DO ^DIE
- +18 ; since the bill number (field .03) is required, it must be manually removed
- +19 IF RCBILLDA
- SET $PIECE(^PRCA(433,RCTRANDA,0),"^",2)=""
- KILL ^PRCA(433,"C",RCBILLDA,RCTRANDA)
- +20 ; remove fy multiple
- +21 KILL ^PRCA(433,RCTRANDA,4)
- +22 QUIT
- +23 ;
- +24 ;
- ADDCOMM(RCTRANDA,COMMENT) ; automatically put a comment on a transaction
- +1 ; comment in the array comment(1)=first line
- +2 ; comment(2)=second line
- +3 NEW CURRLINE,LINE
- +4 ; get the last line
- +5 SET CURRLINE=$ORDER(^PRCA(433,RCTRANDA,7,99999999),-1)
- +6 ; if comment already on transaction, add a blank line and
- +7 ; date time of new comment
- +8 IF CURRLINE
- Begin DoDot:1
- +9 SET CURRLINE=CURRLINE+1
- SET ^PRCA(433,RCTRANDA,7,CURRLINE,0)=" "
- +10 SET CURRLINE=CURRLINE+1
- SET ^PRCA(433,RCTRANDA,7,CURRLINE,0)="Comment added on: "_$$FMTE^XLFDT($$NOW^XLFDT)
- End DoDot:1
- +11 ; add new lines
- +12 FOR LINE=1:1
- if '$DATA(COMMENT(LINE))
- QUIT
- SET ^PRCA(433,RCTRANDA,7,CURRLINE+LINE,0)=COMMENT(LINE)
- +13 ; set the 0th node
- +14 SET ^PRCA(433,RCTRANDA,7,0)="^^"_(CURRLINE+LINE-1)_"^"_(CURRLINE+LINE-1)_"^"_DT_"^"
- +15 QUIT
- FMSDATE(X) ;Finds the next month & year and sets the date for transmission
- +1 ;of the document to FMS. If DT is after EOAM and the document has not
- +2 ;been previously transmitted, the date will be set to the first of the
- +3 ;next month. If the DT is after the EOAM and the document is being
- +4 ;re-transmitted, the the date of transmission will be DT. The flag REGEN
- +5 ;is set in the source code if the document is being
- +6 ;re-transmitted, thus will have a transmission date of DT.
- +7 IF $GET(REFMS)
- GOTO QUIT
- +8 IF DT>$$LDATE^RCRJR(DT)
- SET X=$EXTRACT($$FPS^RCAMFN01(X,1),1,5)_"01"
- QUIT QUIT X