IBCF3 ;ALB/BGA -UB92 HCFA-1450 (gather demographics) ;19-AUG-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
DEV S %ZIS="Q",%ZIS("A")="Output Device: "
S %ZIS("B")=$$BILLDEV^IBCU3(IBIFN)
D ^%ZIS G:POP Q
I $D(IO("Q")) S ZTRTN="EN^IBCF3",ZTDESC="PRINT UB-92 BILL",ZTSAVE("IB*")="",ZTSAVE("DG*")="",ZTSAVE("DFN")="" D ^%ZTLOAD K IO("Q") D HOME^%ZIS G Q
;
U IO D EN
Q Q:$D(ZTQUEUED) D ^%ZISC
Q
;
EN ;This routine gathers demographics for printing of ub92 form.
;Fields 1 to 21 are addressed in this routine.
;IBIFN must be defined...
;
I '$D(IBPNT) S IBPNT=0
;find out if a manual signature is required
S IBCBILL=$G(^DGCR(399,+IBIFN,0)) I IBCBILL="" G EXIT
S IBCU2=$G(^DGCR(399,+IBIFN,"U2")),IBCUF3=$G(^DGCR(399,+IBIFN,"UF3")),IBCUF31=$G(^DGCR(399,+IBIFN,"UF31"))
S IBCINSN=$P($G(^DGCR(399,+IBIFN,"I1")),U,1),IBCINSN=$G(^DIC(36,+IBCINSN,0))
S IBFL(0,"SR")=$S(+$P(IBCINSN,U,3):"##SR",1:"") ; signature required on bill
S IBFL(0,"ZBILL")=$S(IBPNT=1:"",IBPNT=0:"*** COPY OF ORIGINAL BILL ***",IBPNT=2:"*** SECOND NOTICE ***",IBPNT=3:"*** THIRD NOTICE ***",1:"")
;provider name and address ^ibe(350.9,1,2)
S IBX=$G(^IBE(350.9,1,2)) ;site parameter file
S IBFL(1,"PROVL1")=$P(IBX,U,1),IBFL(1,"PROVL2")=$P(IBX,U,2)
S IBFL(1,"PROVL3")=$P(IBX,U,3)_" "_$P($G(^DIC(5,+$P(IBX,U,4),0)),U,2)_" "_$P(IBX,U,5)
S IBX=$P(IBCUF3,U,1) D SPLIT^IBCF3(2,2,30,IBX) ; set IBFL(2)
S IBFL(1,"PROVL4")=$P(IBX,U,6)
S IBFL(3)=$P(IBCBILL,U,1)
S IBFL(4)=$P(IBCBILL,U,4)_$P(IBCBILL,U,5)_$P(IBCBILL,U,6)
;site paramater
S IBSIGN=$G(^IBE(350.9,1,1)) S IBFL(5)=$P(IBSIGN,U,5)
;statement covers period
S IBSTATE=$G(^DGCR(399,+IBIFN,"U"))
S IBFL(6,"FROM")=$$DATE(+$P(IBSTATE,U,1)),IBFL(6,"TO")=$$DATE(+$P(IBSTATE,U,2))
S IBFL(7)=$P(IBCU2,U,2),IBFL(8)=$P(IBCU2,U,3)
S IBX=$P(IBCUF3,U,2) D SPLIT^IBCF3(11,2,13,IBX) ; set IBFL(11)
PAT ; patient info
S IBPMAILN=$G(^DGCR(399,+IBIFN,"M")),IBFL(13)=$P(IBPMAILN,U,10)
S DFN=$P(IBCBILL,U,2) D DEM^VADPT
S IBFL(12)=VADM(1),IBFL(15)=$P(VADM(5),U,1) I IBFL(15)="" S IBFL(15)="U"
S IBFL(14)="00000000" I +VADM(3) S IBFL(14)=$$DATEY(+VADM(3))
;S IBFL(14)=$S(+VADM(3):VADM(3),1:"0000000"),IBFL(14)=$$DATE(IBFL(14))
S IBX=$P(VADM(10),U,1)
S IBFL(16)=$S(IBX=1:"D",IBX=2:"M",IBX=4:"W",IBX=5:"X",IBX=6:"S",1:"U")
;test to see if inpatient with a ptf#, if so use admission date
S IBX=0,IBINPAT=0 I $P(IBCBILL,U,5)<3 S IBINPAT=1 I +$P(IBCBILL,U,8) S IBX=$P($G(^DGPT(+$P(IBCBILL,U,8),0)),U,2)
I 'IBX S IBX=$P(IBCBILL,U,3)
S IBFL(17)=$$DATE(IBX),IBFL(18)=$$TIME(IBX) I IBFL(18)="" S IBFL(18)=99
;
19 ; type of admission if outpatient leave blank
S IBFL(19)="" I +IBINPAT S IBFL(19)=$S(+$P(IBSTATE,U,8):$P(IBSTATE,U,8),1:9)
20 ; source of admission
S IBFL(20)="" I +IBINPAT S IBFL(20)=$S(+$P(IBSTATE,U,9):$P(IBSTATE,U,9),1:9)
21 ; discharge hour: ptf (45,70), non-va (399,16), 99
S IBFL(21)="" I +IBINPAT S IBX=+$G(^DGPT(+$P(IBCBILL,U,8),70)) D
. S IBX=$S(+IBX:IBX,1:$P(IBCBILL,U,16)) S IBFL(21)=$$TIME(IBX) I IBFL(21)="" S IBFL(21)=99
22 ;
D ^IBCF31,^IBCF32,^IBCF33,^IBCF3P
;
;set print status
S (DIC,DIE)=399,DA=IBIFN,DR="[IB STATUS]",IBYY=$S($P($G(^DGCR(399,IBIFN,"S")),U,12)="":"@92",1:"@94") D ^DIE K DIC,DIE,IBYY,DA,DR
D BSTAT^IBCDC(IBIFN) ; remove from AB list
;
EXIT K IBX,IBY,IBI,IBJ,IBCINSN,IBCBILL,IBSIGN,IBINPAT,IBSTATE,IBPMAILN,IBMAIL1,IBCBCOMM,IBCU2,IBCUF3,IBCUF31,IB,VADM,VA,VAERR,IBPG,IBFL,X,Y,^TMP($J)
Q
;
DATE(X) ;returns date in form format MMDDYY
Q ($E($G(X),4,5)_""_$E($G(X),6,7)_""_$E($G(X),2,3))
;
DATEY(X) ;returns date in form format MMDDYYYY
Q ($E($G(X),4,5)_""_$E($G(X),6,7)_""_(17+$E($G(X)))_$E($G(X),2,3))
;
TIME(X) ;returns hour stripped from date
S X=$E($P($G(X),".",2),1,2) I X'="" S:+X=24 X="00" S X=X_"0"
Q $E(X,1,2)
;
SPLIT(FLN,LINES,MAXCH,STRG) ;sets the string broken into lines that will fit in the FL block, in IBFL(FLN,x)=strg where max x=LINES
;specific for the multi line fields where the first line is 1 char less that the rest and is optional
;assumes that the first line length is 1-MAXCH and should be used last
N CNT,IBX S CNT=1,STRG=$G(STRG),MAXCH=+$G(MAXCH) I '$G(FLN)!'$G(LINES) W "NO SOMETHING" Q
I $L(STRG)'>((LINES-1)*MAXCH) S IBFL(FLN,CNT)="",CNT=CNT+1 Q:CNT>LINES
I CNT=1 S IBFL(FLN,CNT)=$E(STRG,1,(MAXCH-1)),STRG=$E(STRG,MAXCH,999),CNT=CNT+1 Q:CNT>LINES
F S IBFL(FLN,CNT)=$E(STRG,1,MAXCH),STRG=$E(STRG,(MAXCH+1),999),CNT=CNT+1 Q:CNT>LINES
Q
IBCF3 ;ALB/BGA -UB92 HCFA-1450 (gather demographics) ;19-AUG-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
DEV SET %ZIS="Q"
SET %ZIS("A")="Output Device: "
+1 SET %ZIS("B")=$$BILLDEV^IBCU3(IBIFN)
+2 DO ^%ZIS
IF POP
GOTO Q
+3 IF $DATA(IO("Q"))
SET ZTRTN="EN^IBCF3"
SET ZTDESC="PRINT UB-92 BILL"
SET ZTSAVE("IB*")=""
SET ZTSAVE("DG*")=""
SET ZTSAVE("DFN")=""
DO ^%ZTLOAD
KILL IO("Q")
DO HOME^%ZIS
GOTO Q
+4 ;
+5 USE IO
DO EN
Q IF $DATA(ZTQUEUED)
QUIT
DO ^%ZISC
+1 QUIT
+2 ;
EN ;This routine gathers demographics for printing of ub92 form.
+1 ;Fields 1 to 21 are addressed in this routine.
+2 ;IBIFN must be defined...
+3 ;
+4 IF '$DATA(IBPNT)
SET IBPNT=0
+5 ;find out if a manual signature is required
+6 SET IBCBILL=$GET(^DGCR(399,+IBIFN,0))
IF IBCBILL=""
GOTO EXIT
+7 SET IBCU2=$GET(^DGCR(399,+IBIFN,"U2"))
SET IBCUF3=$GET(^DGCR(399,+IBIFN,"UF3"))
SET IBCUF31=$GET(^DGCR(399,+IBIFN,"UF31"))
+8 SET IBCINSN=$PIECE($GET(^DGCR(399,+IBIFN,"I1")),U,1)
SET IBCINSN=$GET(^DIC(36,+IBCINSN,0))
+9 ; signature required on bill
SET IBFL(0,"SR")=$SELECT(+$PIECE(IBCINSN,U,3):"##SR",1:"")
+10 SET IBFL(0,"ZBILL")=$SELECT(IBPNT=1:"",IBPNT=0:"*** COPY OF ORIGINAL BILL ***",IBPNT=2:"*** SECOND NOTICE ***",IBPNT=3:"*** THIRD NOTICE ***",1:"")
+11 ;provider name and address ^ibe(350.9,1,2)
+12 ;site parameter file
SET IBX=$GET(^IBE(350.9,1,2))
+13 SET IBFL(1,"PROVL1")=$PIECE(IBX,U,1)
SET IBFL(1,"PROVL2")=$PIECE(IBX,U,2)
+14 SET IBFL(1,"PROVL3")=$PIECE(IBX,U,3)_" "_$PIECE($GET(^DIC(5,+$PIECE(IBX,U,4),0)),U,2)_" "_$PIECE(IBX,U,5)
+15 ; set IBFL(2)
SET IBX=$PIECE(IBCUF3,U,1)
DO SPLIT^IBCF3(2,2,30,IBX)
+16 SET IBFL(1,"PROVL4")=$PIECE(IBX,U,6)
+17 SET IBFL(3)=$PIECE(IBCBILL,U,1)
+18 SET IBFL(4)=$PIECE(IBCBILL,U,4)_$PIECE(IBCBILL,U,5)_$PIECE(IBCBILL,U,6)
+19 ;site paramater
+20 SET IBSIGN=$GET(^IBE(350.9,1,1))
SET IBFL(5)=$PIECE(IBSIGN,U,5)
+21 ;statement covers period
+22 SET IBSTATE=$GET(^DGCR(399,+IBIFN,"U"))
+23 SET IBFL(6,"FROM")=$$DATE(+$PIECE(IBSTATE,U,1))
SET IBFL(6,"TO")=$$DATE(+$PIECE(IBSTATE,U,2))
+24 SET IBFL(7)=$PIECE(IBCU2,U,2)
SET IBFL(8)=$PIECE(IBCU2,U,3)
+25 ; set IBFL(11)
SET IBX=$PIECE(IBCUF3,U,2)
DO SPLIT^IBCF3(11,2,13,IBX)
PAT ; patient info
+1 SET IBPMAILN=$GET(^DGCR(399,+IBIFN,"M"))
SET IBFL(13)=$PIECE(IBPMAILN,U,10)
+2 SET DFN=$PIECE(IBCBILL,U,2)
DO DEM^VADPT
+3 SET IBFL(12)=VADM(1)
SET IBFL(15)=$PIECE(VADM(5),U,1)
IF IBFL(15)=""
SET IBFL(15)="U"
+4 SET IBFL(14)="00000000"
IF +VADM(3)
SET IBFL(14)=$$DATEY(+VADM(3))
+5 ;S IBFL(14)=$S(+VADM(3):VADM(3),1:"0000000"),IBFL(14)=$$DATE(IBFL(14))
+6 SET IBX=$PIECE(VADM(10),U,1)
+7 SET IBFL(16)=$SELECT(IBX=1:"D",IBX=2:"M",IBX=4:"W",IBX=5:"X",IBX=6:"S",1:"U")
+8 ;test to see if inpatient with a ptf#, if so use admission date
+9 SET IBX=0
SET IBINPAT=0
IF $PIECE(IBCBILL,U,5)<3
SET IBINPAT=1
IF +$PIECE(IBCBILL,U,8)
SET IBX=$PIECE($GET(^DGPT(+$PIECE(IBCBILL,U,8),0)),U,2)
+10 IF 'IBX
SET IBX=$PIECE(IBCBILL,U,3)
+11 SET IBFL(17)=$$DATE(IBX)
SET IBFL(18)=$$TIME(IBX)
IF IBFL(18)=""
SET IBFL(18)=99
+12 ;
19 ; type of admission if outpatient leave blank
+1 SET IBFL(19)=""
IF +IBINPAT
SET IBFL(19)=$SELECT(+$PIECE(IBSTATE,U,8):$PIECE(IBSTATE,U,8),1:9)
20 ; source of admission
+1 SET IBFL(20)=""
IF +IBINPAT
SET IBFL(20)=$SELECT(+$PIECE(IBSTATE,U,9):$PIECE(IBSTATE,U,9),1:9)
21 ; discharge hour: ptf (45,70), non-va (399,16), 99
+1 SET IBFL(21)=""
IF +IBINPAT
SET IBX=+$GET(^DGPT(+$PIECE(IBCBILL,U,8),70))
Begin DoDot:1
+2 SET IBX=$SELECT(+IBX:IBX,1:$PIECE(IBCBILL,U,16))
SET IBFL(21)=$$TIME(IBX)
IF IBFL(21)=""
SET IBFL(21)=99
End DoDot:1
22 ;
+1 DO ^IBCF31
DO ^IBCF32
DO ^IBCF33
DO ^IBCF3P
+2 ;
+3 ;set print status
+4 SET (DIC,DIE)=399
SET DA=IBIFN
SET DR="[IB STATUS]"
SET IBYY=$SELECT($PIECE($GET(^DGCR(399,IBIFN,"S")),U,12)="":"@92",1:"@94")
DO ^DIE
KILL DIC,DIE,IBYY,DA,DR
+5 ; remove from AB list
DO BSTAT^IBCDC(IBIFN)
+6 ;
EXIT KILL IBX,IBY,IBI,IBJ,IBCINSN,IBCBILL,IBSIGN,IBINPAT,IBSTATE,IBPMAILN,IBMAIL1,IBCBCOMM,IBCU2,IBCUF3,IBCUF31,IB,VADM,VA,VAERR,IBPG,IBFL,X,Y,^TMP($JOB)
+1 QUIT
+2 ;
DATE(X) ;returns date in form format MMDDYY
+1 QUIT ($EXTRACT($GET(X),4,5)_""_$EXTRACT($GET(X),6,7)_""_$EXTRACT($GET(X),2,3))
+2 ;
DATEY(X) ;returns date in form format MMDDYYYY
+1 QUIT ($EXTRACT($GET(X),4,5)_""_$EXTRACT($GET(X),6,7)_""_(17+$EXTRACT($GET(X)))_$EXTRACT($GET(X),2,3))
+2 ;
TIME(X) ;returns hour stripped from date
+1 SET X=$EXTRACT($PIECE($GET(X),".",2),1,2)
IF X'=""
IF +X=24
SET X="00"
SET X=X_"0"
+2 QUIT $EXTRACT(X,1,2)
+3 ;
SPLIT(FLN,LINES,MAXCH,STRG) ;sets the string broken into lines that will fit in the FL block, in IBFL(FLN,x)=strg where max x=LINES
+1 ;specific for the multi line fields where the first line is 1 char less that the rest and is optional
+2 ;assumes that the first line length is 1-MAXCH and should be used last
+3 NEW CNT,IBX
SET CNT=1
SET STRG=$GET(STRG)
SET MAXCH=+$GET(MAXCH)
IF '$GET(FLN)!'$GET(LINES)
WRITE "NO SOMETHING"
QUIT
+4 IF $LENGTH(STRG)'>((LINES-1)*MAXCH)
SET IBFL(FLN,CNT)=""
SET CNT=CNT+1
IF CNT>LINES
QUIT
+5 IF CNT=1
SET IBFL(FLN,CNT)=$EXTRACT(STRG,1,(MAXCH-1))
SET STRG=$EXTRACT(STRG,MAXCH,999)
SET CNT=CNT+1
IF CNT>LINES
QUIT
+6 FOR
SET IBFL(FLN,CNT)=$EXTRACT(STRG,1,MAXCH)
SET STRG=$EXTRACT(STRG,(MAXCH+1),999)
SET CNT=CNT+1
IF CNT>LINES
QUIT
+7 QUIT
