Routine: IBCF2P

IBCF2P	;ALB/ARH - PRINT HCFA 1500 12-90 FORM ; 17-JUL-93

	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

	;;Per VHA Directive 10-93-142, this routine should not be modified.

PRINT	; print the form, IBFLD required

	S IBADDM=+$P($G(^IBE(350.9,1,1)),U,27),IBPAGE=1

	F IBI=1:1:6 W !,?IBADDM,$G(IBFLD(0,IBI)) ;mailing address

LINE8	; insured's ID number

	W !!,?49,$E(IBFLD("1A"),1,28)

LINE10	; patient name, DOB, sex; insured's name ("SAME" if patient)

	W !!,$E(IBFLD(2),1,28),?30,IBFLD("3D"),?($S(IBFLD("3X")="M":41,1:46)),"X",?49,$E(IBFLD(4),1,28)

LINE12	; patient's address (street); pt. rel to ins.; insured's address

	W !!,$E(IBFLD(5,1),1,28),?($S(+IBFLD(6)=1:32,+IBFLD(6)=2:37,+IBFLD(6)=3:41,1:46)),"X",?49,$E(IBFLD(7),1,28)

LINE14	; patient addr city, state code, marital status; insured's city, state

	W !!,$E(IBFLD(5,2),1,24),?25,IBFLD("5S"),?($S(IBFLD("8M")="S":34,IBFLD("8M")="M":40,1:46)),"X",?49

LINE16	; patient zip code, phone; patient employment status; insured's zip code, phone

	W !!,$E(IBFLD(5,3),1,12),?14,IBFLD("5T"),?34,$S(IBFLD("8E")="E":"X",1:""),?49

LINE18	; other insured's name; insured's policy group

	W !!,$E(IBFLD(9),1,28),?49,$E(IBFLD(11),1,28)

LINE20	; other insured's policy number; condition related to employment?; insured's date of birth and sex

	W !!,$E(IBFLD("9A"),1,28),?($S(+IBFLD("10A"):34,1:40)),"X",?53,?($S(IBFLD("11AX")="M":67,1:74)),"X"

LINE22	; other insured's DOB, sex; patient auto accident & place; insured's employer

	W !!,?1,IBFLD("9BD") I IBFLD("9BX")'="" W ?($S(IBFLD("9BX")="M":17,1:23)),"X"

	W ?($S(+IBFLD("10B"):34,1:40)),"X",?44,IBFLD("10BS"),?49,$E(IBFLD("11B"),1,28)

LINE24	; other insured's employer; patient other accident; insured's insurance plan name

	W !!,$E(IBFLD("9C"),1,28),?($S(+IBFLD("10C"):34,1:40)),"X",?49,$E(IBFLD("11C"),1,28)

LINE26	; other insured's plan name; is there another benefit plan

	W !!,$E(IBFLD("9D"),1,28),?($S(+IBFLD("11D"):51,1:56)),"X"

LINE29	; patient's signature; insured's signature (use PL 99-272, SECTION 1729 TITLE 38)

	W !!!,?3,IBFLD(12),?56,IBFLD(13)

LINE32	; date of current illness; date of similar illness; dates unable to work

	W !!!,?1,IBFLD(14),?36,IBFLD(15),?53,IBFLD("16A"),?67,IBFLD("16B")

LINE34	; name of referring physician; ID# referring physician; hospitalization dates related to services

	W !!,?53,IBFLD("18A"),?67,IBFLD("18B")

LINE35	; "not for SC" note line 1

	W !,?14,$E(IBFLD(19),1,31)_"-"

LINE36	; "not for SC" note line 2; outside lab (now defaults to "no" in IBEHCFA)

	W !,$E(IBFLD(19),32,999),?56,"X"

LINE38	; diagnosis codes 1 and 2; field 22 (MEDICAID) left blank

	W !!,?2,IBFLD(21,1),?30,IBFLD(21,3)

LINE40	; diagnosis codes 3 and 4; field 23 (prior authorization #)

	W !!,?2,IBFLD(21,2),?30,IBFLD(21,4),?49,IBFLD(23)

LINE44	;lines 44,46,48,50,52,54 all the same

	W !! S IBI=+$P(IBFLD(24),U,2) F IBJ=1:1:6 S IBI=IBI+1 D

	. W ! I $D(IBFLD(24,IBI_"A")) W ?25,$E(IBFLD(24,IBI_"A"),1,15)

	. W ! I $D(IBFLD(24,IBI)) D  S IBFLD(24)=IBFLD(24)-1

	.. W $P(IBFLD(24,IBI),U,1),?9,$P(IBFLD(24,IBI),U,2),?18,$P(IBFLD(24,IBI),U,3),?21,$P(IBFLD(24,IBI),U,4),?25,$E($P(IBFLD(24,IBI),U,5),1,15)

	.. W ?41,$P(IBFLD(24,IBI),U,6),?47,$S(+$P(IBFLD(24,IBI),U,7):$J($P(IBFLD(24,IBI),U,7),10,2),1:""),?57,$J($P(IBFLD(24,IBI),U,8),3)

	S $P(IBFLD(24),U,2)=IBI

LINE56	W !!,IBFLD(25),?18,"X",?22,IBFLD(26),?49,$J(IBFLD(28),10,2),?62,?71

LINE58	W !!,?22,$E(IBFLD(32,1),1,26),?49,$E(IBFLD(33,1),1,26)

LINE69	W !,$E(IBFLD(31),1,21),?22,$E(IBFLD(32,2),1,26),?49,$E(IBFLD(33,2),1,26)

LINE60	W !,$E(IBFLD(31),22,42)

	W ?22,$E(IBFLD(32,3),1,(26-2-$L(IBFLD(32,"X")))) I IBFLD(32,"X")'="" W ", "_IBFLD(32,"X")

	W ?49,$E(IBFLD(33,3),1,(26-2-$L(IBFLD(33,"X")))) I IBFLD(33,"X")'="" W ", "_IBFLD(33,"X")

LINE61	W !,$E(IBFLD(31),43,63),?49,IBFLD(33,4)

	I +IBFLD(24)>0 D  G LINE38 ;multiple pages

	. S IBPAGE=IBPAGE+1

	. W @IOF,!,?IBADDM,"PAGE ",IBPAGE,!!!!!!!,?49,IBFLD("1A"),!!,IBFLD(2)

	. F IBI=1:1:26 W !

END	K IBADDM,IBPAGE

IBCF2P    ;ALB/ARH - PRINT HCFA 1500 12-90 FORM ; 17-JUL-93

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

PRINT     ; print the form, IBFLD required

 +1        SET IBADDM=+$PIECE($GET(^IBE(350.9,1,1)),U,27)

           SET IBPAGE=1

 +2       ;mailing address

           FOR IBI=1:1:6

               WRITE !,?IBADDM,$GET(IBFLD(0,IBI))

LINE8     ; insured's ID number

 +1        WRITE !!,?49,$EXTRACT(IBFLD("1A"),1,28)

LINE10    ; patient name, DOB, sex; insured's name ("SAME" if patient)

 +1        WRITE !!,$EXTRACT(IBFLD(2),1,28),?30,IBFLD("3D"),?($SELECT(IBFLD("3X")="M":41,1:46)),"X",?49,$EXTRACT(IBFLD(4),1,28)

LINE12    ; patient's address (street); pt. rel to ins.; insured's address

 +1        WRITE !!,$EXTRACT(IBFLD(5,1),1,28),?($SELECT(+IBFLD(6)=1:32,+IBFLD(6)=2:37,+IBFLD(6)=3:41,1:46)),"X",?49,$EXTRACT(IBFLD(7),1,28)

LINE14    ; patient addr city, state code, marital status; insured's city, state

 +1        WRITE !!,$EXTRACT(IBFLD(5,2),1,24),?25,IBFLD("5S"),?($SELECT(IBFLD("8M")="S":34,IBFLD("8M")="M":40,1:46)),"X",?49

LINE16    ; patient zip code, phone; patient employment status; insured's zip code, phone

 +1        WRITE !!,$EXTRACT(IBFLD(5,3),1,12),?14,IBFLD("5T"),?34,$SELECT(IBFLD("8E")="E":"X",1:""),?49

LINE18    ; other insured's name; insured's policy group

 +1        WRITE !!,$EXTRACT(IBFLD(9),1,28),?49,$EXTRACT(IBFLD(11),1,28)

LINE20    ; other insured's policy number; condition related to employment?; insured's date of birth and sex

 +1        WRITE !!,$EXTRACT(IBFLD("9A"),1,28),?($SELECT(+IBFLD("10A"):34,1:40)),"X",?53,?($SELECT(IBFLD("11AX")="M":67,1:74)),"X"

LINE22    ; other insured's DOB, sex; patient auto accident & place; insured's employer

 +1        WRITE !!,?1,IBFLD("9BD")

           IF IBFLD("9BX")'=""

               WRITE ?($SELECT(IBFLD("9BX")="M":17,1:23)),"X"

 +2        WRITE ?($SELECT(+IBFLD("10B"):34,1:40)),"X",?44,IBFLD("10BS"),?49,$EXTRACT(IBFLD("11B"),1,28)

LINE24    ; other insured's employer; patient other accident; insured's insurance plan name

 +1        WRITE !!,$EXTRACT(IBFLD("9C"),1,28),?($SELECT(+IBFLD("10C"):34,1:40)),"X",?49,$EXTRACT(IBFLD("11C"),1,28)

LINE26    ; other insured's plan name; is there another benefit plan

 +1        WRITE !!,$EXTRACT(IBFLD("9D"),1,28),?($SELECT(+IBFLD("11D"):51,1:56)),"X"

LINE29    ; patient's signature; insured's signature (use PL 99-272, SECTION 1729 TITLE 38)

 +1        WRITE !!!,?3,IBFLD(12),?56,IBFLD(13)

LINE32    ; date of current illness; date of similar illness; dates unable to work

 +1        WRITE !!!,?1,IBFLD(14),?36,IBFLD(15),?53,IBFLD("16A"),?67,IBFLD("16B")

LINE34    ; name of referring physician; ID# referring physician; hospitalization dates related to services

 +1        WRITE !!,?53,IBFLD("18A"),?67,IBFLD("18B")

LINE35    ; "not for SC" note line 1

 +1        WRITE !,?14,$EXTRACT(IBFLD(19),1,31)_"-"

LINE36    ; "not for SC" note line 2; outside lab (now defaults to "no" in IBEHCFA)

 +1        WRITE !,$EXTRACT(IBFLD(19),32,999),?56,"X"

LINE38    ; diagnosis codes 1 and 2; field 22 (MEDICAID) left blank

 +1        WRITE !!,?2,IBFLD(21,1),?30,IBFLD(21,3)

LINE40    ; diagnosis codes 3 and 4; field 23 (prior authorization #)

 +1        WRITE !!,?2,IBFLD(21,2),?30,IBFLD(21,4),?49,IBFLD(23)

LINE44    ;lines 44,46,48,50,52,54 all the same

 +1        WRITE !!

           SET IBI=+$PIECE(IBFLD(24),U,2)

           FOR IBJ=1:1:6

               SET IBI=IBI+1

               Begin DoDot:1

 +2                WRITE !

                   IF $DATA(IBFLD(24,IBI_"A"))

                       WRITE ?25,$EXTRACT(IBFLD(24,IBI_"A"),1,15)

 +3                WRITE !

                   IF $DATA(IBFLD(24,IBI))

                       Begin DoDot:2

 +4                        WRITE $PIECE(IBFLD(24,IBI),U,1),?9,$PIECE(IBFLD(24,IBI),U,2),?18,$PIECE(IBFLD(24,IBI),U,3),?21,$PIECE(IBFLD(24,IBI),U,4),?25,$EXTRACT($PIECE(IBFLD(24,IBI),U,5),1,15)

 +5                        WRITE ?41,$PIECE(IBFLD(24,IBI),U,6),?47,$SELECT(+$PIECE(IBFLD(24,IBI),U,7):$JUSTIFY($PIECE(IBFLD(24,IBI),U,7),10,2),1:""),?57,$JUSTIFY($PIECE(IBFLD(24,IBI),U,8),3)

                       End DoDot:2

                       SET IBFLD(24)=IBFLD(24)-1

               End DoDot:1

 +6        SET $PIECE(IBFLD(24),U,2)=IBI

 +7       ;

LINE56     WRITE !!,IBFLD(25),?18,"X",?22,IBFLD(26),?49,$JUSTIFY(IBFLD(28),10,2),?62,?71

LINE58     WRITE !!,?22,$EXTRACT(IBFLD(32,1),1,26),?49,$EXTRACT(IBFLD(33,1),1,26)

LINE69     WRITE !,$EXTRACT(IBFLD(31),1,21),?22,$EXTRACT(IBFLD(32,2),1,26),?49,$EXTRACT(IBFLD(33,2),1,26)

LINE60     WRITE !,$EXTRACT(IBFLD(31),22,42)

 +1        WRITE ?22,$EXTRACT(IBFLD(32,3),1,(26-2-$LENGTH(IBFLD(32,"X"))))

           IF IBFLD(32,"X")'=""

               WRITE ", "_IBFLD(32,"X")

 +2        WRITE ?49,$EXTRACT(IBFLD(33,3),1,(26-2-$LENGTH(IBFLD(33,"X"))))

           IF IBFLD(33,"X")'=""

               WRITE ", "_IBFLD(33,"X")

LINE61     WRITE !,$EXTRACT(IBFLD(31),43,63),?49,IBFLD(33,4)

 +1       ;

 +2       ;multiple pages

           IF +IBFLD(24)>0

               Begin DoDot:1

 +3                SET IBPAGE=IBPAGE+1

 +4                WRITE @IOF,!,?IBADDM,"PAGE ",IBPAGE,!!!!!!!,?49,IBFLD("1A"),!!,IBFLD(2)

 +5                FOR IBI=1:1:26

                       WRITE !

               End DoDot:1

               GOTO LINE38

 +6       ;

END        KILL IBADDM,IBPAGE

 +1        QUIT

IBCF2P.m