AMHLEPRC.m

AMHLEPRC ; IHS/CMI/LAB - LOOKUP ICD9 ENTRY ;

 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010

 ;

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

 ;

START ;

 D EN^XBNEW("EN^AMHLEPRC","AMH*") ;  new everthing except AMH*

 Q

 ;

EN ; ENTRY POINT FOR ^XBNEW

 NEW AMHQ

 F  D LOOP Q:AMHQ

 Q

 ;

LOOP ;

 S AMHQ=1

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

 W !!!?20,"*******   ENTER CPT PROCEDURES  *******",!!

 W !,"[Press ENTER when finished]",!

 I $D(^AMHRPROC("AD",AMHR)) W "CPT procedure codes currently recorded for this visit:" S AMHX=0 F  S AMHX=$O(^AMHRPROC("AD",AMHR,AMHX)) Q:AMHX'=+AMHX  D

 .W !,$$VAL^XBDIQ1(9002011.04,AMHX,.01),"  ",$$VAL^XBDIQ1(9002011.04,AMHX,.019)

 W ! S DIC=81,DIC(0)="AEMQ" D ^DIC K DIC

 Q:Y<0

 ; add new mh/ss procedure

 S AMHLOOK=1

 S DIC="^AMHRPROC(",DIC(0)="L",DLAYGO=9002011.04,DIC("DR")=".02////"_AMHPAT_";.03////"_AMHR,X=+Y

 K DD,D0,DO D FILE^DICN D ^XBFMK K DLAYGO,DIADD

 K AMHLOOK

 S AMHQ=0

 Q

AMHLEPRC  ; IHS/CMI/LAB - LOOKUP ICD9 ENTRY ;

 +1       ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010

 +2       ;

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

 +4       ;

START     ;

 +1       ;  new everthing except AMH*

           DO EN^XBNEW("EN^AMHLEPRC","AMH*")

 +2        QUIT 

 +3       ;

EN        ; ENTRY POINT FOR ^XBNEW

 +1        NEW AMHQ

 +2        FOR 

               DO LOOP

               IF AMHQ

                   QUIT 

 +3        QUIT 

 +4       ;

LOOP      ;

 +1        SET AMHQ=1

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

               WRITE @IOF

 +3        WRITE !!!?20,"*******   ENTER CPT PROCEDURES  *******",!!

 +4        WRITE !,"[Press ENTER when finished]",!

 +5        IF $DATA(^AMHRPROC("AD",AMHR))

               WRITE "CPT procedure codes currently recorded for this visit:"

               SET AMHX=0

               FOR 

                   SET AMHX=$ORDER(^AMHRPROC("AD",AMHR,AMHX))

                   IF AMHX'=+AMHX

                       QUIT 

                   Begin DoDot:1

 +6                    WRITE !,$$VAL^XBDIQ1(9002011.04,AMHX,.01),"  ",$$VAL^XBDIQ1(9002011.04,AMHX,.019)

                   End DoDot:1

 +7        WRITE !

           SET DIC=81

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC

 +8        IF Y<0

               QUIT 

 +9       ; add new mh/ss procedure

 +10       SET AMHLOOK=1

 +11       SET DIC="^AMHRPROC("

           SET DIC(0)="L"

           SET DLAYGO=9002011.04

           SET DIC("DR")=".02////"_AMHPAT_";.03////"_AMHR

           SET X=+Y

 +12       KILL DD,D0,DO

           DO FILE^DICN

           DO ^XBFMK

           KILL DLAYGO,DIADD

 +13       KILL AMHLOOK

 +14       SET AMHQ=0

 +15       QUIT