Routine: BMCDXADD

BMCDXADD ; IHS/PHXAO/TMJ - ADD DXs ;

 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006

 ; This routine looks up an entry in the ICD DIAGNOSIS file (80).

START ;

 D EN^XBNEW("EN^BMCICDLK","BMC*") ;  new everthing except BMC*

EN ; ENTRY POINT FOR ^XBNEW

 NEW BMCQ

 F  D LOOP Q:BMCQ

LOOP ;

 S BMCQ=1

 W:$G(IOF)'="" @IOF

 S DIC=80,DIC(0)="AEMQ" D DIC^BMCFMC

 Q:Y<0

 ; add new rcis diagnosis for dx just looked up

 S BMCLOOK=1

 S DIC="^BMCDX(",DIC(0)="L",DLAYGO=90001.01,DIC("DR")=".02////"_BMCDFN_";.03////"_BMCRIEN,X=+Y

 D FILE^BMCFMC

 K BMCLOOK

 Q:Y<0

 ; add other fields to dx just created

 S DIE="^BMCDX(",DA=+Y,DR=$S(BMCMODE="A":".04////P",1:".04")_";.05;.06"

 D DIE^BMCFMC

BMCDXADD  ; IHS/PHXAO/TMJ - ADD DXs ;

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006

 +2       ;

 +3       ; This routine looks up an entry in the ICD DIAGNOSIS file (80).

 +4       ;

START     ;

 +1       ;  new everthing except BMC*

           DO EN^XBNEW("EN^BMCICDLK","BMC*")

 +2        QUIT

 +3       ;

EN        ; ENTRY POINT FOR ^XBNEW

 +1        NEW BMCQ

 +2        FOR

               DO LOOP

               IF BMCQ

                   QUIT

 +3        QUIT

 +4       ;

LOOP      ;

 +1        SET BMCQ=1

 +2        IF $GET(IOF)'=""

               WRITE @IOF

 +3        SET DIC=80

           SET DIC(0)="AEMQ"

           DO DIC^BMCFMC

 +4        IF Y<0

               QUIT

 +5       ; add new rcis diagnosis for dx just looked up

 +6        SET BMCLOOK=1

 +7        SET DIC="^BMCDX("

           SET DIC(0)="L"

           SET DLAYGO=90001.01

           SET DIC("DR")=".02////"_BMCDFN_";.03////"_BMCRIEN

           SET X=+Y

 +8        DO FILE^BMCFMC

 +9        KILL BMCLOOK

 +10       IF Y<0

               QUIT

 +11      ; add other fields to dx just created

 +12       SET DIE="^BMCDX("

           SET DA=+Y

           SET DR=$SELECT(BMCMODE="A":".04////P",1:".04")_";.05;.06"

 +13       DO DIE^BMCFMC

 +14       QUIT

BMCDXADD.m