IBCEFG0 ;ALB/TMP - FORMS GENERATOR EXTRACT (CONT) ;17-JAN-96
;;2.0;INTEGRATED BILLING;**52,51**;21-MAR-94
;
ELE(IBXDA,IBXPARM,IBXFORM) ; Find element to extract for form fld
N IBX
I $G(IBXPARM(1))="BILL-SEARCH" D I $G(IBX)>0 G ELEQ ;Custom - bill extract
.S IBX=$$EDIBILL^IBCEFG1(+$G(IBXFORM),IBXDA,$G(IBXPARM(2)),$G(IBXPARM(3)))
S IBX=+$O(^IBA(364.7,"B",IBXDA,""))
I 'IBX,$G(IBXFORM),$O(^IBA(364.6,"APAR",IBXFORM,IBXDA,"")) S IBX=+$O(^("")),IBX=+$O(^IBA(364.7,"B",IBX,0)) I IBX G ELEQ
ELEQ Q IBX
;
DATA(IBXELE,IBX00,IBXFILE,IBXIEN,IBXARRAY,IBXERR) ; Find data assoc with form fld def
N IBXPG,IBXCOL,IBXLN,IBXDA,IBXFF
I $P(IBX00,U,3)="C" S IBXDATA=$P(IBX00,U,8) G DATAQ
I $P(IBX00,U,3)="E",$G(^IBA(364.5,IBXELE,1))'="" X ^(1) G DATAQ
I $P(IBX00,U,3)="F" D
.I $P(IBX00,U,6)[":" I $$GET1^DIQ(IBXFILE,IBXIEN_",",$P($P(IBX00,U,6),":"))="" S IBXDATA="" Q
.S IBXDATA=$$GET1^DIQ(IBXFILE,IBXIEN_",",$P(IBX00,U,6),$S("I"[$P(IBX00,U,7):"I",1:""),IBXARRAY)
.I $D(^TMP("DIERR",$J,1)) S IBXERR="FILEMAN FIELD: "_$P(IBX00,U)_" "_^(1,"TEXT",1)
DATAQ Q $G(IBXDATA)
;
DUP(DA,X,CK) ; Duplicate check on form field definitions
;Returns 1 if a duplicate of this form page/line/column is found
N PG,LN,COL,ND,FORM,DUP,Z
S DUP=0
G:$G(DA)="" DUPQ
S ND=$G(^IBA(364.6,DA,0))
S FORM=$S($G(CK)=1:X,1:$P(ND,U)),PG=$S($G(CK)=2:X,1:$P(ND,U,4)),LN=$S($G(CK)=3:X,1:$P(ND,U,5)),COL=$S($G(CK)=4:X,1:$P(ND,U,8))
;
I FORM'="",PG'="",LN'="",COL'="" D
.S Z=$O(^IBA(364.6,"ASEQ",FORM,PG,LN,COL,""))
.Q:$S(Z="":1,1:Z=DA&($O(^IBA(364.6,"ASEQ",FORM,PG,LN,COL,""),-1)=DA))
.S DUP=1
;
DUPQ Q DUP
;
BILLPARM(IBXIEN,IBXPARM) ; Sets up parameters for extracting bill data
;IBXIEN = internal entry # of the entry to be extracted
;IBXPARM = array that the parameters are set into. Pass by reference
; (2)=insurance co int entry #, (3)=bill type (I/O)
N IB0,IBCBH
S IB0=$G(^DGCR(399,IBXIEN,0)),IBCBH=$P(IB0,U,21) S:"PST"'[IBCBH!(IBCBH="") IBCBH="P"
S IBXPARM(1)="BILL-SEARCH",IBXPARM(2)=$P($G(^DGCR(399,IBXIEN,"I"_($F("PST",IBCBH)-1))),U),IBXPARM(3)=$S($P(IB0,U,5)<3:"I",1:"O")
Q
;
PARTEXT(FORMAT,PG,LN,IBXIEN,IBXFORM,IBXPARM,IBXERR) ; Extract part of a printed form
;FORMAT = flag used to say whether you want (1) formatted (by line)
; or (0) unformatted (by pg/line/col) returned
;PG = page to start/end in 2 '^' pieces (start page^end page)
;LN = line to start/end in 2 '^' pieces (start line^end line)
; the start value of the preceeding 2 parameters are required
; if no end value, start value is assumed to be end value, too
;IBXIEN = the entry # of the record to be extracted
;IBXFORM = ien of the local or parent form in file 353 to be extracted
;IBXPARM = passed by reference. Extract parameters.
;IBXERR = passed by reference. If an error condition is found, this is
; the text of the error.
;
;Returns ^TMP("IBXDISP",$J,PG,LN)=print line(s) if FORMAT=1
;Returns ^TMP("IBXDISP",$J,1,PG,LN,COL)=data at PG/LN/COL if +FORMAT=0
;
;we may later add an automatic data element dependency logic where
; we can flag a data element as needing another d.e. extracted first
; and we execute the other logic automatically if not already done.
;
N IBXDA,IBXPG,IBXLN,IBXCOL,IBXF,IBX2,IBXREC,IBXFILE,Z
K ^TMP("IBXDATA",$J),^TMP("DIERR",$J),^TMP("IBXEDIT",$J),^TMP("IBXDISP",$J)
S IBX2=$G(^IBE(353,+$G(IBXFORM),2))
I $P(IBX2,U,2)'="P" S IBXERR="NOT A PRINTABLE FORM!!" Q
I '$D(^DGCR(399,IBXIEN,0)) S IBXERR="BILL DOES NOT EXIST" Q
S:$P(PG,U,2)="" $P(PG,U,2)=$P(PG,U) S:$P(LN,U,2)="" $P(LN,U,2)=$P(LN,U)
S IBXF=$S($P(IBX2,U,5):$P(IBX2,U,5),1:IBXFORM)
S IBXPG=$O(^IBA(364.6,"ASEQ",IBXF,$P(PG,U)),-1)
F S IBXPG=$O(^IBA(364.6,"ASEQ",IBXF,IBXPG)) Q:IBXPG=""!(IBXPG]$P(PG,U,2)) D
.S IBXLN=$O(^IBA(364.6,"ASEQ",IBXF,IBXPG,$P(LN,U)),-1) F S IBXLN=$O(^IBA(364.6,"ASEQ",IBXF,IBXPG,IBXLN)) Q:IBXLN=""!(IBXLN]$P(LN,U,2)) D G:$G(IBXERR)'="" PTQ
..S IBXCOL="" F S IBXCOL=$O(^IBA(364.6,"ASEQ",IBXF,IBXPG,IBXLN,IBXCOL)) Q:IBXCOL="" D Q:$G(IBXERR)'=""
...S IBXDA=$O(^IBA(364.6,"ASEQ",IBXF,IBXPG,IBXLN,IBXCOL,""))
...Q:'IBXDA
...D DATA^IBCEFG(IBXPG,IBXLN,IBXCOL,IBXIEN,IBXFORM,IBXDA,.IBXPARM,.IBXERR)
S IBXPG="" F S IBXPG=$O(^TMP("IBXDATA",$J,1,IBXPG)) Q:IBXPG=""!(IBXPG>$P(PG,U,2)) F IBXLN=+LN:1:$P(LN,U,2) S:$G(FORMAT) ^TMP("IBXDISP",$J,IBXPG,IBXLN)="" D
.Q:'$D(^TMP("IBXDATA",$J,1,IBXPG,IBXLN))
.S IBXCOL="" F S IBXCOL=$O(^TMP("IBXDATA",$J,1,IBXPG,IBXLN,IBXCOL)) Q:IBXCOL="" S Z=$G(^(IBXCOL)) I Z'="" D
..I $G(FORMAT) S $E(^TMP("IBXDISP",$J,IBXPG,IBXLN),IBXCOL,IBXCOL+$L(Z)-1)=Z Q
..I '$G(FORMAT) S ^TMP("IBXDISP",$J,IBXPG,IBXLN,IBXCOL)=Z
;
PTQ K ^TMP("IBXDATA",$J),^TMP("DIERR",$J)
Q
;
BILLN(FORMAT,PG,LN,IBXIEN,IBXFORM) ; Call to extract the contents of lines on a bill
; See PARTEXT for parameters
; RETURNS null if extract OK, OR error text if not
N IBXPARM,IBXERR,IBXDATA,IBXSIZE
K ^TMP("IBXSAVE",$J)
D BILLPARM(IBXIEN,.IBXPARM)
D PARTEXT(FORMAT,PG,LN,IBXIEN,IBXFORM,.IBXPARM,.IBXERR)
K ^TMP("IBXSAVE",$J)
Q $G(IBXERR)
;
EXTONE(IBXIEN,IBXELE,IBX,IBXERR) ;
; Extract unformatted data element(s) for record in file whose entry
; is IBXIEN
; IBXELE(1-n) = array passed by reference and containing the data
; element ien's from file 364.5 to return
; IBX = name of array to be returned containing the data requested.
; For individual-valued elements, IBX(1-n) will
; contain the data element values.
; For group elements, IBX(1-n,1-z) will contain the
; values of the data element's 1-z occurrences.
;
; IBXERR = if an error, the error message will be returned here
;
N IBX00,IBXQ,IBXDATA,IBXFILE,IBXXD,Z0,Z1
K @IBX
S IBXQ="" F S IBXQ=$O(IBXELE(IBXQ)) Q:'IBXQ D
.S IBX00=$G(^IBA(364.5,+IBXELE(IBXQ),0)),IBXFILE=+$P(IBX00,U,5),IBXARRAY=$P($G(^IBA(364.5,+IBXELE(IBXQ),2)),U) S:IBXARRAY="" IBXARRAY="IBXDATA"
.Q:'IBXFILE
.K IBXXD
.S IBXXD=$$DATA(IBXELE(IBXQ),IBX00,IBXFILE,IBXIEN,IBXARRAY,.IBXERR)
.I $D(@IBXARRAY)=1 S (@IBX,@IBX@(IBXQ))=@IBXARRAY Q
.S Z0="",Z1=0 F S Z0=$O(@IBXARRAY@(Z0)) Q:'Z0 S Z1=Z1+1 M @IBX@(IBXQ,Z1)=@IBXARRAY@(Z0)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEFG0 6181 printed Dec 13, 2024@02:10:27 Page 2
IBCEFG0 ;ALB/TMP - FORMS GENERATOR EXTRACT (CONT) ;17-JAN-96
+1 ;;2.0;INTEGRATED BILLING;**52,51**;21-MAR-94
+2 ;
ELE(IBXDA,IBXPARM,IBXFORM) ; Find element to extract for form fld
+1 NEW IBX
+2 ;Custom - bill extract
IF $GET(IBXPARM(1))="BILL-SEARCH"
Begin DoDot:1
+3 SET IBX=$$EDIBILL^IBCEFG1(+$GET(IBXFORM),IBXDA,$GET(IBXPARM(2)),$GET(IBXPARM(3)))
End DoDot:1
IF $GET(IBX)>0
GOTO ELEQ
+4 SET IBX=+$ORDER(^IBA(364.7,"B",IBXDA,""))
+5 IF 'IBX
IF $GET(IBXFORM)
IF $ORDER(^IBA(364.6,"APAR",IBXFORM,IBXDA,""))
SET IBX=+$ORDER(^(""))
SET IBX=+$ORDER(^IBA(364.7,"B",IBX,0))
IF IBX
GOTO ELEQ
ELEQ QUIT IBX
+1 ;
DATA(IBXELE,IBX00,IBXFILE,IBXIEN,IBXARRAY,IBXERR) ; Find data assoc with form fld def
+1 NEW IBXPG,IBXCOL,IBXLN,IBXDA,IBXFF
+2 IF $PIECE(IBX00,U,3)="C"
SET IBXDATA=$PIECE(IBX00,U,8)
GOTO DATAQ
+3 IF $PIECE(IBX00,U,3)="E"
IF $GET(^IBA(364.5,IBXELE,1))'=""
XECUTE ^(1)
GOTO DATAQ
+4 IF $PIECE(IBX00,U,3)="F"
Begin DoDot:1
+5 IF $PIECE(IBX00,U,6)[":"
IF $$GET1^DIQ(IBXFILE,IBXIEN_",",$PIECE($PIECE(IBX00,U,6),":"))=""
SET IBXDATA=""
QUIT
+6 SET IBXDATA=$$GET1^DIQ(IBXFILE,IBXIEN_",",$PIECE(IBX00,U,6),$SELECT("I"[$PIECE(IBX00,U,7):"I",1:""),IBXARRAY)
+7 IF $DATA(^TMP("DIERR",$JOB,1))
SET IBXERR="FILEMAN FIELD: "_$PIECE(IBX00,U)_" "_^(1,"TEXT",1)
End DoDot:1
DATAQ QUIT $GET(IBXDATA)
+1 ;
DUP(DA,X,CK) ; Duplicate check on form field definitions
+1 ;Returns 1 if a duplicate of this form page/line/column is found
+2 NEW PG,LN,COL,ND,FORM,DUP,Z
+3 SET DUP=0
+4 if $GET(DA)=""
GOTO DUPQ
+5 SET ND=$GET(^IBA(364.6,DA,0))
+6 SET FORM=$SELECT($GET(CK)=1:X,1:$PIECE(ND,U))
SET PG=$SELECT($GET(CK)=2:X,1:$PIECE(ND,U,4))
SET LN=$SELECT($GET(CK)=3:X,1:$PIECE(ND,U,5))
SET COL=$SELECT($GET(CK)=4:X,1:$PIECE(ND,U,8))
+7 ;
+8 IF FORM'=""
IF PG'=""
IF LN'=""
IF COL'=""
Begin DoDot:1
+9 SET Z=$ORDER(^IBA(364.6,"ASEQ",FORM,PG,LN,COL,""))
+10 if $SELECT(Z=""
QUIT
+11 SET DUP=1
End DoDot:1
+12 ;
DUPQ QUIT DUP
+1 ;
BILLPARM(IBXIEN,IBXPARM) ; Sets up parameters for extracting bill data
+1 ;IBXIEN = internal entry # of the entry to be extracted
+2 ;IBXPARM = array that the parameters are set into. Pass by reference
+3 ; (2)=insurance co int entry #, (3)=bill type (I/O)
+4 NEW IB0,IBCBH
+5 SET IB0=$GET(^DGCR(399,IBXIEN,0))
SET IBCBH=$PIECE(IB0,U,21)
if "PST"'[IBCBH!(IBCBH="")
SET IBCBH="P"
+6 SET IBXPARM(1)="BILL-SEARCH"
SET IBXPARM(2)=$PIECE($GET(^DGCR(399,IBXIEN,"I"_($FIND("PST",IBCBH)-1))),U)
SET IBXPARM(3)=$SELECT($PIECE(IB0,U,5)<3:"I",1:"O")
+7 QUIT
+8 ;
PARTEXT(FORMAT,PG,LN,IBXIEN,IBXFORM,IBXPARM,IBXERR) ; Extract part of a printed form
+1 ;FORMAT = flag used to say whether you want (1) formatted (by line)
+2 ; or (0) unformatted (by pg/line/col) returned
+3 ;PG = page to start/end in 2 '^' pieces (start page^end page)
+4 ;LN = line to start/end in 2 '^' pieces (start line^end line)
+5 ; the start value of the preceeding 2 parameters are required
+6 ; if no end value, start value is assumed to be end value, too
+7 ;IBXIEN = the entry # of the record to be extracted
+8 ;IBXFORM = ien of the local or parent form in file 353 to be extracted
+9 ;IBXPARM = passed by reference. Extract parameters.
+10 ;IBXERR = passed by reference. If an error condition is found, this is
+11 ; the text of the error.
+12 ;
+13 ;Returns ^TMP("IBXDISP",$J,PG,LN)=print line(s) if FORMAT=1
+14 ;Returns ^TMP("IBXDISP",$J,1,PG,LN,COL)=data at PG/LN/COL if +FORMAT=0
+15 ;
+16 ;we may later add an automatic data element dependency logic where
+17 ; we can flag a data element as needing another d.e. extracted first
+18 ; and we execute the other logic automatically if not already done.
+19 ;
+20 NEW IBXDA,IBXPG,IBXLN,IBXCOL,IBXF,IBX2,IBXREC,IBXFILE,Z
+21 KILL ^TMP("IBXDATA",$JOB),^TMP("DIERR",$JOB),^TMP("IBXEDIT",$JOB),^TMP("IBXDISP",$JOB)
+22 SET IBX2=$GET(^IBE(353,+$GET(IBXFORM),2))
+23 IF $PIECE(IBX2,U,2)'="P"
SET IBXERR="NOT A PRINTABLE FORM!!"
QUIT
+24 IF '$DATA(^DGCR(399,IBXIEN,0))
SET IBXERR="BILL DOES NOT EXIST"
QUIT
+25 if $PIECE(PG,U,2)=""
SET $PIECE(PG,U,2)=$PIECE(PG,U)
if $PIECE(LN,U,2)=""
SET $PIECE(LN,U,2)=$PIECE(LN,U)
+26 SET IBXF=$SELECT($PIECE(IBX2,U,5):$PIECE(IBX2,U,5),1:IBXFORM)
+27 SET IBXPG=$ORDER(^IBA(364.6,"ASEQ",IBXF,$PIECE(PG,U)),-1)
+28 FOR
SET IBXPG=$ORDER(^IBA(364.6,"ASEQ",IBXF,IBXPG))
if IBXPG=""!(IBXPG]$PIECE(PG,U,2))
QUIT
Begin DoDot:1
+29 SET IBXLN=$ORDER(^IBA(364.6,"ASEQ",IBXF,IBXPG,$PIECE(LN,U)),-1)
FOR
SET IBXLN=$ORDER(^IBA(364.6,"ASEQ",IBXF,IBXPG,IBXLN))
if IBXLN=""!(IBXLN]$PIECE(LN,U,2))
QUIT
Begin DoDot:2
+30 SET IBXCOL=""
FOR
SET IBXCOL=$ORDER(^IBA(364.6,"ASEQ",IBXF,IBXPG,IBXLN,IBXCOL))
if IBXCOL=""
QUIT
Begin DoDot:3
+31 SET IBXDA=$ORDER(^IBA(364.6,"ASEQ",IBXF,IBXPG,IBXLN,IBXCOL,""))
+32 if 'IBXDA
QUIT
+33 DO DATA^IBCEFG(IBXPG,IBXLN,IBXCOL,IBXIEN,IBXFORM,IBXDA,.IBXPARM,.IBXERR)
End DoDot:3
if $GET(IBXERR)'=""
QUIT
End DoDot:2
if $GET(IBXERR)'=""
GOTO PTQ
End DoDot:1
+34 SET IBXPG=""
FOR
SET IBXPG=$ORDER(^TMP("IBXDATA",$JOB,1,IBXPG))
if IBXPG=""!(IBXPG>$PIECE(PG,U,2))
QUIT
FOR IBXLN=+LN:1:$PIECE(LN,U,2)
if $GET(FORMAT)
SET ^TMP("IBXDISP",$JOB,IBXPG,IBXLN)=""
Begin DoDot:1
+35 if '$DATA(^TMP("IBXDATA",$JOB,1,IBXPG,IBXLN))
QUIT
+36 SET IBXCOL=""
FOR
SET IBXCOL=$ORDER(^TMP("IBXDATA",$JOB,1,IBXPG,IBXLN,IBXCOL))
if IBXCOL=""
QUIT
SET Z=$GET(^(IBXCOL))
IF Z'=""
Begin DoDot:2
+37 IF $GET(FORMAT)
SET $EXTRACT(^TMP("IBXDISP",$JOB,IBXPG,IBXLN),IBXCOL,IBXCOL+$LENGTH(Z)-1)=Z
QUIT
+38 IF '$GET(FORMAT)
SET ^TMP("IBXDISP",$JOB,IBXPG,IBXLN,IBXCOL)=Z
End DoDot:2
End DoDot:1
+39 ;
PTQ KILL ^TMP("IBXDATA",$JOB),^TMP("DIERR",$JOB)
+1 QUIT
+2 ;
BILLN(FORMAT,PG,LN,IBXIEN,IBXFORM) ; Call to extract the contents of lines on a bill
+1 ; See PARTEXT for parameters
+2 ; RETURNS null if extract OK, OR error text if not
+3 NEW IBXPARM,IBXERR,IBXDATA,IBXSIZE
+4 KILL ^TMP("IBXSAVE",$JOB)
+5 DO BILLPARM(IBXIEN,.IBXPARM)
+6 DO PARTEXT(FORMAT,PG,LN,IBXIEN,IBXFORM,.IBXPARM,.IBXERR)
+7 KILL ^TMP("IBXSAVE",$JOB)
+8 QUIT $GET(IBXERR)
+9 ;
EXTONE(IBXIEN,IBXELE,IBX,IBXERR) ;
+1 ; Extract unformatted data element(s) for record in file whose entry
+2 ; is IBXIEN
+3 ; IBXELE(1-n) = array passed by reference and containing the data
+4 ; element ien's from file 364.5 to return
+5 ; IBX = name of array to be returned containing the data requested.
+6 ; For individual-valued elements, IBX(1-n) will
+7 ; contain the data element values.
+8 ; For group elements, IBX(1-n,1-z) will contain the
+9 ; values of the data element's 1-z occurrences.
+10 ;
+11 ; IBXERR = if an error, the error message will be returned here
+12 ;
+13 NEW IBX00,IBXQ,IBXDATA,IBXFILE,IBXXD,Z0,Z1
+14 KILL @IBX
+15 SET IBXQ=""
FOR
SET IBXQ=$ORDER(IBXELE(IBXQ))
if 'IBXQ
QUIT
Begin DoDot:1
+16 SET IBX00=$GET(^IBA(364.5,+IBXELE(IBXQ),0))
SET IBXFILE=+$PIECE(IBX00,U,5)
SET IBXARRAY=$PIECE($GET(^IBA(364.5,+IBXELE(IBXQ),2)),U)
if IBXARRAY=""
SET IBXARRAY="IBXDATA"
+17 if 'IBXFILE
QUIT
+18 KILL IBXXD
+19 SET IBXXD=$$DATA(IBXELE(IBXQ),IBX00,IBXFILE,IBXIEN,IBXARRAY,.IBXERR)
+20 IF $DATA(@IBXARRAY)=1
SET (@IBX,@IBX@(IBXQ))=@IBXARRAY
QUIT
+21 SET Z0=""
SET Z1=0
FOR
SET Z0=$ORDER(@IBXARRAY@(Z0))
if 'Z0
QUIT
SET Z1=Z1+1
MERGE @IBX@(IBXQ,Z1)=@IBXARRAY@(Z0)
End DoDot:1
+22 QUIT
+23 ;
