IBCF2.m

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)