ACDRR1.m

ACDRR1 ;IHS/ADC/EDE/KML - SUBSTANCE USE REPORT;

 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998

 ;

 ; This routine prints a patient problem summary report for

 ; a specified time frame.

 ;

START ;

 D INIT

 Q:ACDQ

 D DBQUE

 Q

 ;

INIT ;

 S ACDQ=1

 W !,"This routine prints a patient problem summary report for a specified time frame",!

 S ACDAIEN=$O(^ACDPROB("B","ALCOHOL",0))

 Q:'ACDAIEN

 S ACDDIEN=$O(^ACDPROB("B","DRUGS",0))

 Q:'ACDDIEN

 D GETDTR^ACDDEU ;              get acddtlo & acddthi

 Q:ACDQ

 S ACDQ=0

 Q

 ;

DBQUE ; call to XBDBQUE

 S ACDQ=1

 W ! S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to",DIR("B")="P" K DA D ^DIR K DIR

 Q:$D(DIRUT)

 I Y="B" D BROWSE Q

 S XBRP="^ACDRR1P",XBRC="^ACDRR1C",XBRX="EOJ^ACDRR1",XBNS="ACD"

 D ^XBDBQUE

 Q

 ;

BROWSE ;

 S XBRP="VIEWR^XBLM(""^ACDRR1P"")"

 S XBRC="^ACDRR1C",XBRX="EOJ^ACDRR1",XBIOP=0

 D ^XBDBQUE

 Q

 ;

EOJ ; EP-CALLED BY XBDBQUE

 W:IOST["P-" @IOF

 ;K ^TMP("ACDRR1",ACDJOB,ACDBTH)

 K %,%1,%2,%3,%DT,F,M,V,W,X,Y,Z

 K ACDBT,ACDBTH,ACDCMBO,ACDDIEN,ACDDTHI,ACDDTLO,ACDET,ACDJOB,ACDPRIEN,ACDTRIBE,ACDSAVEX

 Q

ACDRR1    ;IHS/ADC/EDE/KML - SUBSTANCE USE REPORT;

 +1       ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998

 +2       ;

 +3       ; This routine prints a patient problem summary report for

 +4       ; a specified time frame.

 +5       ;

START     ;

 +1        DO INIT

 +2        IF ACDQ

               QUIT 

 +3        DO DBQUE

 +4        QUIT 

 +5       ;

INIT      ;

 +1        SET ACDQ=1

 +2        WRITE !,"This routine prints a patient problem summary report for a specified time frame",!

 +3        SET ACDAIEN=$ORDER(^ACDPROB("B","ALCOHOL",0))

 +4        IF 'ACDAIEN

               QUIT 

 +5        SET ACDDIEN=$ORDER(^ACDPROB("B","DRUGS",0))

 +6        IF 'ACDDIEN

               QUIT 

 +7       ;              get acddtlo & acddthi

           DO GETDTR^ACDDEU

 +8        IF ACDQ

               QUIT 

 +9        SET ACDQ=0

 +10       QUIT 

 +11      ;

DBQUE     ; call to XBDBQUE

 +1        SET ACDQ=1

 +2        WRITE !

           SET DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen"

           SET DIR("A")="Do you wish to"

           SET DIR("B")="P"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               QUIT 

 +4        IF Y="B"

               DO BROWSE

               QUIT 

 +5        SET XBRP="^ACDRR1P"

           SET XBRC="^ACDRR1C"

           SET XBRX="EOJ^ACDRR1"

           SET XBNS="ACD"

 +6        DO ^XBDBQUE

 +7        QUIT 

 +8       ;

BROWSE    ;

 +1        SET XBRP="VIEWR^XBLM(""^ACDRR1P"")"

 +2        SET XBRC="^ACDRR1C"

           SET XBRX="EOJ^ACDRR1"

           SET XBIOP=0

 +3        DO ^XBDBQUE

 +4        QUIT 

 +5       ;

EOJ       ; EP-CALLED BY XBDBQUE

 +1        IF IOST["P-"

               WRITE @IOF

 +2       ;K ^TMP("ACDRR1",ACDJOB,ACDBTH)

 +3        KILL %,%1,%2,%3,%DT,F,M,V,W,X,Y,Z

 +4        KILL ACDBT,ACDBTH,ACDCMBO,ACDDIEN,ACDDTHI,ACDDTLO,ACDET,ACDJOB,ACDPRIEN,ACDTRIBE,ACDSAVEX

 +5        QUIT