- IBCF3 ;ALB/BGA -UB92 HCFA-1450 (gather demographics) ;19-AUG-93
- ;;2.0;INTEGRATED BILLING;**8,52,80,109,51**;21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- DEV ;
- N IBF
- S IBFT=$$FTN^IBCU3(3),IBF=$P($G(^IBE(353,+IB,2)),U,8)
- S:IBF="" IBF=3 ;Forces the use of the output formatter to print bills
- D ENFMT^IBCF(IBIFN,3,IBF)
- K IBFT
- Q
- ; Obsolete calls to print bill routines follows
- 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,"MP")),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 IBFL(1,"PROVL4")=$P(IBX,U,6) ; agent cashier phone
- S IBX=$P(IBCUF3,U,1) D SPLIT^IBCF3(2,2,30,IBX) ; set IBFL(2)
- S IBFL(3)=$$BN1^PRCAFN(IBIFN)
- ;
- S IBFL(4)=$P(IBCBILL,U,24)_$P($G(^DGCR(399.1,+$P(IBCBILL,U,25),0)),U,2)_$P(IBCBILL,U,26)
- ;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,IBNOCHG,X,Y
- K:'$D(IBXIEN) ^TMP($J)
- Q
- ;
- DATE(X) ;returns date in form format MMDDYY
- Q $$DATE^IBCF2($G(X),,1)
- ;
- DATEY(X) ;returns date in form format MMDDYYYY
- Q $$DATE^IBCF2($G(X),1,1)
- ;
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCF3 4775 printed Feb 18, 2025@23:39:21 Page 2
- IBCF3 ;ALB/BGA -UB92 HCFA-1450 (gather demographics) ;19-AUG-93
- +1 ;;2.0;INTEGRATED BILLING;**8,52,80,109,51**;21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- DEV ;
- +1 NEW IBF
- +2 SET IBFT=$$FTN^IBCU3(3)
- SET IBF=$PIECE($GET(^IBE(353,+IB,2)),U,8)
- +3 ;Forces the use of the output formatter to print bills
- if IBF=""
- SET IBF=3
- +4 DO ENFMT^IBCF(IBIFN,3,IBF)
- +5 KILL IBFT
- +6 QUIT
- +7 ; Obsolete calls to print bill routines follows
- +8 SET %ZIS="Q"
- SET %ZIS("A")="Output Device: "
- +9 SET %ZIS("B")=$$BILLDEV^IBCU3(IBIFN)
- +10 DO ^%ZIS
- if POP
- GOTO Q
- +11 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
- +12 ;
- +13 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,"MP")),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 ; agent cashier phone
- SET IBFL(1,"PROVL4")=$PIECE(IBX,U,6)
- +16 ; set IBFL(2)
- SET IBX=$PIECE(IBCUF3,U,1)
- DO SPLIT^IBCF3(2,2,30,IBX)
- +17 SET IBFL(3)=$$BN1^PRCAFN(IBIFN)
- +18 ;
- +19 SET IBFL(4)=$PIECE(IBCBILL,U,24)_$PIECE($GET(^DGCR(399.1,+$PIECE(IBCBILL,U,25),0)),U,2)_$PIECE(IBCBILL,U,26)
- +20 ;site paramater
- +21 SET IBSIGN=$GET(^IBE(350.9,1,1))
- SET IBFL(5)=$PIECE(IBSIGN,U,5)
- +22 ;statement covers period
- +23 SET IBSTATE=$GET(^DGCR(399,+IBIFN,"U"))
- +24 SET IBFL(6,"FROM")=$$DATE(+$PIECE(IBSTATE,U,1))
- SET IBFL(6,"TO")=$$DATE(+$PIECE(IBSTATE,U,2))
- +25 SET IBFL(7)=$PIECE(IBCU2,U,2)
- SET IBFL(8)=$PIECE(IBCU2,U,3)
- +26 ; 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,IBNOCHG,X,Y
- +1 if '$DATA(IBXIEN)
- KILL ^TMP($JOB)
- +2 QUIT
- +3 ;
- DATE(X) ;returns date in form format MMDDYY
- +1 QUIT $$DATE^IBCF2($GET(X),,1)
- +2 ;
- DATEY(X) ;returns date in form format MMDDYYYY
- +1 QUIT $$DATE^IBCF2($GET(X),1,1)
- +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