source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVIBF.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 6.8 KB
Line 
1PRCVIBF ;WOIFO/AS-FUND PROCESSING USING DATA FROM DYNAMED ;4/11/05 15:15
2 ;;5.1;IFCAP;**81**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5INIT(NOD) ;
6 ; 1. Find out it is IV or SV
7 ;
8 NEW RTVAL
9 I '$D(^TMP(NOD,$J)) D ERR(1) G EXIT
10PROCESS ;
11 NEW DUZ
12 NEW %,ACCOD,ACT,BATCHID,BOC,CC,DA,PRC,PRCPDA,PRCHQ,PRCPORD,DIC,PRCSCP,RECORD1,RECORD10,RECORD2,RECORD3,RECORD4,T
13 NEW DATIME,DESC,IEN,ITM,ITOT,IVAL,ND,TRNODE,Z,SVAL,STOT
14 NEW PRCVI,PRCVDT,PRCSN,CC2
15 D NOW^%DTC
16 S PRCVDT=DT,DATIME=%,U="^",ND=$G(^TMP(NOD,$J,1)),PRC("SITE")=$P(ND,U)
17 S BATCHID=$P(ND,U,2),Z=$P(ND,U,3),ACT=$P(ND,U,4)
18 D DUZ^XUP($P(ND,U,6)) ;DBIA #4129 DUZ^XUP
19 ; Return PRC("FY"), PRC("QTR") using fileman date X
20 S X=$P(ND,U,5) D FYQ^PRCFSITE
21 S ND=$G(^TMP(NOD,$J,2))
22 S PRC("SCP")=$P(ND,U),PRC("CP")=$P(ND,U,2),CC=$P(ND,U,3),CC2=$P(ND,U,4)
23 S PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
24 I Z="IV",PRC("SCP")="" S PRC("SCP")=4537
25 ; If adjustment...
26 I ACT'="E" D ADJ G EXIT
27 ;
28 ; Issue Book Fund Commitment
29 ; 1. get data from DynaMed by HL7 message
30TRANS ; 2. get new transaction number
31 S X=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("CP")
32 S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_PRC("CP")
33 D EN1^PRCSUT3
34NOD0 ; 3. create file 410, node 0 and 3
35 S PRC("CP")=$P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),"^")
36 D EN2^PRCSUT3
37 ; Failed if --> I '$D(PRCSX1)
38 ;S X=PRCSX1,T1=DA
39 S RTVAL=DA_"^0"
40 ; Transaction type = O:Obligation, A:Adjustment, CA:Cancelled
41 S $P(^PRCS(410,DA,0),"^",2)="O"
42 ; Form Type = 5, Issue Book
43 S $P(^PRCS(410,DA,0),"^",4)=5
44 ;
45NODE2 ; 4. create file 410, node 2
46 S IEN=$O(^PRC(440,"AC","S",0)),ND=$G(^PRC(440,+IEN,0))
47 I IEN D
48 . S ^PRCS(410,DA,2)=$P(ND,"^",1,10)
49 . S $P(^PRCS(410,DA,3),"^",4)=+IEN
50 ;
51 ; 5. Date of request (P1), Priority of Request (ST), Date required (P4)
52 S ^PRCS(410,DA,1)=PRCVDT_"^^ST^"_PRCVDT
53CC ; 6. Cost Center
54 S CC=CC_CC2,CC=$P($G(^PRCD(420.1,CC,0)),"^")
55 S $P(^PRCS(410,DA,3),"^",3)=CC
56 ; 7. Create Items
57ITEM ; FIND UPDATE^DIE USAGE
58 ;
59 S CC=$G(^TMP(NOD,$J,3,0)),(STOT,ITOT)=0
60 F PRCVI=1:1:CC D
61 . S ND=$G(^TMP(NOD,$J,3,PRCVI,0)) Q:ND=""
62 . S ACCOD=$P(ND,U,2),IVAL=$P(ND,U,4),SVAL=$P(ND,U,5)
63 . S BOC=$P(ND,U,3) I BOC S BOC=$E($P($G(^PRCD(420.2,+BOC,0)),U),1,30)
64 . S ITM=999999,DESC=$P($G(^PRC(441,ITM,0)),"^",2)
65 . I DESC="" S DESC="DYNAMED ITEM"
66 . S ACT=$G(^PRCS(410,DA,"IT",0)) I ACT="" S ^(0)="^410.02AI^0^0"
67 . S $P(^PRCS(410,DA,"IT",0),"^",3,4)=PRCVI_"^"_PRCVI
68 . S ^PRCS(410,DA,"IT",PRCVI,0)=PRCVI_"^^^"_BOC_U_ITM_"^^^"_CC
69 . S ^PRCS(410,DA,"IT",PRCVI,1,0)="^^1^1^"_PRCVDT
70 . S ^PRCS(410,DA,"IT",PRCVI,1,1,0)=DESC
71 . ;Node 445 in "IT"
72 . ; how to handle ACCT-BOC (CAME FROM DYNAMED)
73 . S ^PRCS(410,DA,"IT",PRCVI,445)="A"_ACCOD_"-"_$P(ND,U,3)_U_$P(ND,U)_"^^"_IVAL_U_SVAL
74 . S ^PRCS(410,DA,"IT","AB",PRCVI,PRCVI)=""
75 . S ^PRCS(410,DA,"IT","B",PRCVI,PRCVI)=""
76 . S ^PRCS(410,DA,"IT","AG",ITM,PRCVI)=""
77 . S STOT=STOT+SVAL
78 ; End of item loop
79 S $P(^PRCS(410,DA,10),U)=PRCVI
80 ;
81TOT ; TOTAL COST and Date Commited
82 S ^PRCS(410,DA,4)=ITOT_U_PRCVDT_U_STOT_"^^^^^"_STOT
83 ; 5. Get DUZ of requestor and Approving Official, Total Amount
84 S $P(^PRCS(410,DA,7),U)=DUZ
85445 ;
86 S $P(^PRCS(410,DA,445),"^",5)=BATCHID
87COMMIT ;
88 S PRCSN=^PRCS(410,DA,0),PRCHQ=$P(PRCSN,"^",4)
89 ;S (CURQTR,CURQTR1)=PRC("QTR")
90 S $P(^PRCS(410,DA,11),U,3)=1,^PRCS(410,"AQ",1,DA)=""
91 S ^PRCS(410,"F",PRC("SITE")_"-"_+PRC("CP")_"-"_$P($P(^PRCS(410,DA,0),U),"-",5),DA)=""
92 S ^PRCS(410,"F1",$P($P(^PRCS(410,DA,0),U),"-",5)_"-"_PRC("SITE")_"-"_+PRC("CP"),DA)=""
93 ; Copied from FINAL1^PRCSAPP2
94 ; set record in 443, clean up 410, change cp uncommitted balance
95 ; using TRANS^PRCSES, in 420
96 S PRCSCP=$P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),U,12)
97 L +^PRCS(410,DA):15 Q:$T=0
98 S $P(^PRCS(410,DA,10),U,4)=$O(^PRCD(442.3,"C",60,0))
99 I PRCSCP=1!(PRCHQ=1) S $P(^PRCS(410,DA,10),U,4)=$O(^PRCD(442.3,"C",10,0))
100 K ^PRCS(410,"F",+PRCSN_"-"_+PRC("CP")_"-"_$P($P(PRCSN,U),"-",5),DA)
101 K ^PRCS(410,"F1",$P($P(PRCSN,U),"-",5)_"-"_+PRCSN_"-"_+PRC("CP"),DA)
102 K ^PRCS(410,"AQ",1,DA)
103 S $P(^PRCS(410,DA,11),U,3)=""
104 D ERS410^PRC0G(DA_"^A")
105 L -^PRCS(410,DA)
106ESIG ;
107 S MESSAGE=""
108 D ENCODE^PRCSC1(DA,DUZ,.MESSAGE)
109 K MESSAGE
110 S X=STOT D TRANS^PRCSES
111 ; no sub-cp processing (removed the code)
112 I $P(PRCSN,U,4)>1 D
113 . S X=$P(PRCSN,U,1),DIC="^PRC(443,",DIC(0)="L",DLAYGO=443
114 . D ^DIC K DIC,DLAYGO,X
115 . S X=$O(^PRCD(442.3,"C",60,0))
116 . S:PRCSCP=1 X=$O(^PRCD(442.3,"C",10,0))
117 . S $P(^PRC(443,DA,0),U,7)=X,^PRC(443,"AC",X,DA)=""
118 . S $P(^PRC(443,DA,0),U,11)=$P(PRCSN,U,6)
119 ; No sub-cp so no ---> increment due-ins and due-outs
120 ; D EN2^PRCPWI
121 ;
122 S TRNODE(0)=0 D:PRCHQ=1 NODE^PRCS58OB(DA,.TRNODE)
123POSTING ;
124 ; Buyer and Seller's FCP provided by DynaMed
125 ;
126 ;S (PRCPINPT,WHSE)=$O(^PRCP(445,"B",PRC("SITE")_"-WHSE",0))
127 S PRCPDA=DA
128 ; get reference voucher (Obligation) number
129 S PRCPORD=$$IBCNS^PRCPWPU1(PRC("SITE")_"-I"_$E(PRC("FY"),2))
130 I PRCPORD="" D ERR(2) G EXIT
131 S $P(^PRCS(410,PRCPDA,445),U)=PRCPORD
132 S $P(^PRCS(410,PRCPDA,445),U,3,4)=STOT_U_DT
133 S ^PRCS(410,"AS",BATCHID,PRCPDA)=""
134 ;
135FILE ;
136 D IB^PRCS0B(PRC("SITE")_U_PRC("SITE"),PRC("CP")_U_PRC("SCP"),PRCPDA,STOT_U_STOT)
137FINAL ;
138 ; All issue book from DynaMed are FINAL
139 S $P(^PRCS(410,PRCPDA,4),U,4)=DT
140 ; change status
141 S $P(^PRCS(410,PRCPDA,10),U,4)=$O(^PRCD(442.3,"C",40,0))
142 ; Accountable officer and date signed
143 S $P(^PRCS(410,PRCPDA,7),U,11,12)=DUZ_U_DATIME
144 ; remove any worksheet file for 2237
145 N DA,DIC,DIK
146 S DIK="^PRC(443,",DA=PRCPDA D ^DIK
147EXIT ;
148 Q RTVAL
149 ;
150ADJ ;
151 ; Adjustment
152 ; Get IEN from "AS"
153 S DA=$O(^PRCS(410,"AS",BATCHID,0))
154 I 'DA D ERR(3) Q
155 S RTVAL=DA_"^0"
156 ;
157 S CC=$G(^TMP(NOD,$J,3,0)),STOT=0
158 F PRCVI=1:1:CC D
159 . S ND=$G(^TMP(NOD,$J,3,PRCVI,0)) Q:ND=""
160 . S STOT=STOT+$P(ND,U,5)
161 ; Update following code to generate new 410 for Buyer and Seller
162 I 'STOT D ERR(4) G EXIT
163 S CC=$P($G(^PRCS(410,DA,4)),"^",5)_"-ADJ"
164 I STOT D
165 . N A,B,BUY,SAL
166 . S BUY=PRC("SITE")_U_PRC("CP")_U_"A"_"^^"_DT_U_STOT_U_CC
167 . S A=^PRCS(410,DA,0),B=$P($G(^(3)),"^",11)
168 . S A=$P($$QTRDATE^PRC0D($P(A,"-",2),$P(A,"-",3)),"^",7)
169 . S $P(BUY,"^",10,11)=A_"^"_+$$DATE^PRC0C(B,"I"),SAL=BUY
170 . D A410^PRC0F(.PRCPXX,BUY)
171 . S $P(SAL,U,2)=PRC("SCP"),$P(SAL,U,6)=-STOT
172 . D A410^PRC0F(.PRCPXX,SAL)
173 . K PRCPXX
174 Q
175DMITEM ;
176 ; Initiate new item number for DynaMed interface
177 NEW FDA,RESULT
178 S FDA(441,"?+1,",.01)=999999
179 S FDA(441,"?+1,",.05)="ITEM FOR DYNAMED ISSUE BOOK PROCESSING"
180 S FDA(441,"?+1,",2)=9999
181 S FDA(441,"?+1,",12)=2696
182 D UPDATE^DIE("E","FDA","RESULT")
183 S FDA(1)="Item created for use when processing IVSV transaction in support"
184 S FDA(2)="of the DynaMed-IFCAP interface"
185 D WP^DIE(441,"999999,",.1,"KA","FDA")
186 Q
187ERR(N) ;
188 ; if error, send HL7 app ACK of AE
189 S N=$P($T(ERCODE+N),";;",2)
190 S RTVAL="^"_+N_"^"_$P(N,"^",2)
191 Q
192ERCODE ;
193 ;;201^MISSING TMP GLOBAL
194 ;;207^Reference Voucher Number generation failed
195 ;;209^Original Transaction ID not found
196 ;;211^Adjustment amount missing.
197 ;;
Note: See TracBrowser for help on using the repository browser.