IBAPDX0.m

IBAPDX0	;ALB/CPM - EXTRACT MEANS TEST BILLING DATA FOR PDX (CON'T) ; 05-MAY-93

	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

	;;Per VHA Directive 10-93-142, this routine should not be modified.

	;

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

IBAPDX0   ;ALB/CPM - EXTRACT MEANS TEST BILLING DATA FOR PDX (CON'T) ; 05-MAY-93

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

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