Routine: ACDWCD80

ACDWCD80 ;IHS/ADC/EDE/KML - CLIENT DTX OP FOR IR;

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

 ;*********************************************************************

 ;//^ACDWDRV3, ^ACDWIIF

 ;*********************************************************************

 ;S ACDP1="" F  S ACDP1=$O(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDP1)) Q:ACDP1=""  F ACDP2=0:0 S ACDP2=$O(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDP1,ACDP2)) Q:'ACDP2  S ACDDA=ACDP2 D ^ACDWIIF S ACDDA=^ACDIIF(ACDP2,"BWP") D ^ACDWVIS D P1

 S ACDP1=""

 F  S ACDP1=$O(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDP1)) Q:ACDP1=""  D  Q:$D(DIRUT)

 . F ACDP2=0:0 S ACDP2=$O(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDP1,ACDP2)) Q:'ACDP2  D  Q:$D(DIRUT)

 .. S ACDDA=ACDP2 D ^ACDWIIF S ACDDA=^ACDIIF(ACDP2,"BWP") D ^ACDWVIS D P1

 .. Q

. Q

 D ^ACDWK Q

P1 ;Output

 D F W !!,"CLIENT NAME:",?40,ACDDFN

 D F W !!,"VISIT DATE:",?40,ACDCLIV

 D F W !,"COMPONENT:",?40,ACDCOMCL," / ",ACDCOMTL

 D F W !,"PROVIDER:",?40,ACDPROV

 D F W !,"PRIMARY PROBLEM:",?40,ACDPROBP

 D F W !,"OTHER PROBLEMS:" S ACDLP="" F  S ACDLP=$O(ACDPTA(ACDLP)) Q:ACDLP=""  W ?40,ACDLP D F W !

 W !,"..........................................",!

F ;Form feed

 Q:$D(DIRUT)

 I $Y+4>IOSL D F^ACDWUTL

ACDWCD80  ;IHS/ADC/EDE/KML - CLIENT DTX OP FOR IR;

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

 +2       ;*********************************************************************

 +3       ;//^ACDWDRV3, ^ACDWIIF

 +4       ;*********************************************************************

 +5       ;S ACDP1="" F  S ACDP1=$O(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDP1)) Q:ACDP1=""  F ACDP2=0:0 S ACDP2=$O(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDP1,ACDP2)) Q:'ACDP2  S ACDDA=ACDP2 D ^ACDWIIF S ACDDA=^ACDIIF(ACDP2,"BWP") D ^ACDWVIS D P1

 +6        SET ACDP1=""

 +7        FOR

               SET ACDP1=$ORDER(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDP1))

               IF ACDP1=""

                   QUIT

               Begin DoDot:1

 +8                FOR ACDP2=0:0

                       SET ACDP2=$ORDER(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDP1,ACDP2))

                       IF 'ACDP2

                           QUIT

                       Begin DoDot:2

 +9                        SET ACDDA=ACDP2

                           DO ^ACDWIIF

                           SET ACDDA=^ACDIIF(ACDP2,"BWP")

                           DO ^ACDWVIS

                           DO P1

 +10                       QUIT

                       End DoDot:2

                       IF $DATA(DIRUT)

                           QUIT

 +11               QUIT

               End DoDot:1

               IF $DATA(DIRUT)

                   QUIT

 +12       DO ^ACDWK

           QUIT

P1        ;Output

 +1        DO F

           WRITE !!,"CLIENT NAME:",?40,ACDDFN

 +2        DO F

           WRITE !!,"VISIT DATE:",?40,ACDCLIV

 +3        DO F

           WRITE !,"COMPONENT:",?40,ACDCOMCL," / ",ACDCOMTL

 +4        DO F

           WRITE !,"PROVIDER:",?40,ACDPROV

 +5        DO F

           WRITE !,"PRIMARY PROBLEM:",?40,ACDPROBP

 +6        DO F

           WRITE !,"OTHER PROBLEMS:"

           SET ACDLP=""

FOR

               SET ACDLP=$ORDER(ACDPTA(ACDLP))

               IF ACDLP=""

                   QUIT

               WRITE ?40,ACDLP

               DO F

               WRITE !

 +7        WRITE !,"..........................................",!

 +8       ;

 +9        QUIT

F         ;Form feed

 +1        IF $DATA(DIRUT)

               QUIT

 +2        IF $Y+4>IOSL

               DO F^ACDWUTL

ACDWCD80.m