source: WorldVistAEHR/trunk/r/PATIENT_DATA_EXCHANGE-VAQ/VAQPSE02.m@ 1336

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

initial load of WorldVistAEHR
File size: 3.3 KB
Line 
1VAQPSE02 ;ALB/JRP,JFP - EXPORTED PDX ROUTINE;9-FEB-94
2 ;;1.5;PATIENT DATA EXCHANGE;**1**;NOV 17, 1993
3IBAPDX ;ALB/CPM - EXTRACT MEANS TEST BILLING DATA FOR PDX ; 09-APR-93
4 ;;Version 1.5 ; INTEGRATED BILLING ;**15**; 29-JUL-92
5 ;
6EXTR(TRAN,DFN,ARR) ; PDX Entry Point for the data extraction.
7 ; Input: TRAN -- Pointer to transaction in file #394.61
8 ; DFN -- Pointer to the patient in file #2
9 ; ARR -- Root for the output extract array
10 ; Output: 0 -- Extraction was successful, or
11 ; -1^err -- if an error was encountered during the extract.
12 ;
13 ; NOTES : If TRAN is passed
14 ; The patient pointer of the transaction will be used
15 ; Encryption will be based on the transaction
16 ; If DFN is passed
17 ; Encryption will be based on the site parameter
18 ; : Pointer to transaction takes precedence over DFN ... if
19 ; TRAN>0 the DFN will be based on the transaction
20 ;
21 S TRAN=+$G(TRAN)
22 S DFN=+$G(DFN)
23 Q:(('TRAN)&('DFN)) "-1^Did not pass pointer to transaction or patient"
24 I (TRAN) Q:('$D(^VAT(394.61,TRAN))) "-1^Did not pass valid pointer to VAQ - TRANSACTION file"
25 I (TRAN) S DFN=+$P($G(^VAT(394.61,TRAN,0)),"^",3) Q:('DFN) "-1^Transaction did not contain pointer to PATIENT file"
26 Q:('$D(^DPT(DFN))) "-1^Did not pass valid pointer to PATIENT file"
27 ;
28 N C,ERR,KEY1,KEY2,IBARR,IBATYP,IBCRYP,IBD,IBDF,IBEFDT,IBENC,IBI,IBID,IBN,IBND,IBREF,IBSEQ,STRING,Y,IBENCPT,IBSNDR,IBSTR S ERR=0
29 I $G(ARR)="" S ERR="-1^Did not pass root for the output array." G EXTRQ
30 ;
31 ; - set variables for encryption
32 D ENCR^IBAPDX0 G:ERR<0 EXTRQ
33 ;
34 ; - get Continuous Patient data
35 S IBSTR=$G(^IBE(351.1,+$O(^IBE(351.1,"B",DFN,0)),0)) I 'IBSTR S @ARR@("VALUE",351.1,.01,0)="",@ARR@("ID",351.1,.01,0)="" G CLOCK
36 S (IBENC,STRING)=$P($$PT^IBEFUNC(+IBSTR),"^") X:$$NCRPFLD^VAQUTL2(2,.01) IBCRYP
37 S (IBID,@ARR@("VALUE",351.1,.01,0),@ARR@("ID",351.1,.01,0))=IBENC
38 S (IBENC,STRING)=$$DAT1^IBOUTL($P(IBSTR,"^",2)) X:$$NCRPFLD^VAQUTL2(351.1,.02) IBCRYP
39 S @ARR@("VALUE",351.1,.02,0)=IBENC,@ARR@("ID",351.1,.02,0)=IBID
40 ;
41CLOCK ; - get active billing clock data
42 S IBSTR=$G(^IBE(351,+$O(^IBE(351,"ACT",DFN,0)),0)) I 'IBSTR S @ARR@("VALUE",351,.01,0)="",@ARR@("ID",351,.01,0)="" G EXTRQ
43 I '$D(IBID) S (IBENC,STRING)=$P($$PT^IBEFUNC(+$P(IBSTR,"^",2)),"^") X:$$NCRPFLD^VAQUTL2(2,.01) IBCRYP S IBID=IBENC
44 S IBEFDT=$P(IBSTR,"^",3),(IBENC,STRING)=+IBSTR X:$$NCRPFLD^VAQUTL2(351,.01) IBCRYP
45 S (IBREF,@ARR@("VALUE",351,.01,0))=IBENC,@ARR@("ID",351,.01,0)=IBID
46 S (IBENC,STRING)=$$DAT1^IBOUTL(IBEFDT) X:$$NCRPFLD^VAQUTL2(351,.03) IBCRYP
47 S @ARR@("VALUE",351,.03,0)=IBENC,@ARR@("ID",351,.03,0)=IBREF
48 F IBI=5:1:9 D
49 .S (IBENC,STRING)=+$P(IBSTR,"^",IBI) X:$$NCRPFLD^VAQUTL2(351,".0"_IBI) IBCRYP
50 .S @ARR@("VALUE",351,".0"_IBI,0)=IBENC,@ARR@("ID",351,".0"_IBI,0)=IBREF
51 ;
52 ; - get all charges billed within the active clock period
53 S IBD="" F S IBD=$O(^IB("AFDT",DFN,IBD)) Q:'IBD D
54 .S IBDF=0 F S IBDF=$O(^IB("AFDT",DFN,IBD,IBDF)) Q:'IBDF D
55 ..S IBN=0 F S IBN=$O(^IB("AF",IBDF,IBN)) Q:'IBN D
56 ...S IBND=$G(^IB(IBN,0)) Q:'IBND
57 ...Q:$P(IBND,"^",8)["ADMISSION"
58 ...I $P(IBND,"^",15)'<IBEFDT S IBARR(+$P(IBND,"^",14),IBN)=""
59 ;
60 ; - set all billed charges into the extract array
61 I '$D(IBARR) S @ARR@("VALUE",350,.01,0)="",@ARR@("ID",350,.01,0)="" G EXTRQ
62 D CHG^IBAPDX0
63 ;
64EXTRQ Q ERR
Note: See TracBrowser for help on using the repository browser.