- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAPDX0 2177 printed Apr 23, 2025@18:21:24 Page 2
- 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
