IBAPDX ;ALB/CPM - EXTRACT MEANS TEST BILLING DATA FOR PDX ; 09-APR-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EXTR(TRAN,DFN,ARR) ; PDX Entry Point for the data extraction.
; Input: TRAN -- Pointer to transaction in file #394.61
; DFN -- Pointer to the patient in file #2
; ARR -- Root for the output extract array
; Output: 0 -- Extraction was successful, or
; -1^err -- if an error was encountered during the extract.
;
; NOTES : If TRAN is passed
; The patient pointer of the transaction will be used
; Encryption will be based on the transaction
; If DFN is passed
; Encryption will be based on the site parameter
; : Pointer to transaction takes presidence over DFN ... if
; TRAN>0 the DFN will be based on the transaction
;
S TRAN=+$G(TRAN)
S DFN=+$G(DFN)
Q:(('TRAN)&('DFN)) "-1^Did not pass pointer to transaction or patient"
I (TRAN) Q:('$D(^VAT(394.61,TRAN))) "-1^Did not pass valid pointer to VAQ - TRANSACTION file"
I (TRAN) S DFN=+$P($G(^VAT(394.61,TRAN,0)),"^",3) Q:('DFN) "-1^Transaction did not contain pointer to PATIENT file"
Q:('$D(^DPT(DFN))) "-1^Did not pass valid pointer to PATIENT file"
;
N C,ERR,KEY1,KEY2,IBARR,IBATYP,IBCRYP,IBD,IBDF,IBEFDT,IBENC,IBI,IBID,IBN,IBND,IBREF,IBSEQ,STRING,Y,IBENCPT,IBSNDR,IBSTR S ERR=0
I $G(ARR)="" S ERR="-1^Did not pass root for the output array." G EXTRQ
;
; - set variables for encryption
D ENCR^IBAPDX0 G:ERR<0 EXTRQ
;
; - get Continuous Patient data
S IBSTR=$G(^IBE(351.1,+$O(^IBE(351.1,"B",DFN,0)),0)) I 'IBSTR S @ARR@("VALUE",351.1,.01,0)="",@ARR@("ID",351.1,.01,0)="" G CLOCK
S (IBENC,STRING)=$P($$PT^IBEFUNC(+IBSTR),"^") X:$$NCRPFLD^VAQUTL2(2,.01) IBCRYP
S (IBID,@ARR@("VALUE",351.1,.01,0),@ARR@("ID",351.1,.01,0))=IBENC
S (IBENC,STRING)=$$DAT1^IBOUTL($P(IBSTR,"^",2)) X:$$NCRPFLD^VAQUTL2(351.1,.02) IBCRYP
S @ARR@("VALUE",351.1,.02,0)=IBENC,@ARR@("ID",351.1,.02,0)=IBID
;
CLOCK ; - get active billing clock data
S IBSTR=$G(^IBE(351,+$O(^IBE(351,"ACT",DFN,0)),0)) I 'IBSTR S @ARR@("VALUE",351,.01,0)="",@ARR@("ID",351,.01,0)="" G EXTRQ
I '$D(IBID) S (IBENC,STRING)=$P($$PT^IBEFUNC(+$P(IBSTR,"^",2)),"^") X:$$NCRPFLD^VAQUTL2(2,.01) IBCRYP S IBID=IBENC
S IBEFDT=$P(IBSTR,"^",3),(IBENC,STRING)=+IBSTR X:$$NCRPFLD^VAQUTL2(351,.01) IBCRYP
S (IBREF,@ARR@("VALUE",351,.01,0))=IBENC,@ARR@("ID",351,.01,0)=IBID
S (IBENC,STRING)=$$DAT1^IBOUTL(IBEFDT) X:$$NCRPFLD^VAQUTL2(351,.03) IBCRYP
S @ARR@("VALUE",351,.03,0)=IBENC,@ARR@("ID",351,.03,0)=IBREF
F IBI=5:1:9 D
.S (IBENC,STRING)=+$P(IBSTR,"^",IBI) X:$$NCRPFLD^VAQUTL2(351,".0"_IBI) IBCRYP
.S @ARR@("VALUE",351,".0"_IBI,0)=IBENC,@ARR@("ID",351,".0"_IBI,0)=IBREF
;
; - get all charges billed within the active clock period
S IBD="" F S IBD=$O(^IB("AFDT",DFN,IBD)) Q:'IBD D
.S IBDF=0 F S IBDF=$O(^IB("AFDT",DFN,IBD,IBDF)) Q:'IBDF D
..S IBN=0 F S IBN=$O(^IB("AF",IBDF,IBN)) Q:'IBN D
...S IBND=$G(^IB(IBN,0)) Q:'IBND
...Q:$P(IBND,"^",8)["ADMISSION"
...I $P(IBND,"^",15)'<IBEFDT S IBARR(+$P(IBND,"^",14),IBN)=""
;
; - set all billed charges into the extract array
I '$D(IBARR) S @ARR@("VALUE",350,.01,0)="",@ARR@("ID",350,.01,0)="" G EXTRQ
D CHG^IBAPDX0
;
EXTRQ Q ERR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAPDX 3362 printed Dec 13, 2024@02:06:51 Page 2
IBAPDX ;ALB/CPM - EXTRACT MEANS TEST BILLING DATA FOR PDX ; 09-APR-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EXTR(TRAN,DFN,ARR) ; PDX Entry Point for the data extraction.
+1 ; Input: TRAN -- Pointer to transaction in file #394.61
+2 ; DFN -- Pointer to the patient in file #2
+3 ; ARR -- Root for the output extract array
+4 ; Output: 0 -- Extraction was successful, or
+5 ; -1^err -- if an error was encountered during the extract.
+6 ;
+7 ; NOTES : If TRAN is passed
+8 ; The patient pointer of the transaction will be used
+9 ; Encryption will be based on the transaction
+10 ; If DFN is passed
+11 ; Encryption will be based on the site parameter
+12 ; : Pointer to transaction takes presidence over DFN ... if
+13 ; TRAN>0 the DFN will be based on the transaction
+14 ;
+15 SET TRAN=+$GET(TRAN)
+16 SET DFN=+$GET(DFN)
+17 if (('TRAN)&('DFN))
QUIT "-1^Did not pass pointer to transaction or patient"
+18 IF (TRAN)
if ('$DATA(^VAT(394.61,TRAN)))
QUIT "-1^Did not pass valid pointer to VAQ - TRANSACTION file"
+19 IF (TRAN)
SET DFN=+$PIECE($GET(^VAT(394.61,TRAN,0)),"^",3)
if ('DFN)
QUIT "-1^Transaction did not contain pointer to PATIENT file"
+20 if ('$DATA(^DPT(DFN)))
QUIT "-1^Did not pass valid pointer to PATIENT file"
+21 ;
+22 NEW C,ERR,KEY1,KEY2,IBARR,IBATYP,IBCRYP,IBD,IBDF,IBEFDT,IBENC,IBI,IBID,IBN,IBND,IBREF,IBSEQ,STRING,Y,IBENCPT,IBSNDR,IBSTR
SET ERR=0
+23 IF $GET(ARR)=""
SET ERR="-1^Did not pass root for the output array."
GOTO EXTRQ
+24 ;
+25 ; - set variables for encryption
+26 DO ENCR^IBAPDX0
if ERR<0
GOTO EXTRQ
+27 ;
+28 ; - get Continuous Patient data
+29 SET IBSTR=$GET(^IBE(351.1,+$ORDER(^IBE(351.1,"B",DFN,0)),0))
IF 'IBSTR
SET @ARR@("VALUE",351.1,.01,0)=""
SET @ARR@("ID",351.1,.01,0)=""
GOTO CLOCK
+30 SET (IBENC,STRING)=$PIECE($$PT^IBEFUNC(+IBSTR),"^")
if $$NCRPFLD^VAQUTL2(2,.01)
XECUTE IBCRYP
+31 SET (IBID,@ARR@("VALUE",351.1,.01,0),@ARR@("ID",351.1,.01,0))=IBENC
+32 SET (IBENC,STRING)=$$DAT1^IBOUTL($PIECE(IBSTR,"^",2))
if $$NCRPFLD^VAQUTL2(351.1,.02)
XECUTE IBCRYP
+33 SET @ARR@("VALUE",351.1,.02,0)=IBENC
SET @ARR@("ID",351.1,.02,0)=IBID
+34 ;
CLOCK ; - get active billing clock data
+1 SET IBSTR=$GET(^IBE(351,+$ORDER(^IBE(351,"ACT",DFN,0)),0))
IF 'IBSTR
SET @ARR@("VALUE",351,.01,0)=""
SET @ARR@("ID",351,.01,0)=""
GOTO EXTRQ
+2 IF '$DATA(IBID)
SET (IBENC,STRING)=$PIECE($$PT^IBEFUNC(+$PIECE(IBSTR,"^",2)),"^")
if $$NCRPFLD^VAQUTL2(2,.01)
XECUTE IBCRYP
SET IBID=IBENC
+3 SET IBEFDT=$PIECE(IBSTR,"^",3)
SET (IBENC,STRING)=+IBSTR
if $$NCRPFLD^VAQUTL2(351,.01)
XECUTE IBCRYP
+4 SET (IBREF,@ARR@("VALUE",351,.01,0))=IBENC
SET @ARR@("ID",351,.01,0)=IBID
+5 SET (IBENC,STRING)=$$DAT1^IBOUTL(IBEFDT)
if $$NCRPFLD^VAQUTL2(351,.03)
XECUTE IBCRYP
+6 SET @ARR@("VALUE",351,.03,0)=IBENC
SET @ARR@("ID",351,.03,0)=IBREF
+7 FOR IBI=5:1:9
Begin DoDot:1
+8 SET (IBENC,STRING)=+$PIECE(IBSTR,"^",IBI)
if $$NCRPFLD^VAQUTL2(351,".0"_IBI)
XECUTE IBCRYP
+9 SET @ARR@("VALUE",351,".0"_IBI,0)=IBENC
SET @ARR@("ID",351,".0"_IBI,0)=IBREF
End DoDot:1
+10 ;
+11 ; - get all charges billed within the active clock period
+12 SET IBD=""
FOR
SET IBD=$ORDER(^IB("AFDT",DFN,IBD))
if 'IBD
QUIT
Begin DoDot:1
+13 SET IBDF=0
FOR
SET IBDF=$ORDER(^IB("AFDT",DFN,IBD,IBDF))
if 'IBDF
QUIT
Begin DoDot:2
+14 SET IBN=0
FOR
SET IBN=$ORDER(^IB("AF",IBDF,IBN))
if 'IBN
QUIT
Begin DoDot:3
+15 SET IBND=$GET(^IB(IBN,0))
if 'IBND
QUIT
+16 if $PIECE(IBND,"^",8)["ADMISSION"
QUIT
+17 IF $PIECE(IBND,"^",15)'<IBEFDT
SET IBARR(+$PIECE(IBND,"^",14),IBN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+18 ;
+19 ; - set all billed charges into the extract array
+20 IF '$DATA(IBARR)
SET @ARR@("VALUE",350,.01,0)=""
SET @ARR@("ID",350,.01,0)=""
GOTO EXTRQ
+21 DO CHG^IBAPDX0
+22 ;
EXTRQ QUIT ERR
