| 1 | IBAPDX0 ;ALB/CPM - EXTRACT MEANS TEST BILLING DATA FOR PDX (CON'T) ; 05-MAY-93
|
|---|
| 2 | ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ENCR ; Set variables for encryption.
|
|---|
| 6 | ;DETERMINE IF ENCRYPTION IS ON - SAVE POINTER TO ENCRYPTION METHOD
|
|---|
| 7 | S:('TRAN) IBENCPT=$$NCRYPTON^VAQUTL2(1)
|
|---|
| 8 | S:(TRAN) IBENCPT=$$TRANENC^VAQUTL3(TRAN,2)
|
|---|
| 9 | ;SET UP EXECUTABLE CALL TO ENCRYPT
|
|---|
| 10 | S:(IBENCPT) IBCRYP=$$ENCMTHD^VAQUTL2(IBENCPT,0)
|
|---|
| 11 | S:('IBENCPT) IBCRYP=""
|
|---|
| 12 | S:(IBCRYP'="") IBCRYP=("S IBENC="_IBCRYP)
|
|---|
| 13 | S:(IBCRYP="") IBCRYP="S IBENC=STRING"
|
|---|
| 14 | ;DETERMINE PRIMARY KEY
|
|---|
| 15 | I (TRAN) S IBSNDR=$$SENDER^VAQCON2(TRAN) I ($P(IBSNDR,"^",1)="-1") S ERR="-1^Could not determine encryption keys" G ENCRQ
|
|---|
| 16 | S:(TRAN) IBSNDR=$P(IBSNDR,"^",1)
|
|---|
| 17 | S:(TRAN) KEY1=$$NAMEKEY^VAQUTL3(IBSNDR,1)
|
|---|
| 18 | S:('TRAN) KEY1=$$DUZKEY^VAQUTL3($G(DUZ),1)
|
|---|
| 19 | ;DETERMINE SECONDARY KEY
|
|---|
| 20 | S:(TRAN) KEY2=$$NAMEKEY^VAQUTL3(IBSNDR,0)
|
|---|
| 21 | S:('TRAN) KEY2=$$DUZKEY^VAQUTL3($G(DUZ),0)
|
|---|
| 22 | I (IBENCPT) I ((KEY1="")!(KEY2="")) S ERR="-1^Could not determine encryption keys"
|
|---|
| 23 | ENCRQ Q
|
|---|
| 24 | ;
|
|---|
| 25 | CHG ; Build the array of Means Test charges.
|
|---|
| 26 | 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
|
|---|
| 27 | .S IBND=$G(^IB(IBN,0)) Q:'IBND
|
|---|
| 28 | .S (IBENC,STRING)=+IBND X:$$NCRPFLD^VAQUTL2(350,.01) IBCRYP
|
|---|
| 29 | .S (IBREF,@ARR@("VALUE",350,.01,IBSEQ))=IBENC,@ARR@("ID",350,.01,IBSEQ)=IBID
|
|---|
| 30 | .S IBATYP=$P($G(^IBE(350.1,+$P(IBND,"^",3),0)),"^") S:$E(IBATYP,1,2)="DG" IBATYP=$E(IBATYP,4,99)
|
|---|
| 31 | .S (IBENC,STRING)=IBATYP X:$$NCRPFLD^VAQUTL2(350,.03) IBCRYP
|
|---|
| 32 | .S @ARR@("VALUE",350,.03,IBSEQ)=IBENC,@ARR@("ID",350,.03,IBSEQ)=IBREF
|
|---|
| 33 | .S Y=$P(IBND,"^",5),C=$P(^DD(350,.05,0),"^",2) D Y^DIQ
|
|---|
| 34 | .S (IBENC,STRING)=Y X:$$NCRPFLD^VAQUTL2(350,.05) IBCRYP
|
|---|
| 35 | .S @ARR@("VALUE",350,.05,IBSEQ)=IBENC,@ARR@("ID",350,.05,IBSEQ)=IBREF
|
|---|
| 36 | .S (IBENC,STRING)=+$P(IBND,"^",7) X:$$NCRPFLD^VAQUTL2(350,.07) IBCRYP
|
|---|
| 37 | .S @ARR@("VALUE",350,.07,IBSEQ)=IBENC,@ARR@("ID",350,.07,IBSEQ)=IBREF
|
|---|
| 38 | .F IBI=14,15 D
|
|---|
| 39 | ..S (IBENC,STRING)=$$DAT1^IBOUTL(+$P(IBND,"^",IBI)) X:$$NCRPFLD^VAQUTL2(350,"."_IBI) IBCRYP
|
|---|
| 40 | ..S @ARR@("VALUE",350,"."_IBI,IBSEQ)=IBENC,@ARR@("ID",350,"."_IBI,IBSEQ)=IBREF
|
|---|
| 41 | .S IBSEQ=IBSEQ+1
|
|---|
| 42 | Q
|
|---|
