- 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
