source: FOIAVistA/trunk/r/PATIENT_DATA_EXCHANGE-VAQ/VAQPSE03.m@ 1535

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

initial load of FOIAVistA 6/30/08 version

File size: 2.1 KB
Line 
1VAQPSE03 ;ALB/JRP,JFP - EXPORTED PDX ROUTINE;9-FEB-94
2 ;;1.5;PATIENT DATA EXCHANGE;**1**;NOV 17, 1993
3IBAPDX0 ;ALB/CPM - EXTRACT MEANS TEST BILLING DATA FOR PDX (CON'T) ; 05-MAY-93
4 ;;Version 1.5 ; INTEGRATED BILLING ;**15**; 29-JUL-92
5 ;
6ENCR ; Set variables for encryption.
7 ;DETERMINE IF ENCRYPTION IS ON - SAVE POINTER TO ENCRYPTION METHOD
8 S:('TRAN) IBENCPT=$$NCRYPTON^VAQUTL2(1)
9 S:(TRAN) IBENCPT=$$TRANENC^VAQUTL3(TRAN,2)
10 ;SET UP EXECUTABLE CALL TO ENCRYPT
11 S:(IBENCPT) IBCRYP=$$ENCMTHD^VAQUTL2(IBENCPT,0)
12 S:('IBENCPT) IBCRYP=""
13 S:(IBCRYP'="") IBCRYP=("S IBENC="_IBCRYP)
14 S:(IBCRYP="") IBCRYP="S IBENC=STRING"
15 ;DETERMINE PRIMARY KEY
16 I (TRAN) S IBSNDR=$$SENDER^VAQCON2(TRAN) I ($P(IBSNDR,"^",1)="-1") S ERR="-1^Could not determine encryption keys" G ENCRQ
17 S:(TRAN) IBSNDR=$P(IBSNDR,"^",1)
18 S:(TRAN) KEY1=$$NAMEKEY^VAQUTL3(IBSNDR,1)
19 S:('TRAN) KEY1=$$DUZKEY^VAQUTL3($G(DUZ),1)
20 ;DETERMINE SECONDARY KEY
21 S:(TRAN) KEY2=$$NAMEKEY^VAQUTL3(IBSNDR,0)
22 S:('TRAN) KEY2=$$DUZKEY^VAQUTL3($G(DUZ),0)
23 I (IBENCPT) I ((KEY1="")!(KEY2="")) S ERR="-1^Could not determine encryption keys"
24ENCRQ Q
25 ;
26CHG ; Build the array of Means Test charges.
27 S (IBD,IBSEQ)=0 F S IBD=$O(IBARR(IBD)) Q:'IBD S IBN=0 F S IBN=$O(IBARR(IBD,IBN)) Q:'IBN D
28 .S IBND=$G(^IB(IBN,0)) Q:'IBND
29 .S (IBENC,STRING)=+IBND X:$$NCRPFLD^VAQUTL2(350,.01) IBCRYP
30 .S (IBREF,@ARR@("VALUE",350,.01,IBSEQ))=IBENC,@ARR@("ID",350,.01,IBSEQ)=IBID
31 .S IBATYP=$P($G(^IBE(350.1,+$P(IBND,"^",3),0)),"^") S:$E(IBATYP,1,2)="DG" IBATYP=$E(IBATYP,4,99)
32 .S (IBENC,STRING)=IBATYP X:$$NCRPFLD^VAQUTL2(350,.03) IBCRYP
33 .S @ARR@("VALUE",350,.03,IBSEQ)=IBENC,@ARR@("ID",350,.03,IBSEQ)=IBREF
34 .S Y=$P(IBND,"^",5),C=$P(^DD(350,.05,0),"^",2) D Y^DIQ
35 .S (IBENC,STRING)=Y X:$$NCRPFLD^VAQUTL2(350,.05) IBCRYP
36 .S @ARR@("VALUE",350,.05,IBSEQ)=IBENC,@ARR@("ID",350,.05,IBSEQ)=IBREF
37 .S (IBENC,STRING)=+$P(IBND,"^",7) X:$$NCRPFLD^VAQUTL2(350,.07) IBCRYP
38 .S @ARR@("VALUE",350,.07,IBSEQ)=IBENC,@ARR@("ID",350,.07,IBSEQ)=IBREF
39 .F IBI=14,15 D
40 ..S (IBENC,STRING)=$$DAT1^IBOUTL(+$P(IBND,"^",IBI)) X:$$NCRPFLD^VAQUTL2(350,"."_IBI) IBCRYP
41 ..S @ARR@("VALUE",350,"."_IBI,IBSEQ)=IBENC,@ARR@("ID",350,"."_IBI,IBSEQ)=IBREF
42 .S IBSEQ=IBSEQ+1
43 Q
Note: See TracBrowser for help on using the repository browser.