IBCF2P ;ALB/ARH - PRINT HCFA 1500 12-90 FORM ; 17-JUL-93
;;2.0;INTEGRATED BILLING;**8,52,133,488**;21-MAR-94;Build 184
;;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"
W ?53,IBFLD("11AD") I IBFLD("11AX")'="" W ?($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" *488*
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
;remove box 9c *488*
;W !!,$E(IBFLD("9C"),1,28),?($S(+IBFLD("10C"):34,1:40)),"X",?49,$E(IBFLD("11C"),1,28)
W !!,?($S(+IBFLD("10C"):34,1:40)),"X",?49,$E(IBFLD("11C"),1,28)
LINE26 ; other insured's plan name; is there another benefit plan *488* add box 10d
W !!,$E(IBFLD("9D"),1,28),?30,IBFLD("10D"),?($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 *488*
W !!!,?1,IBFLD(14),?14,IBFLD(14.1),?26,IBFLD(15.1),?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,83),?56,"X"
LINE37 ; diagnosis code indicator *488*
W !,?40,IBFLD("21A")
LINE38 ; diagnosis codes 1-4 ; field 22 (MEDICAID) left blank *488*
W !,?2,IBFLD(21,1),?15,IBFLD(21,2),?28,IBFLD(21,3),?40,IBFLD(21,4)
LINE39 ; diagnosis codes 5-8 *488*
W !,?2,IBFLD(21,5),?15,IBFLD(21,6),?28,IBFLD(21,7),?40,IBFLD(21,7)
LINE40 ; diagnosis codes 9-12; field 23 (prior authorization #) *488*
W !,?2,IBFLD(21,9),?15,IBFLD(21,10),?28,IBFLD(21,11),?40,IBFLD(21,12),?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)
.. I $P(IBFLD(24,IBI),U,9) W ?32,$P($$MOD^ICPTMOD(+$P(IBFLD(24,IBI),U,9),"I",DT),U,2)
.. W ?41,$P(IBFLD(24,IBI),U,6),?48,$S(+$P(IBFLD(24,IBI),U,7):$J($P(IBFLD(24,IBI),U,7),9,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)
W:IBFLD(29) ?62,$J(IBFLD(29),7,2)
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCF2P 4577 printed Dec 13, 2024@02:12:55 Page 2
IBCF2P ;ALB/ARH - PRINT HCFA 1500 12-90 FORM ; 17-JUL-93
+1 ;;2.0;INTEGRATED BILLING;**8,52,133,488**;21-MAR-94;Build 184
+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"
+2 WRITE ?53,IBFLD("11AD")
IF IBFLD("11AX")'=""
WRITE ?($SELECT(IBFLD("11AX")="M":67,1:74)),"X"
LINE22 ; other insured's DOB, sex; patient auto accident & place; insured's employer
+1 ;,?1,IBFLD("9BD") I IBFLD("9BX")'="" W ?($S(IBFLD("9BX")="M":17,1:23)),"X" *488*
WRITE !!
+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 ;remove box 9c *488*
+2 ;W !!,$E(IBFLD("9C"),1,28),?($S(+IBFLD("10C"):34,1:40)),"X",?49,$E(IBFLD("11C"),1,28)
+3 WRITE !!,?($SELECT(+IBFLD("10C"):34,1:40)),"X",?49,$EXTRACT(IBFLD("11C"),1,28)
LINE26 ; other insured's plan name; is there another benefit plan *488* add box 10d
+1 WRITE !!,$EXTRACT(IBFLD("9D"),1,28),?30,IBFLD("10D"),?($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 *488*
+1 WRITE !!!,?1,IBFLD(14),?14,IBFLD(14.1),?26,IBFLD(15.1),?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,83),?56,"X"
LINE37 ; diagnosis code indicator *488*
+1 WRITE !,?40,IBFLD("21A")
LINE38 ; diagnosis codes 1-4 ; field 22 (MEDICAID) left blank *488*
+1 WRITE !,?2,IBFLD(21,1),?15,IBFLD(21,2),?28,IBFLD(21,3),?40,IBFLD(21,4)
LINE39 ; diagnosis codes 5-8 *488*
+1 WRITE !,?2,IBFLD(21,5),?15,IBFLD(21,6),?28,IBFLD(21,7),?40,IBFLD(21,7)
LINE40 ; diagnosis codes 9-12; field 23 (prior authorization #) *488*
+1 WRITE !,?2,IBFLD(21,9),?15,IBFLD(21,10),?28,IBFLD(21,11),?40,IBFLD(21,12),?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 IF $PIECE(IBFLD(24,IBI),U,9)
WRITE ?32,$PIECE($$MOD^ICPTMOD(+$PIECE(IBFLD(24,IBI),U,9),"I",DT),U,2)
+6 WRITE ?41,$PIECE(IBFLD(24,IBI),U,6),?48,$SELECT(+$PIECE(IBFLD(24,IBI),U,7):$JUSTIFY($PIECE(IBFLD(24,IBI),U,7),9,2),1:""),?57,$JUSTIFY($PIECE(IBFLD(24,IBI),U,8),3)
End DoDot:2
SET IBFLD(24)=IBFLD(24)-1
End DoDot:1
+7 SET $PIECE(IBFLD(24),U,2)=IBI
+8 ;
LINE56 WRITE !!,IBFLD(25),?18,"X",?22,IBFLD(26),?49,$JUSTIFY(IBFLD(28),10,2)
+1 if IBFLD(29)
WRITE ?62,$JUSTIFY(IBFLD(29),7,2)
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
