- ABMDF27B ; IHS/ASDST/DMJ - Set HCFA1500 (08/05) Print Array PART 2 ;
- ;;2.6;IHS 3P BILLING SYSTEM;**4,10,11,21**;NOV 12, 2009;Build 379
- ; IHS/SD/SDR - abm*2.6*4 - HEAT12115 - Moved box 23 over 2 to allow for "extra" dx codes
- ;IHS/SD/SDR - 2.6*21 - VMBP - Updated p11 changes to include Serena ref#s
- ;
- ; *********************************************************************
- BNODES S ABM("B5")=$G(^ABMDBILL(DUZ(2),ABMP("BDFN"),5)),ABM("B6")=$G(^(6)),ABM("B7")=$G(^(7)),ABM("B8")=$G(^(8)),ABM("B9")=$G(^(9)),ABM("B10")=$G(^(10))
- ;start old code abm*2.6*4 HEAT12115
- ;I $P(ABM("B5"),U,12)]"" S $P(ABMF(33),U,3)=$P(ABM("B5"),U,12)
- ;I $P($G(^DIC(40.7,ABMP("CLN"),0)),U)="AMBULANCE" S $P(ABMF(33),U,3)=$E($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,6),1,5)
- ;I +$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),37,0))'=0 D
- ;.I +$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U)'=0,($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,23)'="") S $P(ABMF(33),U,3)=$P($G(^ABMRLABS($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,23),0)),U,2)
- ;.I +$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U)=0 S $P(ABMF(33),U,3)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,22) ;default in-house
- ;end old code start new code HEAT12115
- I $P(ABM("B5"),U,12)]"" S $P(ABMF(33),U,5)=$P(ABM("B5"),U,12)
- I $P($G(^DIC(40.7,ABMP("CLN"),0)),U)="AMBULANCE" S $P(ABMF(33),U,5)=$E($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,6),1,5)
- I +$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),37,0))'=0 D
- .I +$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U)'=0,($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,23)'="") S $P(ABMF(33),U,5)=$P($G(^ABMRLABS($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,23),0)),U,2)
- .I +$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U)=0 S $P(ABMF(33),U,5)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,22) ;default in-house
- ;end new code HEAT12115
- ;no labs but CLIA wanted on form
- I +$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),37,0))=0 D
- .I $P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),1)),U,6)="R" D
- ..S $P(ABMF(33),U,3)=$P($G(^ABMRLABS($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,23),0)),U,2)
- .I $P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),1)),U,6)="I" D
- ..S $P(ABMF(33),U,3)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,22)
- ;
- ;I (ABMP("ITYPE")="V")&($P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,12)'="") S $P(ABMF(33),U,5)=$P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,12) ;abm*2.6*11 VMBP RQMT_108 ;abm*2.6*14 VMBP change
- I ((ABMP("ITYPE")="V")!($$GET1^DIQ(9999999.18,ABMP("INS"),".01","E")["VMBP"))&($P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,12)'="") S $P(ABMF(33),U,5)=$P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,12) ;abm*2.6*11 VMBP RQMT_108 ;abm*2.6*14 VMBP change
- ;
- EMPL I $P(ABM("B9"),U)]"" S $P(ABMF(13),U,2)="X"
- E S $P(ABMF(13),U,3)="X" G ACCD
- I $P(ABM("B9"),U,3)]"" S $P(ABMF(25),U,3)=$P(ABM("B9"),U,3)
- I $P(ABM("B9"),U,4)]"" S $P(ABMF(25),U,4)=$P(ABM("B9"),U,4)
- ;
- ACCD S $P(ABMF(15),U,$S('$P(ABM("B8"),U,3):5,"12"[$P(ABM("B8"),U,3):4,1:5))="X"
- S $P(ABMF(17),U,$S("12"[$P(ABM("B8"),U,3):3,1:2))="X"
- FSYM S $P(ABMF(25),U)=$P(ABM("B8"),U,6)
- SIML S $P(ABMF(25),U,2)=$P(ABM("B8"),U,9)
- REFR S $P(ABMF(27),U)=$P(ABM("B8"),U,8)
- S $P(ABMF(26),U)=$P(ABM("B8"),U,18)_$P(ABM("B8"),U,11) ;ref QUALIFIER/ID
- S $P(ABMF(27),U,2)=$P(ABM("B8"),U,17) ;ref NPI
- BLK19 ;
- S ABMBLK19=$$SDT^ABMDUTL($P(ABM("B9"),U,11)) ;date last seen
- S ABMBLK19=ABMBLK19_" "_$P(ABM("B9"),U,24) ;supervising prov UPIN
- S ABMBLK19=ABMBLK19_" "_$P(ABM("B9"),U,12) ;supervising prov
- S ABMBLK19=ABMBLK19_" "_$$SDT^ABMDUTL($P(ABM("B9"),U,13)) ;last x-ray
- S ABMBLK19=ABMBLK19_" "_$S($P(ABM("B9"),U,14)="Y":"HOMEBOUND",1:"")
- S ABMBLK19=ABMBLK19_" "_$S($P(ABM("B9"),U,15)="Y":"HOSPICE EMP. PROV",1:"")
- S ABMBLK19=ABMBLK19_" "_$P(ABM("B10"),U,1)
- S $P(ABMF(29),U)=$E(ABMBLK19,1,48)
- I (ABMP("ITYPE")="V")&($P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,13)'="") S $P(ABMF(29),U)=$P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,13) ;abm*2.6*11 VMBP VMBP RQMT_108
- I ((ABMP("ITYPE")="V")!($$GET1^DIQ(9999999.18,ABMP("INS"),".01","E")["VMBP"))&($P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,13)'="") S $P(ABMF(29),U)=$P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,13) ;abm*2.6*11 VMBP RQMT_108 ;abm*2.6*14 VMBP
- K ABMBLK19
- LAB I '$P(ABM("B8"),U) S $P(ABMF(29),U,3)="X"
- E S $P(ABMF(29),U,2)="X",$P(ABMF(29),U,4)=$P(ABM("B8"),U)
- ;I $P(ABM("B7"),U,4)="Y" S ABMF("23")="SIGNATURE ON FILE"_U_DT ;abm*2.6*10 HEAT78335
- ;I $P(ABM("B7"),U,4)="Y" S ABMF("23")="SIGNATURE ON FILE"_U_$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,12) ;abm*2.6*10 HEAT78335 ;abm*2.6*11 IHS/SD/AML 3/31/2011 HEAT30524- ALLOW ROI DATE TO PRINT
- I $P(ABM("B7"),U,4)="Y" S ABMF("23")="SIGNATURE ON FILE"_U_$P(ABM("B7"),U,11) ;abm*2.6*11 IHS/SD/AML 3/31/2011 HEAT30524- ALLOW ROI DATE TO PRINT
- I $P(ABM("B7"),U,5)="Y" S $P(ABMF("23"),U,3)="SIGNATURE ON FILE"
- ;
- I $P(ABMP("B0"),U,7)'=111,($P(ABMP("B0"),U,7)'=999),($P(ABMP("B0"),U,7)'=141) G XIT
- ;
- ; Hosp Info
- ADMIT I $P(ABM("B6"),U,1)]"" S $P(ABMF(27),U,3)=$P(ABM("B6"),U,1)
- DISCH I $P(ABM("B6"),U,3)]"" S $P(ABMF(27),U,4)=$P(ABM("B6"),U,3)
- ;
- XIT K ABM,ABMV,ABMX
- Q
- ABMDF27B ; IHS/ASDST/DMJ - Set HCFA1500 (08/05) Print Array PART 2 ;
- +1 ;;2.6;IHS 3P BILLING SYSTEM;**4,10,11,21**;NOV 12, 2009;Build 379
- +2 ; IHS/SD/SDR - abm*2.6*4 - HEAT12115 - Moved box 23 over 2 to allow for "extra" dx codes
- +3 ;IHS/SD/SDR - 2.6*21 - VMBP - Updated p11 changes to include Serena ref#s
- +4 ;
- +5 ; *********************************************************************
- BNODES SET ABM("B5")=$GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),5))
- SET ABM("B6")=$GET(^(6))
- SET ABM("B7")=$GET(^(7))
- SET ABM("B8")=$GET(^(8))
- SET ABM("B9")=$GET(^(9))
- SET ABM("B10")=$GET(^(10))
- +1 ;start old code abm*2.6*4 HEAT12115
- +2 ;I $P(ABM("B5"),U,12)]"" S $P(ABMF(33),U,3)=$P(ABM("B5"),U,12)
- +3 ;I $P($G(^DIC(40.7,ABMP("CLN"),0)),U)="AMBULANCE" S $P(ABMF(33),U,3)=$E($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,6),1,5)
- +4 ;I +$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),37,0))'=0 D
- +5 ;.I +$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U)'=0,($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,23)'="") S $P(ABMF(33),U,3)=$P($G(^ABMRLABS($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,23),0)),U,2)
- +6 ;.I +$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U)=0 S $P(ABMF(33),U,3)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,22) ;default in-house
- +7 ;end old code start new code HEAT12115
- +8 IF $PIECE(ABM("B5"),U,12)]""
- SET $PIECE(ABMF(33),U,5)=$PIECE(ABM("B5"),U,12)
- +9 IF $PIECE($GET(^DIC(40.7,ABMP("CLN"),0)),U)="AMBULANCE"
- SET $PIECE(ABMF(33),U,5)=$EXTRACT($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,6),1,5)
- +10 IF +$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),37,0))'=0
- Begin DoDot:1
- +11 IF +$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U)'=0
- IF ($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,23)'="")
- SET $PIECE(ABMF(33),U,5)=$PIECE($GET(^ABMRLABS($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,23),0)),U,2)
- +12 ;default in-house
- IF +$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U)=0
- SET $PIECE(ABMF(33),U,5)=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,22)
- End DoDot:1
- +13 ;end new code HEAT12115
- +14 ;no labs but CLIA wanted on form
- +15 IF +$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),37,0))=0
- Begin DoDot:1
- +16 IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),1)),U,6)="R"
- Begin DoDot:2
- +17 SET $PIECE(ABMF(33),U,3)=$PIECE($GET(^ABMRLABS($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,23),0)),U,2)
- End DoDot:2
- +18 IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),1)),U,6)="I"
- Begin DoDot:2
- +19 SET $PIECE(ABMF(33),U,3)=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,22)
- End DoDot:2
- End DoDot:1
- +20 ;
- +21 ;I (ABMP("ITYPE")="V")&($P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,12)'="") S $P(ABMF(33),U,5)=$P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,12) ;abm*2.6*11 VMBP RQMT_108 ;abm*2.6*14 VMBP change
- +22 ;abm*2.6*11 VMBP RQMT_108 ;abm*2.6*14 VMBP change
- IF ((ABMP("ITYPE")="V")!($$GET1^DIQ(9999999.18,ABMP("INS"),".01","E")["VMBP"))&($PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,3)),U,12)'="")
- SET $PIECE(ABMF(33),U,5)=$PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,3)),U,12)
- +23 ;
- EMPL IF $PIECE(ABM("B9"),U)]""
- SET $PIECE(ABMF(13),U,2)="X"
- +1 IF '$TEST
- SET $PIECE(ABMF(13),U,3)="X"
- GOTO ACCD
- +2 IF $PIECE(ABM("B9"),U,3)]""
- SET $PIECE(ABMF(25),U,3)=$PIECE(ABM("B9"),U,3)
- +3 IF $PIECE(ABM("B9"),U,4)]""
- SET $PIECE(ABMF(25),U,4)=$PIECE(ABM("B9"),U,4)
- +4 ;
- ACCD SET $PIECE(ABMF(15),U,$SELECT('$PIECE(ABM("B8"),U,3):5,"12"[$PIECE(ABM("B8"),U,3):4,1:5))="X"
- +1 SET $PIECE(ABMF(17),U,$SELECT("12"[$PIECE(ABM("B8"),U,3):3,1:2))="X"
- FSYM SET $PIECE(ABMF(25),U)=$PIECE(ABM("B8"),U,6)
- SIML SET $PIECE(ABMF(25),U,2)=$PIECE(ABM("B8"),U,9)
- REFR SET $PIECE(ABMF(27),U)=$PIECE(ABM("B8"),U,8)
- +1 ;ref QUALIFIER/ID
- SET $PIECE(ABMF(26),U)=$PIECE(ABM("B8"),U,18)_$PIECE(ABM("B8"),U,11)
- +2 ;ref NPI
- SET $PIECE(ABMF(27),U,2)=$PIECE(ABM("B8"),U,17)
- BLK19 ;
- +1 ;date last seen
- SET ABMBLK19=$$SDT^ABMDUTL($PIECE(ABM("B9"),U,11))
- +2 ;supervising prov UPIN
- SET ABMBLK19=ABMBLK19_" "_$PIECE(ABM("B9"),U,24)
- +3 ;supervising prov
- SET ABMBLK19=ABMBLK19_" "_$PIECE(ABM("B9"),U,12)
- +4 ;last x-ray
- SET ABMBLK19=ABMBLK19_" "_$$SDT^ABMDUTL($PIECE(ABM("B9"),U,13))
- +5 SET ABMBLK19=ABMBLK19_" "_$SELECT($PIECE(ABM("B9"),U,14)="Y":"HOMEBOUND",1:"")
- +6 SET ABMBLK19=ABMBLK19_" "_$SELECT($PIECE(ABM("B9"),U,15)="Y":"HOSPICE EMP. PROV",1:"")
- +7 SET ABMBLK19=ABMBLK19_" "_$PIECE(ABM("B10"),U,1)
- +8 SET $PIECE(ABMF(29),U)=$EXTRACT(ABMBLK19,1,48)
- +9 ;abm*2.6*11 VMBP VMBP RQMT_108
- IF (ABMP("ITYPE")="V")&($PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,3)),U,13)'="")
- SET $PIECE(ABMF(29),U)=$PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,3)),U,13)
- +10 ;abm*2.6*11 VMBP RQMT_108 ;abm*2.6*14 VMBP
- IF ((ABMP("ITYPE")="V")!($$GET1^DIQ(9999999.18,ABMP("INS"),".01","E")["VMBP"))&($PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,3)),U,13)'="")
- SET $PIECE(ABMF(29),U)=$PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,3)),U,13)
- +11 KILL ABMBLK19
- LAB IF '$PIECE(ABM("B8"),U)
- SET $PIECE(ABMF(29),U,3)="X"
- +1 IF '$TEST
- SET $PIECE(ABMF(29),U,2)="X"
- SET $PIECE(ABMF(29),U,4)=$PIECE(ABM("B8"),U)
- +2 ;I $P(ABM("B7"),U,4)="Y" S ABMF("23")="SIGNATURE ON FILE"_U_DT ;abm*2.6*10 HEAT78335
- +3 ;I $P(ABM("B7"),U,4)="Y" S ABMF("23")="SIGNATURE ON FILE"_U_$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,12) ;abm*2.6*10 HEAT78335 ;abm*2.6*11 IHS/SD/AML 3/31/2011 HEAT30524- ALLOW ROI DATE TO PRINT
- +4 ;abm*2.6*11 IHS/SD/AML 3/31/2011 HEAT30524- ALLOW ROI DATE TO PRINT
- IF $PIECE(ABM("B7"),U,4)="Y"
- SET ABMF("23")="SIGNATURE ON FILE"_U_$PIECE(ABM("B7"),U,11)
- +5 IF $PIECE(ABM("B7"),U,5)="Y"
- SET $PIECE(ABMF("23"),U,3)="SIGNATURE ON FILE"
- +6 ;
- +7 IF $PIECE(ABMP("B0"),U,7)'=111
- IF ($PIECE(ABMP("B0"),U,7)'=999)
- IF ($PIECE(ABMP("B0"),U,7)'=141)
- GOTO XIT
- +8 ;
- +9 ; Hosp Info
- ADMIT IF $PIECE(ABM("B6"),U,1)]""
- SET $PIECE(ABMF(27),U,3)=$PIECE(ABM("B6"),U,1)
- DISCH IF $PIECE(ABM("B6"),U,3)]""
- SET $PIECE(ABMF(27),U,4)=$PIECE(ABM("B6"),U,3)
- +1 ;
- XIT KILL ABM,ABMV,ABMX
- +1 QUIT
