- IBCF2 ;ALB/ARH - HCFA 1500 19-90 DATA (gather demographics) ; 12-JUN-93
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- DEV ; IBIFN required
- S %ZIS="Q",%ZIS("A")="Output Device: "
- S %ZIS("B")=$P($G(^IBE(353,+$P($G(^DGCR(399,IBIFN,0)),"^",19),0)),"^",2)
- D ^%ZIS G:POP Q
- I $D(IO("Q")) S ZTRTN="EN^IBCF2",ZTDESC="PRINT HCFA1500",ZTSAVE("IB*")="" D ^%ZTLOAD K IO("Q") D HOME^%ZIS G Q
- U IO D EN
- Q I '$D(ZTQUEUED) D ^%ZISC
- Q
- ;
- EN ;begin gathering data for printing of HCFA 1500
- ;IBIFN must be defined
- K IBFLD
- S IB(0)=$G(^DGCR(399,IBIFN,0)) Q:IB(0)=""
- S DFN=+$P(IB(0),U,2) Q:'$D(^DPT(DFN,0)) D ARRAY
- S IBJ=1 S:'$D(IBPNT) IBPNT=0 S IBFLD(0,1)=$S(IBPNT=1:"",IBPNT=0:"*** COPY OF ORIGINAL BILL ***",IBPNT=2:"*** SECOND NOTICE ***",IBPNT=3:"*** THIRD NOTICE ***",1:""),IBJ=IBJ+1
- MAIL F IBI="M","M1" S IB(IBI)=$G(^DGCR(399,IBIFN,IBI))
- S IBFLD(0,IBJ)=$P(IB("M"),U,4),IBJ=IBJ+1
- F IBI=$P(IB("M"),U,5),$P(IB("M"),U,6),$P(IB("M1"),U,1) I IBI'="" S IBFLD(0,IBJ)=IBI S IBJ=IBJ+1
- S IBFLD(0,IBJ)=$P(IB("M"),U,7)_", "_$$STATE(+$P(IB("M"),U,8))_" "_$P(IB("M"),U,9)
- ;
- PAT D DEM^VADPT
- S IBFLD("1A")=$P(VADM(2),U,2) ; ssn
- S IBFLD(2)=VADM(1) ; patient name
- S IBFLD("3D")=$$DATE(+VADM(3)) ; date of birth
- S IBFLD("3X")=$P(VADM(5),U,1) ; sex (m/f)
- S IBFLD("8M")=$S("146"[+VADM(10):"S","25"[+VADM(10):"M",1:"O") ;marital status
- K VADM,VA
- S X=+$P($G(^DPT(DFN,.311)),U,15),IBFLD("8E")=$S(",1,2,4,6,"[X:"E",1:"") ;employed?
- S IBSPE=+$P($G(^DPT(DFN,.25)),U,15),IBSPE=$S(",1,2,4,6,"[IBSPE:"E",1:"") ; spouse employed?
- ;
- PATADD D ADD^VADPT
- S IBFLD(5,1)=VAPA(1)_" "_VAPA(2)_" "_VAPA(3) ;patient's street address
- S IBFLD(5,2)=VAPA(4),IBFLD(5,3)=$P(VAPA(11),U,2) ;patient's city, zip
- S IBFLD("5S")=$$STATE(+VAPA(5)) ; patient's state
- S IBFLD("5T")=VAPA(8) ; patients phone number
- K VAPA
- ;
- NEXT D ^IBCF21 ; gather remaining data
- ;
- PRINT D ^IBCF2P ; print
- ;
- END ;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
- ;
- K DFN,IB,IBI,IBJ,IBX,IBY,IBSPE,IBFLD,IBDXI,X,Y,VAERR
- Q
- ;
- ARRAY ;
- F IBI=1:1:6 S IBFLD(0,IBI)=""
- F IBI=1:1:16,18:1:21,23:1:26,31:1:33 S IBFLD(IBI)=""
- F IBI=10,16,18 F IBJ="A","B" S IBFLD(IBI_IBJ)=""
- F IBI="10BS","10C","11AX","11B","11C","11D","1A","3D","3X","5S","5T","8E","8M","9A","9BD","9BX","9C","9D" S IBFLD(IBI)=""
- Q
- ;
- DATE(X) ; returns date in form format
- Q ($E(X,4,5)_" "_$E(X,6,7)_" "_$E(X,2,3))
- ;
- STATE(X) ; returns 2 letter abbreviation for state pointer
- Q $P($G(^DIC(5,+X,0)),U,2)
- IBCF2 ;ALB/ARH - HCFA 1500 19-90 DATA (gather demographics) ; 12-JUN-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 ; IBIFN required
- +1 SET %ZIS="Q"
- SET %ZIS("A")="Output Device: "
- +2 SET %ZIS("B")=$PIECE($GET(^IBE(353,+$PIECE($GET(^DGCR(399,IBIFN,0)),"^",19),0)),"^",2)
- +3 DO ^%ZIS
- IF POP
- GOTO Q
- +4 IF $DATA(IO("Q"))
- SET ZTRTN="EN^IBCF2"
- SET ZTDESC="PRINT HCFA1500"
- SET ZTSAVE("IB*")=""
- DO ^%ZTLOAD
- KILL IO("Q")
- DO HOME^%ZIS
- GOTO Q
- +5 USE IO
- DO EN
- Q IF '$DATA(ZTQUEUED)
- DO ^%ZISC
- +1 QUIT
- +2 ;
- EN ;begin gathering data for printing of HCFA 1500
- +1 ;IBIFN must be defined
- +2 KILL IBFLD
- +3 SET IB(0)=$GET(^DGCR(399,IBIFN,0))
- IF IB(0)=""
- QUIT
- +4 SET DFN=+$PIECE(IB(0),U,2)
- IF '$DATA(^DPT(DFN,0))
- QUIT
- DO ARRAY
- +5 SET IBJ=1
- IF '$DATA(IBPNT)
- SET IBPNT=0
- SET IBFLD(0,1)=$SELECT(IBPNT=1:"",IBPNT=0:"*** COPY OF ORIGINAL BILL ***",IBPNT=2:"*** SECOND NOTICE ***",IBPNT=3:"*** THIRD NOTICE ***",1:"")
- SET IBJ=IBJ+1
- MAIL FOR IBI="M","M1"
- SET IB(IBI)=$GET(^DGCR(399,IBIFN,IBI))
- +1 SET IBFLD(0,IBJ)=$PIECE(IB("M"),U,4)
- SET IBJ=IBJ+1
- +2 FOR IBI=$PIECE(IB("M"),U,5),$PIECE(IB("M"),U,6),$PIECE(IB("M1"),U,1)
- IF IBI'=""
- SET IBFLD(0,IBJ)=IBI
- SET IBJ=IBJ+1
- +3 SET IBFLD(0,IBJ)=$PIECE(IB("M"),U,7)_", "_$$STATE(+$PIECE(IB("M"),U,8))_" "_$PIECE(IB("M"),U,9)
- +4 ;
- PAT DO DEM^VADPT
- +1 ; ssn
- SET IBFLD("1A")=$PIECE(VADM(2),U,2)
- +2 ; patient name
- SET IBFLD(2)=VADM(1)
- +3 ; date of birth
- SET IBFLD("3D")=$$DATE(+VADM(3))
- +4 ; sex (m/f)
- SET IBFLD("3X")=$PIECE(VADM(5),U,1)
- +5 ;marital status
- SET IBFLD("8M")=$SELECT("146"[+VADM(10):"S","25"[+VADM(10):"M",1:"O")
- +6 KILL VADM,VA
- +7 ;employed?
- SET X=+$PIECE($GET(^DPT(DFN,.311)),U,15)
- SET IBFLD("8E")=$SELECT(",1,2,4,6,"[X:"E",1:"")
- +8 ; spouse employed?
- SET IBSPE=+$PIECE($GET(^DPT(DFN,.25)),U,15)
- SET IBSPE=$SELECT(",1,2,4,6,"[IBSPE:"E",1:"")
- +9 ;
- PATADD DO ADD^VADPT
- +1 ;patient's street address
- SET IBFLD(5,1)=VAPA(1)_" "_VAPA(2)_" "_VAPA(3)
- +2 ;patient's city, zip
- SET IBFLD(5,2)=VAPA(4)
- SET IBFLD(5,3)=$PIECE(VAPA(11),U,2)
- +3 ; patient's state
- SET IBFLD("5S")=$$STATE(+VAPA(5))
- +4 ; patients phone number
- SET IBFLD("5T")=VAPA(8)
- +5 KILL VAPA
- +6 ;
- NEXT ; gather remaining data
- DO ^IBCF21
- +1 ;
- PRINT ; print
- DO ^IBCF2P
- +1 ;
- END ;set print status
- +1 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
- +2 ; remove from AB list
- DO BSTAT^IBCDC(IBIFN)
- +3 ;
- +4 KILL DFN,IB,IBI,IBJ,IBX,IBY,IBSPE,IBFLD,IBDXI,X,Y,VAERR
- +5 QUIT
- +6 ;
- ARRAY ;
- +1 FOR IBI=1:1:6
- SET IBFLD(0,IBI)=""
- +2 FOR IBI=1:1:16,18:1:21,23:1:26,31:1:33
- SET IBFLD(IBI)=""
- +3 FOR IBI=10,16,18
- FOR IBJ="A","B"
- SET IBFLD(IBI_IBJ)=""
- +4 FOR IBI="10BS","10C","11AX","11B","11C","11D","1A","3D","3X","5S","5T","8E","8M","9A","9BD","9BX","9C","9D"
- SET IBFLD(IBI)=""
- +5 QUIT
- +6 ;
- DATE(X) ; returns date in form format
- +1 QUIT ($EXTRACT(X,4,5)_" "_$EXTRACT(X,6,7)_" "_$EXTRACT(X,2,3))
- +2 ;
- STATE(X) ; returns 2 letter abbreviation for state pointer
- +1 QUIT $PIECE($GET(^DIC(5,+X,0)),U,2)
