ABMDE6 ; IHS/ASDST/DMJ - Page 6 - DENTAL ;
;;2.6;IHS Third Party Billing System;**2,8,10,21**;NOV 12, 2009;Build 379
;
; IHS/SD/SDR - v2.5 p9 - IM17106 - <UNDEFINED>PC1^ABMDE6 regarding
; a cross reference with no entry
; IHS/SD/SDR - v2.5 p10 - IM20380/IM20401 - fix when Edit choosen & only one option
; of if they don't select any
; IHS/SD/SDR - v2.5 p10 - IM20873 - <UNDEF>E+21^ABMDE6 error (entry not
; selected when Delete is selected)
; IHS/SD/SDR - v2.5 p11 - NPI - change for needed fields for ADA-2006 format
; field was there but not being asked
; IHS/SD/SDR - abm*2.6*2 - 3PMS10003A - modified to call ABMFEAPI
;IHS/SD/SDR - 2.6*21 - HEAT124092 - Made default revenue code 512
;
OPT9 K ABM,ABME
S ABM("TOTL")=0
D DISP
W ! S ABMP("OPT")="ADEVNJBQ" D SEL^ABMDEOPT S ABM("ACTION")=Y
I "AVDE"'[$E(Y) S:$D(ABMP("DDL"))&($E(ABMP("PAGE"),$L(ABMP("PAGE")))=6) ABMP("QUIT")="" G XIT
G XIT:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
S ABM("DO")=$S($E(Y)="V":"V1",1:"A")
K DA D @ABM("DO")
G OPT9
;
DISP ;PAGE DISPLAY
K ABMZ
S ABMZ("TITL")="DENTAL SERVICES",ABMZ("PG")="6"
S ABMZ("ITEM")="Dental (ADA Code)"
I $D(ABMP("DDL")),$Y>(IOSL-9) D PAUSE^ABMDE1 G:$D(DUOUT)!$D(DTOUT)!$D(DIROUT) XIT I 1
E D SUM^ABMDE1
;
D ^ABMDE6X
S ABMZ("SUB")=33
D HD G LOOP
HD ;
W !?4,"VISIT",?56,"ORAL",?61,"OPER"
W !?4,"DATE",?11," DENTAL SERVICE",?56,"CAV",?61,"SITE",?66,"SURF",?73,"CHARGE"
W !?4,"=====",?11,"============================================",?56,"====",?61,"====",?66,"=====",?73,"======"
Q
LOOP ;LOOP THROUGH LINE ITEMS
S (ABMZ("LNUM"),ABMZ(1),ABM)=0
S ABMZ("NUM")=0
F S ABM=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),33,"C",ABM)) Q:'ABM D
.S ABM("X")=0
.F S ABM("X")=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),33,"C",ABM,ABM("X"))) Q:'ABM("X") D
..I '$D(^ABMDCLM(DUZ(2),ABMP("CDFN"),33,ABM("X"),0)) K ^ABMDCLM(DUZ(2),ABMP("CDFN"),33,"C",ABM,ABM("X")) Q
..D PC1
W !?72,"=======",!?70,$J(("$"_$FN(ABM("TOTL"),",",2)),9)
I +$O(ABME(0)) S ABME("CONT")="" D ^ABMDERR K ABME("CONT")
G XIT
;
PC1 S ABM("X0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),33,ABM("X"),0)
S ABMZ("NUM")=+ABMZ("NUM")+1
S ABMZ(ABMZ("NUM"))=$P(^AUTTADA(+ABM("X0"),0),U)_U_ABM("X")
EOP I $Y>(IOSL-5) D PAUSE^ABMDE1,HD
W !,"[",ABMZ("NUM"),"]"
I $P(ABM("X0"),U,7)]"" W ?4,$E($P(ABM("X0"),U,7),4,5)_"/"_$E($P(ABM("X0"),U,7),6,7)
W ?11,$P(^AUTTADA(+ABM("X0"),0),U)," ",$E($P(^(0),U,2),1,39)
W ?57,$P($G(ABM("X0")),U,11) ;oral cavity
W ?62 W $S($P(ABM("X0"),U,5)="":"",$D(^ADEOPS($P(ABM("X0"),U,5),88)):$P(^(88),U),1:"")
W ?66,$J($P(ABM("X0"),U,6),4)
S ABM("ITMTOTL")=$P(ABM("X0"),U,8)*$P(ABM("X0"),U,9)
S:'+ABM("ITMTOTL") ABM("ITMTOTL")=$P(ABM("X0"),U,8)
W ?73,$J($FN(ABM("ITMTOTL"),",",2),6)
S ABM("TOTL")=ABM("TOTL")+ABM("ITMTOTL")
Q
;
XIT K ABM
Q
;
V1 S ABMZ("TITL")="DENTAL VIEW OPTION" D SUM^ABMDE1
D ^ABMDERR
Q
A ;ADD LINE ITEM
K DA S DA(1)=ABMP("CDFN")
I $E(ABM("ACTION"))="A" D
.S DIC="^AUTTADA(",DIC(0)="AEMQ"
.D ^DIC Q:+Y<0
.S X=$P(Y,U)
.S DIC("P")=$P(^DD(9002274.3,33,0),U,2)
.S DIC="^ABMDCLM(DUZ(2),DA(1),33,"
.;K DD,DO D FILE^DICN Q:+Y<0 S DA=+Y ;abm*2.6*8 5010
.K DD,DO D FILE^DICN Q:+Y<0 S (DA,ABMXANS)=+Y ;abm*2.6*8 5010
E ;EDIT LINE ITEM
I $E(ABM("ACTION"))="D" D Q
.K DIR S DIR(0)="LO^1:"_ABMZ("NUM")_":0"
.S DIR("?")="Enter the Sequence Number of "_ABMZ("ITEM")_" to Delete"
.S DIR("A")="Sequence Number to DELETE"
.D ^DIR K DIR
.W !
.S ABMXANS=Y
.;Q:ABMXANS="" ;abm*2.6*10 HEAT69379
.Q:ABMXANS=""!$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) ;abm*2.6*10 HEAT69379
.F ABM("I")=1:1 S ABM=$P(ABMXANS,",",ABM("I")) Q:ABM="" D
..I $G(ABMX("ANS"))'="" S ABMX("ANS")=ABMX("ANS")_","_$P(ABMZ(ABM),U)
..E S ABMX("ANS")=$P(ABMZ(ABM),U)
.K DIR S DIR(0)="YO",DIR("A")="Do you wish "_ABMX("ANS")_" DELETED"
.D ^DIR K DIR
.Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
.I Y=1 D
..F ABM("I")=1:1 S ABM=$P(ABMXANS,",",ABM("I")) Q:ABM="" D
...S DA(1)=ABMP("CDFN")
...S DA=$P(ABMZ(ABM),U,2)
...S DIK="^ABMDCLM(DUZ(2),"_DA(1)_",33,"
...D ^DIK
;
I $E(ABM("ACTION"))="E" D
.;I ABMZ("NUM")=1 S (DA,Y)=$P(ABMZ(1),U,2) Q ;abm*2.6*8
.I ABMZ("NUM")=1 S (DA,Y,ABMXANS)=$P(ABMZ(1),U,2) Q ;abm*2.6*8
.K DIR S DIR(0)="NO^1:"_ABMZ("NUM")_":0"
.S DIR("?")="Enter the Sequence Number of "_ABMZ("ITEM")_" to Edit",DIR("A")="Sequence Number to EDIT"
.D ^DIR K DIR
.G XIT:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(+Y'>0)
.;W !!!,"[",+Y,"] ",$P(ABMZ(+Y),U) S DA=$P(ABMZ(+Y),U,2) ;abm*2.6*8 5010
.W !!!,"[",+Y,"] ",$P(ABMZ(+Y),U) S (DA,ABMXANS)=$P(ABMZ(+Y),U,2) ;abm*2.6*8 5010
E2 ;
G XIT:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(+Y'>0)
S ABMZ("ADACODE")=$P($G(^ABMDCLM(DUZ(2),DA(1),33,DA,0)),U)
S ABMZ("DCD")=$P(^AUTTADA(ABMZ("ADACODE"),0),U)
;S ABMZ("CHRG")=+$P($G(^ABMDFEE(ABMP("FEE"),21,1_ABMZ("DCD"),0)),"^",2) ;abm*2.6*2 3PMS10003A
S ABMZ("CHRG")=+$P($$ONE^ABMFEAPI(ABMP("FEE"),21,1_ABMZ("DCD"),ABMP("VDT")),U) ;abm*2.6*2 3PMS10003A
S DIE="^ABMDCLM(DUZ(2),"_DA(1)_",33,"
I $P(^ABMDEXP(ABMP("EXP"),0),"^",1)["UB" D Q:$D(Y)
.;S DR="W !;.02" D ^DIE ;abm*2.6*21 IHS/SD/SDR HEAT124092
.S DR="W !;.02//512" D ^DIE ;abm*2.6*21 IHS/SD/SDR HEAT124092
S DR="W !;.07//"_ABMP("VISTDT") D ^DIE Q:$D(Y)
S ABMZ("OPSITE")=1 S:$P(^AUTTADA(ABMZ("ADACODE"),0),"^",9)="n" ABMZ("OPSITE")=0
I ABMZ("OPSITE") D Q:$D(Y)
.S DR="W !;.05;W !;.06;W !;.11"
.D ^DIE
;D DX^ABMDEMLC S DR=".04///"_Y(0) D ^DIE Q:$D(Y) ;abm*2.6*10 ICD10 002I
D DX^ABMDEMLC I +$G(Y(0)) S DR=".04///"_Y(0) D ^DIE Q:$D(Y) ;abm*2.6*10 ICD10 002I
S DR=".09//1" D ^DIE Q:$D(Y)
S DR=".08//"_ABMZ("CHRG") D ^DIE Q:$D(Y)
S DR=".17///M" D ^DIE
D PROV ;abm*2.6*8 5010
Q
;start new code abm*2.6*8 5010
PROV ;EP
I +$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMZ("SUB"),DA,"P",0))>0 D
.W !
.S ABMIEN=0
.F S ABMIEN=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMZ("SUB"),DA,"P",ABMIEN)) Q:+ABMIEN=0 D
..W !?5,$P($G(^VA(200,$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMZ("SUB"),DA,"P",ABMIEN,0)),U),0)),U)
..W ?40,$S($P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMZ("SUB"),DA,"P",ABMIEN,0)),U,2)="R":"RENDERING",$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMZ("SUB"),DA,"P",ABMIEN,0)),U,2)="D":"ORDERING",1:"")
.W !
K DIC,DR,DIE,DA
S DA(2)=ABMP("CDFN")
S DA(1)=ABMXANS
S DIC="^ABMDCLM(DUZ(2),"_DA(2)_","_ABMZ("SUB")_","_DA(1)_",""P"","
S DIC(0)="AELMQ"
S ABMFLNM="9002274.30"_$G(ABMZ("SUB"))
S DIC("P")=$P($G(^DD(ABMFLNM,.18,0)),U,2)
Q:DIC("P")=""
S DIC("DR")=".01;.02//RENDERING"
I +$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMZ("SUB"),DA(1),"P","C","R",0))>0 S DIC("DR")=".01;.02//ORDERING"
D ^DIC
K DIC,DR,DIE,DA
I +Y>0,(+$P(Y,U,3)=0) D
.K DIE,DA,DR
.S DA(2)=ABMP("CDFN")
.S DA(1)=ABMXANS
.S DIE="^ABMDCLM(DUZ(2),"_DA(2)_","_ABMZ("SUB")_","_DA(1)_",""P"","
.S DA=+Y
.S DR=".01//;.02"
.D ^DIE
Q
;end new code abm*2.6*8
ABMDE6 ; IHS/ASDST/DMJ - Page 6 - DENTAL ;
+1 ;;2.6;IHS Third Party Billing System;**2,8,10,21**;NOV 12, 2009;Build 379
+2 ;
+3 ; IHS/SD/SDR - v2.5 p9 - IM17106 - <UNDEFINED>PC1^ABMDE6 regarding
+4 ; a cross reference with no entry
+5 ; IHS/SD/SDR - v2.5 p10 - IM20380/IM20401 - fix when Edit choosen & only one option
+6 ; of if they don't select any
+7 ; IHS/SD/SDR - v2.5 p10 - IM20873 - <UNDEF>E+21^ABMDE6 error (entry not
+8 ; selected when Delete is selected)
+9 ; IHS/SD/SDR - v2.5 p11 - NPI - change for needed fields for ADA-2006 format
+10 ; field was there but not being asked
+11 ; IHS/SD/SDR - abm*2.6*2 - 3PMS10003A - modified to call ABMFEAPI
+12 ;IHS/SD/SDR - 2.6*21 - HEAT124092 - Made default revenue code 512
+13 ;
OPT9 KILL ABM,ABME
+1 SET ABM("TOTL")=0
+2 DO DISP
+3 WRITE !
SET ABMP("OPT")="ADEVNJBQ"
DO SEL^ABMDEOPT
SET ABM("ACTION")=Y
+4 IF "AVDE"'[$EXTRACT(Y)
IF $DATA(ABMP("DDL"))&($EXTRACT(ABMP("PAGE"),$LENGTH(ABMP("PAGE")))=6)
SET ABMP("QUIT")=""
GOTO XIT
+5 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO XIT
+6 SET ABM("DO")=$SELECT($EXTRACT(Y)="V":"V1",1:"A")
+7 KILL DA
DO @ABM("DO")
+8 GOTO OPT9
+9 ;
DISP ;PAGE DISPLAY
+1 KILL ABMZ
+2 SET ABMZ("TITL")="DENTAL SERVICES"
SET ABMZ("PG")="6"
+3 SET ABMZ("ITEM")="Dental (ADA Code)"
+4 IF $DATA(ABMP("DDL"))
IF $Y>(IOSL-9)
DO PAUSE^ABMDE1
IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
GOTO XIT
IF 1
+5 IF '$TEST
DO SUM^ABMDE1
+6 ;
+7 DO ^ABMDE6X
+8 SET ABMZ("SUB")=33
+9 DO HD
GOTO LOOP
HD ;
+1 WRITE !?4,"VISIT",?56,"ORAL",?61,"OPER"
+2 WRITE !?4,"DATE",?11," DENTAL SERVICE",?56,"CAV",?61,"SITE",?66,"SURF",?73,"CHARGE"
+3 WRITE !?4,"=====",?11,"============================================",?56,"====",?61,"====",?66,"=====",?73,"======"
+4 QUIT
LOOP ;LOOP THROUGH LINE ITEMS
+1 SET (ABMZ("LNUM"),ABMZ(1),ABM)=0
+2 SET ABMZ("NUM")=0
+3 FOR
SET ABM=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),33,"C",ABM))
IF 'ABM
QUIT
Begin DoDot:1
+4 SET ABM("X")=0
+5 FOR
SET ABM("X")=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),33,"C",ABM,ABM("X")))
IF 'ABM("X")
QUIT
Begin DoDot:2
+6 IF '$DATA(^ABMDCLM(DUZ(2),ABMP("CDFN"),33,ABM("X"),0))
KILL ^ABMDCLM(DUZ(2),ABMP("CDFN"),33,"C",ABM,ABM("X"))
QUIT
+7 DO PC1
End DoDot:2
End DoDot:1
+8 WRITE !?72,"=======",!?70,$JUSTIFY(("$"_$FNUMBER(ABM("TOTL"),",",2)),9)
+9 IF +$ORDER(ABME(0))
SET ABME("CONT")=""
DO ^ABMDERR
KILL ABME("CONT")
+10 GOTO XIT
+11 ;
PC1 SET ABM("X0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),33,ABM("X"),0)
+1 SET ABMZ("NUM")=+ABMZ("NUM")+1
+2 SET ABMZ(ABMZ("NUM"))=$PIECE(^AUTTADA(+ABM("X0"),0),U)_U_ABM("X")
EOP IF $Y>(IOSL-5)
DO PAUSE^ABMDE1
DO HD
+1 WRITE !,"[",ABMZ("NUM"),"]"
+2 IF $PIECE(ABM("X0"),U,7)]""
WRITE ?4,$EXTRACT($PIECE(ABM("X0"),U,7),4,5)_"/"_$EXTRACT($PIECE(ABM("X0"),U,7),6,7)
+3 WRITE ?11,$PIECE(^AUTTADA(+ABM("X0"),0),U)," ",$EXTRACT($PIECE(^(0),U,2),1,39)
+4 ;oral cavity
WRITE ?57,$PIECE($GET(ABM("X0")),U,11)
+5 WRITE ?62
WRITE $SELECT($PIECE(ABM("X0"),U,5)="":"",$DATA(^ADEOPS($PIECE(ABM("X0"),U,5),88)):$PIECE(^(88),U),1:"")
+6 WRITE ?66,$JUSTIFY($PIECE(ABM("X0"),U,6),4)
+7 SET ABM("ITMTOTL")=$PIECE(ABM("X0"),U,8)*$PIECE(ABM("X0"),U,9)
+8 IF '+ABM("ITMTOTL")
SET ABM("ITMTOTL")=$PIECE(ABM("X0"),U,8)
+9 WRITE ?73,$JUSTIFY($FNUMBER(ABM("ITMTOTL"),",",2),6)
+10 SET ABM("TOTL")=ABM("TOTL")+ABM("ITMTOTL")
+11 QUIT
+12 ;
XIT KILL ABM
+1 QUIT
+2 ;
V1 SET ABMZ("TITL")="DENTAL VIEW OPTION"
DO SUM^ABMDE1
+1 DO ^ABMDERR
+2 QUIT
A ;ADD LINE ITEM
+1 KILL DA
SET DA(1)=ABMP("CDFN")
+2 IF $EXTRACT(ABM("ACTION"))="A"
Begin DoDot:1
+3 SET DIC="^AUTTADA("
SET DIC(0)="AEMQ"
+4 DO ^DIC
IF +Y<0
QUIT
+5 SET X=$PIECE(Y,U)
+6 SET DIC("P")=$PIECE(^DD(9002274.3,33,0),U,2)
+7 SET DIC="^ABMDCLM(DUZ(2),DA(1),33,"
+8 ;K DD,DO D FILE^DICN Q:+Y<0 S DA=+Y ;abm*2.6*8 5010
+9 ;abm*2.6*8 5010
KILL DD,DO
DO FILE^DICN
IF +Y<0
QUIT
SET (DA,ABMXANS)=+Y
End DoDot:1
E ;EDIT LINE ITEM
+1 IF $EXTRACT(ABM("ACTION"))="D"
Begin DoDot:1
+2 KILL DIR
SET DIR(0)="LO^1:"_ABMZ("NUM")_":0"
+3 SET DIR("?")="Enter the Sequence Number of "_ABMZ("ITEM")_" to Delete"
+4 SET DIR("A")="Sequence Number to DELETE"
+5 DO ^DIR
KILL DIR
+6 WRITE !
+7 SET ABMXANS=Y
+8 ;Q:ABMXANS="" ;abm*2.6*10 HEAT69379
+9 ;abm*2.6*10 HEAT69379
IF ABMXANS=""!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT
+10 FOR ABM("I")=1:1
SET ABM=$PIECE(ABMXANS,",",ABM("I"))
IF ABM=""
QUIT
Begin DoDot:2
+11 IF $GET(ABMX("ANS"))'=""
SET ABMX("ANS")=ABMX("ANS")_","_$PIECE(ABMZ(ABM),U)
+12 IF '$TEST
SET ABMX("ANS")=$PIECE(ABMZ(ABM),U)
End DoDot:2
+13 KILL DIR
SET DIR(0)="YO"
SET DIR("A")="Do you wish "_ABMX("ANS")_" DELETED"
+14 DO ^DIR
KILL DIR
+15 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT
+16 IF Y=1
Begin DoDot:2
+17 FOR ABM("I")=1:1
SET ABM=$PIECE(ABMXANS,",",ABM("I"))
IF ABM=""
QUIT
Begin DoDot:3
+18 SET DA(1)=ABMP("CDFN")
+19 SET DA=$PIECE(ABMZ(ABM),U,2)
+20 SET DIK="^ABMDCLM(DUZ(2),"_DA(1)_",33,"
+21 DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+22 ;
+23 IF $EXTRACT(ABM("ACTION"))="E"
Begin DoDot:1
+24 ;I ABMZ("NUM")=1 S (DA,Y)=$P(ABMZ(1),U,2) Q ;abm*2.6*8
+25 ;abm*2.6*8
IF ABMZ("NUM")=1
SET (DA,Y,ABMXANS)=$PIECE(ABMZ(1),U,2)
QUIT
+26 KILL DIR
SET DIR(0)="NO^1:"_ABMZ("NUM")_":0"
+27 SET DIR("?")="Enter the Sequence Number of "_ABMZ("ITEM")_" to Edit"
SET DIR("A")="Sequence Number to EDIT"
+28 DO ^DIR
KILL DIR
+29 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)!(+Y'>0)
GOTO XIT
+30 ;W !!!,"[",+Y,"] ",$P(ABMZ(+Y),U) S DA=$P(ABMZ(+Y),U,2) ;abm*2.6*8 5010
+31 ;abm*2.6*8 5010
WRITE !!!,"[",+Y,"] ",$PIECE(ABMZ(+Y),U)
SET (DA,ABMXANS)=$PIECE(ABMZ(+Y),U,2)
End DoDot:1
E2 ;
+1 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)!(+Y'>0)
GOTO XIT
+2 SET ABMZ("ADACODE")=$PIECE($GET(^ABMDCLM(DUZ(2),DA(1),33,DA,0)),U)
+3 SET ABMZ("DCD")=$PIECE(^AUTTADA(ABMZ("ADACODE"),0),U)
+4 ;S ABMZ("CHRG")=+$P($G(^ABMDFEE(ABMP("FEE"),21,1_ABMZ("DCD"),0)),"^",2) ;abm*2.6*2 3PMS10003A
+5 ;abm*2.6*2 3PMS10003A
SET ABMZ("CHRG")=+$PIECE($$ONE^ABMFEAPI(ABMP("FEE"),21,1_ABMZ("DCD"),ABMP("VDT")),U)
+6 SET DIE="^ABMDCLM(DUZ(2),"_DA(1)_",33,"
+7 IF $PIECE(^ABMDEXP(ABMP("EXP"),0),"^",1)["UB"
Begin DoDot:1
+8 ;S DR="W !;.02" D ^DIE ;abm*2.6*21 IHS/SD/SDR HEAT124092
+9 ;abm*2.6*21 IHS/SD/SDR HEAT124092
SET DR="W !;.02//512"
DO ^DIE
End DoDot:1
IF $DATA(Y)
QUIT
+10 SET DR="W !;.07//"_ABMP("VISTDT")
DO ^DIE
IF $DATA(Y)
QUIT
+11 SET ABMZ("OPSITE")=1
IF $PIECE(^AUTTADA(ABMZ("ADACODE"),0),"^",9)="n"
SET ABMZ("OPSITE")=0
+12 IF ABMZ("OPSITE")
Begin DoDot:1
+13 SET DR="W !;.05;W !;.06;W !;.11"
+14 DO ^DIE
End DoDot:1
IF $DATA(Y)
QUIT
+15 ;D DX^ABMDEMLC S DR=".04///"_Y(0) D ^DIE Q:$D(Y) ;abm*2.6*10 ICD10 002I
+16 ;abm*2.6*10 ICD10 002I
DO DX^ABMDEMLC
IF +$GET(Y(0))
SET DR=".04///"_Y(0)
DO ^DIE
IF $DATA(Y)
QUIT
+17 SET DR=".09//1"
DO ^DIE
IF $DATA(Y)
QUIT
+18 SET DR=".08//"_ABMZ("CHRG")
DO ^DIE
IF $DATA(Y)
QUIT
+19 SET DR=".17///M"
DO ^DIE
+20 ;abm*2.6*8 5010
DO PROV
+21 QUIT
+22 ;start new code abm*2.6*8 5010
PROV ;EP
+1 IF +$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMZ("SUB"),DA,"P",0))>0
Begin DoDot:1
+2 WRITE !
+3 SET ABMIEN=0
+4 FOR
SET ABMIEN=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMZ("SUB"),DA,"P",ABMIEN))
IF +ABMIEN=0
QUIT
Begin DoDot:2
+5 WRITE !?5,$PIECE($GET(^VA(200,$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMZ("SUB"),DA,"P",ABMIEN,0)),U),0)),U)
+6 WRITE ?40,$SELECT($PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMZ("SUB"),DA,"P",ABMIEN,0)),U,2)="R":"RENDERING",$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMZ("SUB"),DA,"P",ABMIEN,0)),U,2)="D":"ORDERING",1:"")
End DoDot:2
+7 WRITE !
End DoDot:1
+8 KILL DIC,DR,DIE,DA
+9 SET DA(2)=ABMP("CDFN")
+10 SET DA(1)=ABMXANS
+11 SET DIC="^ABMDCLM(DUZ(2),"_DA(2)_","_ABMZ("SUB")_","_DA(1)_",""P"","
+12 SET DIC(0)="AELMQ"
+13 SET ABMFLNM="9002274.30"_$GET(ABMZ("SUB"))
+14 SET DIC("P")=$PIECE($GET(^DD(ABMFLNM,.18,0)),U,2)
+15 IF DIC("P")=""
QUIT
+16 SET DIC("DR")=".01;.02//RENDERING"
+17 IF +$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMZ("SUB"),DA(1),"P","C","R",0))>0
SET DIC("DR")=".01;.02//ORDERING"
+18 DO ^DIC
+19 KILL DIC,DR,DIE,DA
+20 IF +Y>0
IF (+$PIECE(Y,U,3)=0)
Begin DoDot:1
+21 KILL DIE,DA,DR
+22 SET DA(2)=ABMP("CDFN")
+23 SET DA(1)=ABMXANS
+24 SET DIE="^ABMDCLM(DUZ(2),"_DA(2)_","_ABMZ("SUB")_","_DA(1)_",""P"","
+25 SET DA=+Y
+26 SET DR=".01//;.02"
+27 DO ^DIE
End DoDot:1
+28 QUIT
+29 ;end new code abm*2.6*8
