- 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 Mar 13, 2025@21:11:40 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
