VAQPSE03 ;ALB/JRP,JFP - EXPORTED PDX ROUTINE;9-FEB-94
;;1.5;PATIENT DATA EXCHANGE;**1**;NOV 17, 1993
IBAPDX0 ;ALB/CPM - EXTRACT MEANS TEST BILLING DATA FOR PDX (CON'T) ; 05-MAY-93
;;Version 1.5 ; INTEGRATED BILLING ;**15**; 29-JUL-92
;
ENCR ; Set variables for encryption.
;DETERMINE IF ENCRYPTION IS ON - SAVE POINTER TO ENCRYPTION METHOD
S:('TRAN) IBENCPT=$$NCRYPTON^VAQUTL2(1)
S:(TRAN) IBENCPT=$$TRANENC^VAQUTL3(TRAN,2)
;SET UP EXECUTABLE CALL TO ENCRYPT
S:(IBENCPT) IBCRYP=$$ENCMTHD^VAQUTL2(IBENCPT,0)
S:('IBENCPT) IBCRYP=""
S:(IBCRYP'="") IBCRYP=("S IBENC="_IBCRYP)
S:(IBCRYP="") IBCRYP="S IBENC=STRING"
;DETERMINE PRIMARY KEY
I (TRAN) S IBSNDR=$$SENDER^VAQCON2(TRAN) I ($P(IBSNDR,"^",1)="-1") S ERR="-1^Could not determine encryption keys" G ENCRQ
S:(TRAN) IBSNDR=$P(IBSNDR,"^",1)
S:(TRAN) KEY1=$$NAMEKEY^VAQUTL3(IBSNDR,1)
S:('TRAN) KEY1=$$DUZKEY^VAQUTL3($G(DUZ),1)
;DETERMINE SECONDARY KEY
S:(TRAN) KEY2=$$NAMEKEY^VAQUTL3(IBSNDR,0)
S:('TRAN) KEY2=$$DUZKEY^VAQUTL3($G(DUZ),0)
I (IBENCPT) I ((KEY1="")!(KEY2="")) S ERR="-1^Could not determine encryption keys"
ENCRQ Q
;
CHG ; Build the array of Means Test charges.
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
.S IBND=$G(^IB(IBN,0)) Q:'IBND
.S (IBENC,STRING)=+IBND X:$$NCRPFLD^VAQUTL2(350,.01) IBCRYP
.S (IBREF,@ARR@("VALUE",350,.01,IBSEQ))=IBENC,@ARR@("ID",350,.01,IBSEQ)=IBID
.S IBATYP=$P($G(^IBE(350.1,+$P(IBND,"^",3),0)),"^") S:$E(IBATYP,1,2)="DG" IBATYP=$E(IBATYP,4,99)
.S (IBENC,STRING)=IBATYP X:$$NCRPFLD^VAQUTL2(350,.03) IBCRYP
.S @ARR@("VALUE",350,.03,IBSEQ)=IBENC,@ARR@("ID",350,.03,IBSEQ)=IBREF
.S Y=$P(IBND,"^",5),C=$P(^DD(350,.05,0),"^",2) D Y^DIQ
.S (IBENC,STRING)=Y X:$$NCRPFLD^VAQUTL2(350,.05) IBCRYP
.S @ARR@("VALUE",350,.05,IBSEQ)=IBENC,@ARR@("ID",350,.05,IBSEQ)=IBREF
.S (IBENC,STRING)=+$P(IBND,"^",7) X:$$NCRPFLD^VAQUTL2(350,.07) IBCRYP
.S @ARR@("VALUE",350,.07,IBSEQ)=IBENC,@ARR@("ID",350,.07,IBSEQ)=IBREF
.F IBI=14,15 D
..S (IBENC,STRING)=$$DAT1^IBOUTL(+$P(IBND,"^",IBI)) X:$$NCRPFLD^VAQUTL2(350,"."_IBI) IBCRYP
..S @ARR@("VALUE",350,"."_IBI,IBSEQ)=IBENC,@ARR@("ID",350,"."_IBI,IBSEQ)=IBREF
.S IBSEQ=IBSEQ+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQPSE03 2217 printed Dec 13, 2024@02:26:17 Page 2
VAQPSE03 ;ALB/JRP,JFP - EXPORTED PDX ROUTINE;9-FEB-94
+1 ;;1.5;PATIENT DATA EXCHANGE;**1**;NOV 17, 1993
IBAPDX0 ;ALB/CPM - EXTRACT MEANS TEST BILLING DATA FOR PDX (CON'T) ; 05-MAY-93
+1 ;;Version 1.5 ; INTEGRATED BILLING ;**15**; 29-JUL-92
+2 ;
ENCR ; Set variables for encryption.
+1 ;DETERMINE IF ENCRYPTION IS ON - SAVE POINTER TO ENCRYPTION METHOD
+2 if ('TRAN)
SET IBENCPT=$$NCRYPTON^VAQUTL2(1)
+3 if (TRAN)
SET IBENCPT=$$TRANENC^VAQUTL3(TRAN,2)
+4 ;SET UP EXECUTABLE CALL TO ENCRYPT
+5 if (IBENCPT)
SET IBCRYP=$$ENCMTHD^VAQUTL2(IBENCPT,0)
+6 if ('IBENCPT)
SET IBCRYP=""
+7 if (IBCRYP'="")
SET IBCRYP=("S IBENC="_IBCRYP)
+8 if (IBCRYP="")
SET IBCRYP="S IBENC=STRING"
+9 ;DETERMINE PRIMARY KEY
+10 IF (TRAN)
SET IBSNDR=$$SENDER^VAQCON2(TRAN)
IF ($PIECE(IBSNDR,"^",1)="-1")
SET ERR="-1^Could not determine encryption keys"
GOTO ENCRQ
+11 if (TRAN)
SET IBSNDR=$PIECE(IBSNDR,"^",1)
+12 if (TRAN)
SET KEY1=$$NAMEKEY^VAQUTL3(IBSNDR,1)
+13 if ('TRAN)
SET KEY1=$$DUZKEY^VAQUTL3($GET(DUZ),1)
+14 ;DETERMINE SECONDARY KEY
+15 if (TRAN)
SET KEY2=$$NAMEKEY^VAQUTL3(IBSNDR,0)
+16 if ('TRAN)
SET KEY2=$$DUZKEY^VAQUTL3($GET(DUZ),0)
+17 IF (IBENCPT)
IF ((KEY1="")!(KEY2=""))
SET ERR="-1^Could not determine encryption keys"
ENCRQ QUIT
+1 ;
CHG ; Build the array of Means Test charges.
+1 SET (IBD,IBSEQ)=0
FOR
SET IBD=$ORDER(IBARR(IBD))
if 'IBD
QUIT
SET IBN=0
FOR
SET IBN=$ORDER(IBARR(IBD,IBN))
if 'IBN
QUIT
Begin DoDot:1
+2 SET IBND=$GET(^IB(IBN,0))
if 'IBND
QUIT
+3 SET (IBENC,STRING)=+IBND
if $$NCRPFLD^VAQUTL2(350,.01)
XECUTE IBCRYP
+4 SET (IBREF,@ARR@("VALUE",350,.01,IBSEQ))=IBENC
SET @ARR@("ID",350,.01,IBSEQ)=IBID
+5 SET IBATYP=$PIECE($GET(^IBE(350.1,+$PIECE(IBND,"^",3),0)),"^")
if $EXTRACT(IBATYP,1,2)="DG"
SET IBATYP=$EXTRACT(IBATYP,4,99)
+6 SET (IBENC,STRING)=IBATYP
if $$NCRPFLD^VAQUTL2(350,.03)
XECUTE IBCRYP
+7 SET @ARR@("VALUE",350,.03,IBSEQ)=IBENC
SET @ARR@("ID",350,.03,IBSEQ)=IBREF
+8 SET Y=$PIECE(IBND,"^",5)
SET C=$PIECE(^DD(350,.05,0),"^",2)
DO Y^DIQ
+9 SET (IBENC,STRING)=Y
if $$NCRPFLD^VAQUTL2(350,.05)
XECUTE IBCRYP
+10 SET @ARR@("VALUE",350,.05,IBSEQ)=IBENC
SET @ARR@("ID",350,.05,IBSEQ)=IBREF
+11 SET (IBENC,STRING)=+$PIECE(IBND,"^",7)
if $$NCRPFLD^VAQUTL2(350,.07)
XECUTE IBCRYP
+12 SET @ARR@("VALUE",350,.07,IBSEQ)=IBENC
SET @ARR@("ID",350,.07,IBSEQ)=IBREF
+13 FOR IBI=14,15
Begin DoDot:2
+14 SET (IBENC,STRING)=$$DAT1^IBOUTL(+$PIECE(IBND,"^",IBI))
if $$NCRPFLD^VAQUTL2(350,"."_IBI)
XECUTE IBCRYP
+15 SET @ARR@("VALUE",350,"."_IBI,IBSEQ)=IBENC
SET @ARR@("ID",350,"."_IBI,IBSEQ)=IBREF
End DoDot:2
+16 SET IBSEQ=IBSEQ+1
End DoDot:1
+17 QUIT
