- 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
