198 lines
6.8 KiB
Mathematica
198 lines
6.8 KiB
Mathematica
PRCVIBF ;WOIFO/AS-FUND PROCESSING USING DATA FROM DYNAMED ;4/11/05 15:15
|
|
;;5.1;IFCAP;**81**;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
;
|
|
INIT(NOD) ;
|
|
; 1. Find out it is IV or SV
|
|
;
|
|
NEW RTVAL
|
|
I '$D(^TMP(NOD,$J)) D ERR(1) G EXIT
|
|
PROCESS ;
|
|
NEW DUZ
|
|
NEW %,ACCOD,ACT,BATCHID,BOC,CC,DA,PRC,PRCPDA,PRCHQ,PRCPORD,DIC,PRCSCP,RECORD1,RECORD10,RECORD2,RECORD3,RECORD4,T
|
|
NEW DATIME,DESC,IEN,ITM,ITOT,IVAL,ND,TRNODE,Z,SVAL,STOT
|
|
NEW PRCVI,PRCVDT,PRCSN,CC2
|
|
D NOW^%DTC
|
|
S PRCVDT=DT,DATIME=%,U="^",ND=$G(^TMP(NOD,$J,1)),PRC("SITE")=$P(ND,U)
|
|
S BATCHID=$P(ND,U,2),Z=$P(ND,U,3),ACT=$P(ND,U,4)
|
|
D DUZ^XUP($P(ND,U,6)) ;DBIA #4129 DUZ^XUP
|
|
; Return PRC("FY"), PRC("QTR") using fileman date X
|
|
S X=$P(ND,U,5) D FYQ^PRCFSITE
|
|
S ND=$G(^TMP(NOD,$J,2))
|
|
S PRC("SCP")=$P(ND,U),PRC("CP")=$P(ND,U,2),CC=$P(ND,U,3),CC2=$P(ND,U,4)
|
|
S PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
|
|
I Z="IV",PRC("SCP")="" S PRC("SCP")=4537
|
|
; If adjustment...
|
|
I ACT'="E" D ADJ G EXIT
|
|
;
|
|
; Issue Book Fund Commitment
|
|
; 1. get data from DynaMed by HL7 message
|
|
TRANS ; 2. get new transaction number
|
|
S X=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("CP")
|
|
S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_PRC("CP")
|
|
D EN1^PRCSUT3
|
|
NOD0 ; 3. create file 410, node 0 and 3
|
|
S PRC("CP")=$P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),"^")
|
|
D EN2^PRCSUT3
|
|
; Failed if --> I '$D(PRCSX1)
|
|
;S X=PRCSX1,T1=DA
|
|
S RTVAL=DA_"^0"
|
|
; Transaction type = O:Obligation, A:Adjustment, CA:Cancelled
|
|
S $P(^PRCS(410,DA,0),"^",2)="O"
|
|
; Form Type = 5, Issue Book
|
|
S $P(^PRCS(410,DA,0),"^",4)=5
|
|
;
|
|
NODE2 ; 4. create file 410, node 2
|
|
S IEN=$O(^PRC(440,"AC","S",0)),ND=$G(^PRC(440,+IEN,0))
|
|
I IEN D
|
|
. S ^PRCS(410,DA,2)=$P(ND,"^",1,10)
|
|
. S $P(^PRCS(410,DA,3),"^",4)=+IEN
|
|
;
|
|
; 5. Date of request (P1), Priority of Request (ST), Date required (P4)
|
|
S ^PRCS(410,DA,1)=PRCVDT_"^^ST^"_PRCVDT
|
|
CC ; 6. Cost Center
|
|
S CC=CC_CC2,CC=$P($G(^PRCD(420.1,CC,0)),"^")
|
|
S $P(^PRCS(410,DA,3),"^",3)=CC
|
|
; 7. Create Items
|
|
ITEM ; FIND UPDATE^DIE USAGE
|
|
;
|
|
S CC=$G(^TMP(NOD,$J,3,0)),(STOT,ITOT)=0
|
|
F PRCVI=1:1:CC D
|
|
. S ND=$G(^TMP(NOD,$J,3,PRCVI,0)) Q:ND=""
|
|
. S ACCOD=$P(ND,U,2),IVAL=$P(ND,U,4),SVAL=$P(ND,U,5)
|
|
. S BOC=$P(ND,U,3) I BOC S BOC=$E($P($G(^PRCD(420.2,+BOC,0)),U),1,30)
|
|
. S ITM=999999,DESC=$P($G(^PRC(441,ITM,0)),"^",2)
|
|
. I DESC="" S DESC="DYNAMED ITEM"
|
|
. S ACT=$G(^PRCS(410,DA,"IT",0)) I ACT="" S ^(0)="^410.02AI^0^0"
|
|
. S $P(^PRCS(410,DA,"IT",0),"^",3,4)=PRCVI_"^"_PRCVI
|
|
. S ^PRCS(410,DA,"IT",PRCVI,0)=PRCVI_"^^^"_BOC_U_ITM_"^^^"_CC
|
|
. S ^PRCS(410,DA,"IT",PRCVI,1,0)="^^1^1^"_PRCVDT
|
|
. S ^PRCS(410,DA,"IT",PRCVI,1,1,0)=DESC
|
|
. ;Node 445 in "IT"
|
|
. ; how to handle ACCT-BOC (CAME FROM DYNAMED)
|
|
. S ^PRCS(410,DA,"IT",PRCVI,445)="A"_ACCOD_"-"_$P(ND,U,3)_U_$P(ND,U)_"^^"_IVAL_U_SVAL
|
|
. S ^PRCS(410,DA,"IT","AB",PRCVI,PRCVI)=""
|
|
. S ^PRCS(410,DA,"IT","B",PRCVI,PRCVI)=""
|
|
. S ^PRCS(410,DA,"IT","AG",ITM,PRCVI)=""
|
|
. S STOT=STOT+SVAL
|
|
; End of item loop
|
|
S $P(^PRCS(410,DA,10),U)=PRCVI
|
|
;
|
|
TOT ; TOTAL COST and Date Commited
|
|
S ^PRCS(410,DA,4)=ITOT_U_PRCVDT_U_STOT_"^^^^^"_STOT
|
|
; 5. Get DUZ of requestor and Approving Official, Total Amount
|
|
S $P(^PRCS(410,DA,7),U)=DUZ
|
|
445 ;
|
|
S $P(^PRCS(410,DA,445),"^",5)=BATCHID
|
|
COMMIT ;
|
|
S PRCSN=^PRCS(410,DA,0),PRCHQ=$P(PRCSN,"^",4)
|
|
;S (CURQTR,CURQTR1)=PRC("QTR")
|
|
S $P(^PRCS(410,DA,11),U,3)=1,^PRCS(410,"AQ",1,DA)=""
|
|
S ^PRCS(410,"F",PRC("SITE")_"-"_+PRC("CP")_"-"_$P($P(^PRCS(410,DA,0),U),"-",5),DA)=""
|
|
S ^PRCS(410,"F1",$P($P(^PRCS(410,DA,0),U),"-",5)_"-"_PRC("SITE")_"-"_+PRC("CP"),DA)=""
|
|
; Copied from FINAL1^PRCSAPP2
|
|
; set record in 443, clean up 410, change cp uncommitted balance
|
|
; using TRANS^PRCSES, in 420
|
|
S PRCSCP=$P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),U,12)
|
|
L +^PRCS(410,DA):15 Q:$T=0
|
|
S $P(^PRCS(410,DA,10),U,4)=$O(^PRCD(442.3,"C",60,0))
|
|
I PRCSCP=1!(PRCHQ=1) S $P(^PRCS(410,DA,10),U,4)=$O(^PRCD(442.3,"C",10,0))
|
|
K ^PRCS(410,"F",+PRCSN_"-"_+PRC("CP")_"-"_$P($P(PRCSN,U),"-",5),DA)
|
|
K ^PRCS(410,"F1",$P($P(PRCSN,U),"-",5)_"-"_+PRCSN_"-"_+PRC("CP"),DA)
|
|
K ^PRCS(410,"AQ",1,DA)
|
|
S $P(^PRCS(410,DA,11),U,3)=""
|
|
D ERS410^PRC0G(DA_"^A")
|
|
L -^PRCS(410,DA)
|
|
ESIG ;
|
|
S MESSAGE=""
|
|
D ENCODE^PRCSC1(DA,DUZ,.MESSAGE)
|
|
K MESSAGE
|
|
S X=STOT D TRANS^PRCSES
|
|
; no sub-cp processing (removed the code)
|
|
I $P(PRCSN,U,4)>1 D
|
|
. S X=$P(PRCSN,U,1),DIC="^PRC(443,",DIC(0)="L",DLAYGO=443
|
|
. D ^DIC K DIC,DLAYGO,X
|
|
. S X=$O(^PRCD(442.3,"C",60,0))
|
|
. S:PRCSCP=1 X=$O(^PRCD(442.3,"C",10,0))
|
|
. S $P(^PRC(443,DA,0),U,7)=X,^PRC(443,"AC",X,DA)=""
|
|
. S $P(^PRC(443,DA,0),U,11)=$P(PRCSN,U,6)
|
|
; No sub-cp so no ---> increment due-ins and due-outs
|
|
; D EN2^PRCPWI
|
|
;
|
|
S TRNODE(0)=0 D:PRCHQ=1 NODE^PRCS58OB(DA,.TRNODE)
|
|
POSTING ;
|
|
; Buyer and Seller's FCP provided by DynaMed
|
|
;
|
|
;S (PRCPINPT,WHSE)=$O(^PRCP(445,"B",PRC("SITE")_"-WHSE",0))
|
|
S PRCPDA=DA
|
|
; get reference voucher (Obligation) number
|
|
S PRCPORD=$$IBCNS^PRCPWPU1(PRC("SITE")_"-I"_$E(PRC("FY"),2))
|
|
I PRCPORD="" D ERR(2) G EXIT
|
|
S $P(^PRCS(410,PRCPDA,445),U)=PRCPORD
|
|
S $P(^PRCS(410,PRCPDA,445),U,3,4)=STOT_U_DT
|
|
S ^PRCS(410,"AS",BATCHID,PRCPDA)=""
|
|
;
|
|
FILE ;
|
|
D IB^PRCS0B(PRC("SITE")_U_PRC("SITE"),PRC("CP")_U_PRC("SCP"),PRCPDA,STOT_U_STOT)
|
|
FINAL ;
|
|
; All issue book from DynaMed are FINAL
|
|
S $P(^PRCS(410,PRCPDA,4),U,4)=DT
|
|
; change status
|
|
S $P(^PRCS(410,PRCPDA,10),U,4)=$O(^PRCD(442.3,"C",40,0))
|
|
; Accountable officer and date signed
|
|
S $P(^PRCS(410,PRCPDA,7),U,11,12)=DUZ_U_DATIME
|
|
; remove any worksheet file for 2237
|
|
N DA,DIC,DIK
|
|
S DIK="^PRC(443,",DA=PRCPDA D ^DIK
|
|
EXIT ;
|
|
Q RTVAL
|
|
;
|
|
ADJ ;
|
|
; Adjustment
|
|
; Get IEN from "AS"
|
|
S DA=$O(^PRCS(410,"AS",BATCHID,0))
|
|
I 'DA D ERR(3) Q
|
|
S RTVAL=DA_"^0"
|
|
;
|
|
S CC=$G(^TMP(NOD,$J,3,0)),STOT=0
|
|
F PRCVI=1:1:CC D
|
|
. S ND=$G(^TMP(NOD,$J,3,PRCVI,0)) Q:ND=""
|
|
. S STOT=STOT+$P(ND,U,5)
|
|
; Update following code to generate new 410 for Buyer and Seller
|
|
I 'STOT D ERR(4) G EXIT
|
|
S CC=$P($G(^PRCS(410,DA,4)),"^",5)_"-ADJ"
|
|
I STOT D
|
|
. N A,B,BUY,SAL
|
|
. S BUY=PRC("SITE")_U_PRC("CP")_U_"A"_"^^"_DT_U_STOT_U_CC
|
|
. S A=^PRCS(410,DA,0),B=$P($G(^(3)),"^",11)
|
|
. S A=$P($$QTRDATE^PRC0D($P(A,"-",2),$P(A,"-",3)),"^",7)
|
|
. S $P(BUY,"^",10,11)=A_"^"_+$$DATE^PRC0C(B,"I"),SAL=BUY
|
|
. D A410^PRC0F(.PRCPXX,BUY)
|
|
. S $P(SAL,U,2)=PRC("SCP"),$P(SAL,U,6)=-STOT
|
|
. D A410^PRC0F(.PRCPXX,SAL)
|
|
. K PRCPXX
|
|
Q
|
|
DMITEM ;
|
|
; Initiate new item number for DynaMed interface
|
|
NEW FDA,RESULT
|
|
S FDA(441,"?+1,",.01)=999999
|
|
S FDA(441,"?+1,",.05)="ITEM FOR DYNAMED ISSUE BOOK PROCESSING"
|
|
S FDA(441,"?+1,",2)=9999
|
|
S FDA(441,"?+1,",12)=2696
|
|
D UPDATE^DIE("E","FDA","RESULT")
|
|
S FDA(1)="Item created for use when processing IVSV transaction in support"
|
|
S FDA(2)="of the DynaMed-IFCAP interface"
|
|
D WP^DIE(441,"999999,",.1,"KA","FDA")
|
|
Q
|
|
ERR(N) ;
|
|
; if error, send HL7 app ACK of AE
|
|
S N=$P($T(ERCODE+N),";;",2)
|
|
S RTVAL="^"_+N_"^"_$P(N,"^",2)
|
|
Q
|
|
ERCODE ;
|
|
;;201^MISSING TMP GLOBAL
|
|
;;207^Reference Voucher Number generation failed
|
|
;;209^Original Transaction ID not found
|
|
;;211^Adjustment amount missing.
|
|
;;
|