- ABMDFRA ; IHS/ASDST/DMJ - FLAT RATE ADJUSTMENT ;
- ;;2.6;IHS 3P BILLING SYSTEM;**9**;NOV 12, 2009
- ;
- ; IHS/SD/SDR - v2.5 p12 - UFMS
- ; If user isn't logged into cashiering session they can't do
- ; this option
- ;
- START ;START
- ;start new code abm*2.6*9 NOHEAT - ensure UFMS is setup
- I $P($G(^ABMDPARM(DUZ(2),1,4)),U,15)="" D Q
- .W !!,"* * UFMS SETUP MUST BE DONE BEFORE ANY BILLING FUNCTIONS CAN BE USED! * *",!
- .S DIR(0)="E",DIR("A")="Enter RETURN to Continue" D ^DIR K DIR
- ;end new code
- I $P($G(^ABMDPARM(DUZ(2),1,4)),U,15)=1 D Q:+$G(ABMUOPNS)=0
- .S ABMUOPNS=$$FINDOPEN^ABMUCUTL(DUZ)
- .I +$G(ABMUOPNS)=0 D Q
- ..W !!,"* * YOU MUST SIGN IN TO BE ABLE TO PERFORM BILLING FUNCTIONS! * *",!
- ..S DIR(0)="E",DIR("A")="Enter RETURN to Continue" D ^DIR K DIR
- W !!,"This option will adjust the amount billed field for all claims"
- W !,"for the insurer and visit type you select beginning with the date"
- W !,"you select to reflect a new flat rate.",!
- W !,"An adjustment will then be passed to the A/R system.",!
- S DIC="^ABMNINS(DUZ(2),",DIC(0)="AEMQ" D ^DIC Q:+Y<0 S ABMINS=+Y
- S DIC="^ABMNINS(DUZ(2),ABMINS,1,",DIC(0)="AEMQ" D ^DIC Q:+Y<0 S ABMVTYP=+Y
- S DIR(0)="D" D ^DIR K DIR Q:'Y S ABMDATE=Y
- S DIR(0)="N",DIR("A")="Enter Old Rate " D ^DIR K DIR S ABMORAT=Y
- W !!,"I am going to adjust the amount billed field for all bills with visit date ",!,$$MDT^ABMDUTL(ABMDATE)
- W "or later for insurer ",$P(^AUTNINS(ABMINS,0),U),", visit type ",ABMVTYP,", billed at"
- W !,"the old rate of ",ABMORAT,"."
- S ABMFLAT=$$FLAT^ABMDUTL(ABMINS,ABMVTYP,ABMDATE)
- W !!,"NOTE: The flat rate for this insurer, visit type, and date is $",ABMFLAT,".",!
- D PRO Q:Y'=1
- S ABMCOUNT=0
- S ABMI=ABMDATE-.5 F S ABMI=$O(^ABMDBILL(DUZ(2),"AD",ABMI)) Q:'ABMI D
- .S ABMJ=0 F S ABMJ=$O(^ABMDBILL(DUZ(2),"AD",ABMI,ABMJ)) Q:'ABMJ D
- ..D ONE
- W !!,"Finished - ",ABMCOUNT," bills changed.",!!
- S DIR(0)="E" D ^DIR K DIR
- K ABMFLAT,ABMVTYP,ABMDATE,ABMINS,ABMZERO,ABMCOUNT,ABMOLD,ABMI,ABMJ,ABMAO
- Q
- ONE ;EP - one bill
- S DA=ABMJ
- S ABMZERO=^ABMDBILL(DUZ(2),DA,0)
- Q:$P(ABMZERO,"^",7)'=ABMVTYP
- Q:$P(ABMZERO,"^",8)'=ABMINS
- S ABMDAYS=$P($G(^ABMDBILL(DUZ(2),DA,7)),"^",3)
- S:+ABMDAYS<2 ABMDAYS=1
- S ABMOLD=$P(^ABMDBILL(DUZ(2),DA,2),U)
- S ABMOTOT=ABMORAT*ABMDAYS
- Q:ABMOLD'=ABMOTOT
- S ABMNEW=ABMFLAT*ABMDAYS
- Q:ABMOLD=ABMNEW
- S $P(^ABMDBILL(DUZ(2),DA,2),U)=ABMNEW
- S:$P(^ABMDBILL(DUZ(2),DA,2),"^",3)=ABMOLD $P(^(2),"^",3)=ABMNEW
- S ^ABMDBILL(DUZ(2),DA,"AF",$H,.21)=DUZ_"^"_ABMOLD
- W "."
- S ABMCOUNT=ABMCOUNT+1
- S ABMFR("ADJ AMT")=ABMNEW-ABMOLD
- S ABMFR("USER")=DUZ
- S ABMFR("ARLOC")=$P(^ABMDBILL(DUZ(2),DA,2),"^",6)
- I ABMFR("ARLOC")="" D
- .S ABMFR("ARLOC")=$$FIND(DA)
- .I ABMFR("ARLOC")="" Q
- .S DIE="^ABMDBILL(DUZ(2),",DR=".26///"_ABMFR("ARLOC")
- .D ^DIE
- S ABMFR("TRAN TYPE")=503
- S ABMTEST=$$EN^BARFRAPI(.ABMFR)
- Q
- PRO ;PROCEED
- W !
- S DIR(0)="Y",DIR("A")="Proceed",DIR("B")="NO" D ^DIR K DIR
- Q
- FIND(DA) ;find bill in A/R
- S ABMARLOC=""
- S ABMNAME=$P(^ABMDBILL(DUZ(2),DA,0),U),ABMLOC=$P(^(0),"^",3)
- N I
- S I=0
- F S I=$O(^BARBL(I)) Q:'I D
- .Q:ABMARLOC'=""
- .S ABMNXT=$O(^BARBL(I,"B",ABMNAME))
- .Q:ABMNXT'[ABMNAME
- .S ABMIEN=$O(^BARBL(I,"B",ABMNXT,0))
- .I $P(^BARBL(I,ABMIEN,0),"^",17)=DA S ABMARLOC=I_","_ABMIEN
- Q ABMARLOC
- ABMDFRA ; IHS/ASDST/DMJ - FLAT RATE ADJUSTMENT ;
- +1 ;;2.6;IHS 3P BILLING SYSTEM;**9**;NOV 12, 2009
- +2 ;
- +3 ; IHS/SD/SDR - v2.5 p12 - UFMS
- +4 ; If user isn't logged into cashiering session they can't do
- +5 ; this option
- +6 ;
- START ;START
- +1 ;start new code abm*2.6*9 NOHEAT - ensure UFMS is setup
- +2 IF $PIECE($GET(^ABMDPARM(DUZ(2),1,4)),U,15)=""
- Begin DoDot:1
- +3 WRITE !!,"* * UFMS SETUP MUST BE DONE BEFORE ANY BILLING FUNCTIONS CAN BE USED! * *",!
- +4 SET DIR(0)="E"
- SET DIR("A")="Enter RETURN to Continue"
- DO ^DIR
- KILL DIR
- End DoDot:1
- QUIT
- +5 ;end new code
- +6 IF $PIECE($GET(^ABMDPARM(DUZ(2),1,4)),U,15)=1
- Begin DoDot:1
- +7 SET ABMUOPNS=$$FINDOPEN^ABMUCUTL(DUZ)
- +8 IF +$GET(ABMUOPNS)=0
- Begin DoDot:2
- +9 WRITE !!,"* * YOU MUST SIGN IN TO BE ABLE TO PERFORM BILLING FUNCTIONS! * *",!
- +10 SET DIR(0)="E"
- SET DIR("A")="Enter RETURN to Continue"
- DO ^DIR
- KILL DIR
- End DoDot:2
- QUIT
- End DoDot:1
- IF +$GET(ABMUOPNS)=0
- QUIT
- +11 WRITE !!,"This option will adjust the amount billed field for all claims"
- +12 WRITE !,"for the insurer and visit type you select beginning with the date"
- +13 WRITE !,"you select to reflect a new flat rate.",!
- +14 WRITE !,"An adjustment will then be passed to the A/R system.",!
- +15 SET DIC="^ABMNINS(DUZ(2),"
- SET DIC(0)="AEMQ"
- DO ^DIC
- IF +Y<0
- QUIT
- SET ABMINS=+Y
- +16 SET DIC="^ABMNINS(DUZ(2),ABMINS,1,"
- SET DIC(0)="AEMQ"
- DO ^DIC
- IF +Y<0
- QUIT
- SET ABMVTYP=+Y
- +17 SET DIR(0)="D"
- DO ^DIR
- KILL DIR
- IF 'Y
- QUIT
- SET ABMDATE=Y
- +18 SET DIR(0)="N"
- SET DIR("A")="Enter Old Rate "
- DO ^DIR
- KILL DIR
- SET ABMORAT=Y
- +19 WRITE !!,"I am going to adjust the amount billed field for all bills with visit date ",!,$$MDT^ABMDUTL(ABMDATE)
- +20 WRITE "or later for insurer ",$PIECE(^AUTNINS(ABMINS,0),U),", visit type ",ABMVTYP,", billed at"
- +21 WRITE !,"the old rate of ",ABMORAT,"."
- +22 SET ABMFLAT=$$FLAT^ABMDUTL(ABMINS,ABMVTYP,ABMDATE)
- +23 WRITE !!,"NOTE: The flat rate for this insurer, visit type, and date is $",ABMFLAT,".",!
- +24 DO PRO
- IF Y'=1
- QUIT
- +25 SET ABMCOUNT=0
- +26 SET ABMI=ABMDATE-.5
- FOR
- SET ABMI=$ORDER(^ABMDBILL(DUZ(2),"AD",ABMI))
- IF 'ABMI
- QUIT
- Begin DoDot:1
- +27 SET ABMJ=0
- FOR
- SET ABMJ=$ORDER(^ABMDBILL(DUZ(2),"AD",ABMI,ABMJ))
- IF 'ABMJ
- QUIT
- Begin DoDot:2
- +28 DO ONE
- End DoDot:2
- End DoDot:1
- +29 WRITE !!,"Finished - ",ABMCOUNT," bills changed.",!!
- +30 SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- +31 KILL ABMFLAT,ABMVTYP,ABMDATE,ABMINS,ABMZERO,ABMCOUNT,ABMOLD,ABMI,ABMJ,ABMAO
- +32 QUIT
- ONE ;EP - one bill
- +1 SET DA=ABMJ
- +2 SET ABMZERO=^ABMDBILL(DUZ(2),DA,0)
- +3 IF $PIECE(ABMZERO,"^",7)'=ABMVTYP
- QUIT
- +4 IF $PIECE(ABMZERO,"^",8)'=ABMINS
- QUIT
- +5 SET ABMDAYS=$PIECE($GET(^ABMDBILL(DUZ(2),DA,7)),"^",3)
- +6 IF +ABMDAYS<2
- SET ABMDAYS=1
- +7 SET ABMOLD=$PIECE(^ABMDBILL(DUZ(2),DA,2),U)
- +8 SET ABMOTOT=ABMORAT*ABMDAYS
- +9 IF ABMOLD'=ABMOTOT
- QUIT
- +10 SET ABMNEW=ABMFLAT*ABMDAYS
- +11 IF ABMOLD=ABMNEW
- QUIT
- +12 SET $PIECE(^ABMDBILL(DUZ(2),DA,2),U)=ABMNEW
- +13 IF $PIECE(^ABMDBILL(DUZ(2),DA,2),"^",3)=ABMOLD
- SET $PIECE(^(2),"^",3)=ABMNEW
- +14 SET ^ABMDBILL(DUZ(2),DA,"AF",$HOROLOG,.21)=DUZ_"^"_ABMOLD
- +15 WRITE "."
- +16 SET ABMCOUNT=ABMCOUNT+1
- +17 SET ABMFR("ADJ AMT")=ABMNEW-ABMOLD
- +18 SET ABMFR("USER")=DUZ
- +19 SET ABMFR("ARLOC")=$PIECE(^ABMDBILL(DUZ(2),DA,2),"^",6)
- +20 IF ABMFR("ARLOC")=""
- Begin DoDot:1
- +21 SET ABMFR("ARLOC")=$$FIND(DA)
- +22 IF ABMFR("ARLOC")=""
- QUIT
- +23 SET DIE="^ABMDBILL(DUZ(2),"
- SET DR=".26///"_ABMFR("ARLOC")
- +24 DO ^DIE
- End DoDot:1
- +25 SET ABMFR("TRAN TYPE")=503
- +26 SET ABMTEST=$$EN^BARFRAPI(.ABMFR)
- +27 QUIT
- PRO ;PROCEED
- +1 WRITE !
- +2 SET DIR(0)="Y"
- SET DIR("A")="Proceed"
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- +3 QUIT
- FIND(DA) ;find bill in A/R
- +1 SET ABMARLOC=""
- +2 SET ABMNAME=$PIECE(^ABMDBILL(DUZ(2),DA,0),U)
- SET ABMLOC=$PIECE(^(0),"^",3)
- +3 NEW I
- +4 SET I=0
- +5 FOR
- SET I=$ORDER(^BARBL(I))
- IF 'I
- QUIT
- Begin DoDot:1
- +6 IF ABMARLOC'=""
- QUIT
- +7 SET ABMNXT=$ORDER(^BARBL(I,"B",ABMNAME))
- +8 IF ABMNXT'[ABMNAME
- QUIT
- +9 SET ABMIEN=$ORDER(^BARBL(I,"B",ABMNXT,0))
- +10 IF $PIECE(^BARBL(I,ABMIEN,0),"^",17)=DA
- SET ABMARLOC=I_","_ABMIEN
- End DoDot:1
- +11 QUIT ABMARLOC
