ABMDTIN2 ; IHS/SD/SDR - Maintenance of INSURER FILE part 3 ;
;;2.6;IHS Third Party Billing;**6,9,10,21**;NOV 12, 2009;Build 379
;IHS/SD/SDR 2.6*21 Moved DISP tag from ABMDTIN1 to here due to routine size limit
DISP ;DISPLAY VISIT TYPE TABLE
D VHDR^ABMDTIN1
S DA=0 F S DA=$O(^ABMNINS(DUZ(2),ABM("DFN"),1,DA)) Q:'DA S ABM(0)=^(DA,0) D
.I $Y+4>IOSL D
..S DIR(0)="E" D ^DIR K DIR
..D VHDR^ABMDTIN1
.W !?1,DA,?7,$E($P($G(^ABMDVTYP(DA,0)),U),1,17)
.I $P(ABM(0),U,7)="N" W ?27,"***** (UNBILLABLE) *****" Q
.I $D(^ABMNINS(DUZ(2),ABM("DFN"),1,DA,12,0)) D
..S ABMMVTD=""
..F S ABMMVTD=$O(^ABMNINS(DUZ(2),ABM("DFN"),1,DA,12,"B",ABMMVTD),-1) Q:ABMMVTD=""!($G(ABMVFLG)=1) D
...S ABMVTI=""
...F S ABMVTI=$O(^ABMNINS(DUZ(2),ABM("DFN"),1,DA,12,"B",ABMMVTD,ABMVTI)) Q:ABMVTI=""!($G(ABMVFLG)=1) D
....I $P($G(^ABMNINS(DUZ(2),ABM("DFN"),1,DA,12,ABMVTI,0)),U,2)'="",$P($G(^ABMNINS(DUZ(2),ABM("DFN"),1,DA,12,ABMVTI,0)),U,2)<DT Q
....S ABMVFLG=1
....W ?27,"** Replace with: "
....W:$P($G(^ABMNINS(DUZ(2),ABM("DFN"),1,DA,12,ABMVTI,0)),U,3)'="" $P($G(^AUTNINS($P($G(^ABMNINS(DUZ(2),ABM("DFN"),1,DA,12,ABMVTI,0)),U,3),0)),U)
....W " **"
.I $G(ABMVFLG)=1 K ABMVTI,ABMMVTD,ABMVFLG Q
.S ABM("X")=$S($P(ABM(0),U,4):$P($G(^ABMDEXP($P(ABM(0),U,4),0)),U),DA=111:"UB-92",1:"HCFA-1500")
.W ?26,$J("",9-$L(ABM("X"))\2)_ABM("X")
.W ?40,$S($P(ABM(0),U,6)="Y":"YES",DA=999:"N/A",1:"NO"),?46,$P(ABM(0),U,5)
.S ABM(1)=0 F ABM("I")=1:1 S ABM(1)=$O(^ABMNINS(DUZ(2),ABM("DFN"),1,DA,11,ABM(1))) Q:'ABM(1) S ABM(10)=^(ABM(1),0) D
..W:ABM("I")>1 !
..W ?50,$$SDT^ABMDUTL(ABM(10))
..I $P(ABM(10),U,3)]"" W ?61,$$SDT^ABMDUTL($P(ABM(10),"^",3))
..W ?72,$J($P(ABM(10),U,2),7,2)
Q
PROV2 ;
W !!
S ABMENTRY=0
F D Q:+Y<0!(ABMENTRY=4) ;ask for list of qualifiers
.D ^XBFMK
.S DA(1)=ABM("DFN")
.S DIC="^ABMNINS("_DUZ(2)_","_DA(1)_",3.5,"
.S DIC("P")=$P(^DD(9002274.09,3.5,0),U,2)
.S DIC(0)="AEQLM"
.S DIC("A")="Enter First 2310/2330/2440 Qualifier to use: "
.I ABMENTRY'=0 S DIC("A")=$S(ABMENTRY=1:"Second",ABMENTRY=2:"Third",ABMENTRY=3:"Fourth",1:"")_" 2310/2330/2440 Qualifier to use: "
.D ^DIC
.Q:+Y<0
.S ABMENTRY=+$G(ABMENTRY)+1
.S ABMQ(ABMENTRY)=$P(Y,U,2)
W !!,"Now set up your provider numbers for qualifiers..."
D ^XBFMK
F ABMX("I")=1:1:4 D
.Q:$G(ABMQ(ABMX("I")))=""
.W !!,"Providers for qualifier "_$G(ABMQ(ABMX("I")))
.F D Q:+Y<0
..D ^XBFMK
..S DA(2)=ABM("DFN")
..S DA(1)=ABMX("I")
..S DIC="^ABMNINS("_DUZ(2)_","_DA(2)_",3.5,"_DA(1)_",1,"
..S DIC("P")=$P(^DD(9002274.0935,.02,0),U,2)
..S DIC(0)="AEQLM"
..S DIC("A")="Select Provider: "
..D ^DIC
..Q:+Y<0
..S:$G(ABMQ(ABMX("I")))="0B" ABMPRVN=$$SLN^ABMEEPRV($P(Y,U,2))
..S:$G(ABMQ(ABMX("I")))="1G" ABMPRVN=$$UPIN^ABMEEPRV($P(Y,U,2))
..S:$G(ABMQ(ABMX("I")))="G2" ABMPRVN=$$PI^ABMUTLF($P(Y,U,2))
..W !,"Number "_ABMPRVN_" will be used from the New Person file"
D PAZ^ABMDRUTL
Q
;start new code abm*2.6*9 HEAT57746
SERVLOC ;EP
I +$P(ABM("0"),U,4)=0 Q ;abm*2.6*10 HEAT76272
I $P(^ABMDEXP($P(ABM("0"),U,4),0),U)'["5010" Q
S DR="117Service Facility Location"
D ^DIE
Q
;end new code HEAT57746
ABMDTIN2 ; IHS/SD/SDR - Maintenance of INSURER FILE part 3 ;
+1 ;;2.6;IHS Third Party Billing;**6,9,10,21**;NOV 12, 2009;Build 379
+2 ;IHS/SD/SDR 2.6*21 Moved DISP tag from ABMDTIN1 to here due to routine size limit
DISP ;DISPLAY VISIT TYPE TABLE
+1 DO VHDR^ABMDTIN1
+2 SET DA=0
FOR
SET DA=$ORDER(^ABMNINS(DUZ(2),ABM("DFN"),1,DA))
IF 'DA
QUIT
SET ABM(0)=^(DA,0)
Begin DoDot:1
+3 IF $Y+4>IOSL
Begin DoDot:2
+4 SET DIR(0)="E"
DO ^DIR
KILL DIR
+5 DO VHDR^ABMDTIN1
End DoDot:2
+6 WRITE !?1,DA,?7,$EXTRACT($PIECE($GET(^ABMDVTYP(DA,0)),U),1,17)
+7 IF $PIECE(ABM(0),U,7)="N"
WRITE ?27,"***** (UNBILLABLE) *****"
QUIT
+8 IF $DATA(^ABMNINS(DUZ(2),ABM("DFN"),1,DA,12,0))
Begin DoDot:2
+9 SET ABMMVTD=""
+10 FOR
SET ABMMVTD=$ORDER(^ABMNINS(DUZ(2),ABM("DFN"),1,DA,12,"B",ABMMVTD),-1)
IF ABMMVTD=""!($GET(ABMVFLG)=1)
QUIT
Begin DoDot:3
+11 SET ABMVTI=""
+12 FOR
SET ABMVTI=$ORDER(^ABMNINS(DUZ(2),ABM("DFN"),1,DA,12,"B",ABMMVTD,ABMVTI))
IF ABMVTI=""!($GET(ABMVFLG)=1)
QUIT
Begin DoDot:4
+13 IF $PIECE($GET(^ABMNINS(DUZ(2),ABM("DFN"),1,DA,12,ABMVTI,0)),U,2)'=""
IF $PIECE($GET(^ABMNINS(DUZ(2),ABM("DFN"),1,DA,12,ABMVTI,0)),U,2)<DT
QUIT
+14 SET ABMVFLG=1
+15 WRITE ?27,"** Replace with: "
+16 IF $PIECE($GET(^ABMNINS(DUZ(2),ABM("DFN"),1,DA,12,ABMVTI,0)),U,3)'=""
WRITE $PIECE($GET(^AUTNINS($PIECE($GET(^ABMNINS(DUZ(2),ABM("DFN"),1,DA,12,ABMVTI,0)),U,3),0)),U)
+17 WRITE " **"
End DoDot:4
End DoDot:3
End DoDot:2
+18 IF $GET(ABMVFLG)=1
KILL ABMVTI,ABMMVTD,ABMVFLG
QUIT
+19 SET ABM("X")=$SELECT($PIECE(ABM(0),U,4):$PIECE($GET(^ABMDEXP($PIECE(ABM(0),U,4),0)),U),DA=111:"UB-92",1:"HCFA-1500")
+20 WRITE ?26,$JUSTIFY("",9-$LENGTH(ABM("X"))\2)_ABM("X")
+21 WRITE ?40,$SELECT($PIECE(ABM(0),U,6)="Y":"YES",DA=999:"N/A",1:"NO"),?46,$PIECE(ABM(0),U,5)
+22 SET ABM(1)=0
FOR ABM("I")=1:1
SET ABM(1)=$ORDER(^ABMNINS(DUZ(2),ABM("DFN"),1,DA,11,ABM(1)))
IF 'ABM(1)
QUIT
SET ABM(10)=^(ABM(1),0)
Begin DoDot:2
+23 IF ABM("I")>1
WRITE !
+24 WRITE ?50,$$SDT^ABMDUTL(ABM(10))
+25 IF $PIECE(ABM(10),U,3)]""
WRITE ?61,$$SDT^ABMDUTL($PIECE(ABM(10),"^",3))
+26 WRITE ?72,$JUSTIFY($PIECE(ABM(10),U,2),7,2)
End DoDot:2
End DoDot:1
+27 QUIT
PROV2 ;
+1 WRITE !!
+2 SET ABMENTRY=0
+3 ;ask for list of qualifiers
FOR
Begin DoDot:1
+4 DO ^XBFMK
+5 SET DA(1)=ABM("DFN")
+6 SET DIC="^ABMNINS("_DUZ(2)_","_DA(1)_",3.5,"
+7 SET DIC("P")=$PIECE(^DD(9002274.09,3.5,0),U,2)
+8 SET DIC(0)="AEQLM"
+9 SET DIC("A")="Enter First 2310/2330/2440 Qualifier to use: "
+10 IF ABMENTRY'=0
SET DIC("A")=$SELECT(ABMENTRY=1:"Second",ABMENTRY=2:"Third",ABMENTRY=3:"Fourth",1:"")_" 2310/2330/2440 Qualifier to use: "
+11 DO ^DIC
+12 IF +Y<0
QUIT
+13 SET ABMENTRY=+$GET(ABMENTRY)+1
+14 SET ABMQ(ABMENTRY)=$PIECE(Y,U,2)
End DoDot:1
IF +Y<0!(ABMENTRY=4)
QUIT
+15 WRITE !!,"Now set up your provider numbers for qualifiers..."
+16 DO ^XBFMK
+17 FOR ABMX("I")=1:1:4
Begin DoDot:1
+18 IF $GET(ABMQ(ABMX("I")))=""
QUIT
+19 WRITE !!,"Providers for qualifier "_$GET(ABMQ(ABMX("I")))
+20 FOR
Begin DoDot:2
+21 DO ^XBFMK
+22 SET DA(2)=ABM("DFN")
+23 SET DA(1)=ABMX("I")
+24 SET DIC="^ABMNINS("_DUZ(2)_","_DA(2)_",3.5,"_DA(1)_",1,"
+25 SET DIC("P")=$PIECE(^DD(9002274.0935,.02,0),U,2)
+26 SET DIC(0)="AEQLM"
+27 SET DIC("A")="Select Provider: "
+28 DO ^DIC
+29 IF +Y<0
QUIT
+30 IF $GET(ABMQ(ABMX("I")))="0B"
SET ABMPRVN=$$SLN^ABMEEPRV($PIECE(Y,U,2))
+31 IF $GET(ABMQ(ABMX("I")))="1G"
SET ABMPRVN=$$UPIN^ABMEEPRV($PIECE(Y,U,2))
+32 IF $GET(ABMQ(ABMX("I")))="G2"
SET ABMPRVN=$$PI^ABMUTLF($PIECE(Y,U,2))
+33 WRITE !,"Number "_ABMPRVN_" will be used from the New Person file"
End DoDot:2
IF +Y<0
QUIT
End DoDot:1
+34 DO PAZ^ABMDRUTL
+35 QUIT
+36 ;start new code abm*2.6*9 HEAT57746
SERVLOC ;EP
+1 ;abm*2.6*10 HEAT76272
IF +$PIECE(ABM("0"),U,4)=0
QUIT
+2 IF $PIECE(^ABMDEXP($PIECE(ABM("0"),U,4),0),U)'["5010"
QUIT
+3 SET DR="117Service Facility Location"
+4 DO ^DIE
+5 QUIT
+6 ;end new code HEAT57746
