ACDFUL1.m

ACDFUL1 ;IHS/ADC/EDE/KML - IHS-SMBD/MLQ CDMIS FU LIST PART 1;

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

 ;;Extract date selected in ACDFUL2

 ;

 ; need an exclusive because ^ACDFUL2 calls FILE^DICN

 D ^XBNEW("EN^ACDFUL1:ACD*")

 Q

 ;

EN ; EP - FOR EXCLUSIVE NEW

 S X1=ACDBEGDT,X2=-180 D C^%DTC

 S ACD6MO=$E(X,1,5)_"00",ACD6MOE=$E(X,1,5)_"99"

 S X1=ACDBEGDT,X2=-365 D C^%DTC

 S ACD12MO=$E(X,1,5)_"00",ACD12MOE=$E(X,1,5)_"99"

 S X1=ACDBEGDT,X2=-545 D C^%DTC

 S ACD18MO=$E(X,1,5)_"00",ACD18MOE=$E(X,1,5)_"99"

 S X1=ACDBEGDT,X2=-730 D C^%DTC

 S ACD24MO=$E(X,1,5)_"00",ACD24MOE=$E(X,1,5)_"99"

 W !,"Records Due for Follow Up on ",ACDBGMDY," will be extracted"

 D WAIT^DICD

 S DIK="^ACDWORK("

 S DA=0 F ACDIX=0:0 S DA=$O(^ACDWORK(DA)) Q:'+DA  D ^DIK

 K ACDBEGDT,ACDIX,DA

 G ^ACDFUL2

 Q

ACDFUL1   ;IHS/ADC/EDE/KML - IHS-SMBD/MLQ CDMIS FU LIST PART 1;

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

 +2       ;;Extract date selected in ACDFUL2

 +3       ;

 +4       ; need an exclusive because ^ACDFUL2 calls FILE^DICN

 +5        DO ^XBNEW("EN^ACDFUL1:ACD*")

 +6        QUIT 

 +7       ;

EN        ; EP - FOR EXCLUSIVE NEW

 +1        SET X1=ACDBEGDT

           SET X2=-180

           DO C^%DTC

 +2        SET ACD6MO=$EXTRACT(X,1,5)_"00"

           SET ACD6MOE=$EXTRACT(X,1,5)_"99"

 +3        SET X1=ACDBEGDT

           SET X2=-365

           DO C^%DTC

 +4        SET ACD12MO=$EXTRACT(X,1,5)_"00"

           SET ACD12MOE=$EXTRACT(X,1,5)_"99"

 +5        SET X1=ACDBEGDT

           SET X2=-545

           DO C^%DTC

 +6        SET ACD18MO=$EXTRACT(X,1,5)_"00"

           SET ACD18MOE=$EXTRACT(X,1,5)_"99"

 +7        SET X1=ACDBEGDT

           SET X2=-730

           DO C^%DTC

 +8        SET ACD24MO=$EXTRACT(X,1,5)_"00"

           SET ACD24MOE=$EXTRACT(X,1,5)_"99"

 +9        WRITE !,"Records Due for Follow Up on ",ACDBGMDY," will be extracted"

 +10       DO WAIT^DICD

 +11       SET DIK="^ACDWORK("

 +12       SET DA=0

           FOR ACDIX=0:0

               SET DA=$ORDER(^ACDWORK(DA))

               IF '+DA

                   QUIT 

               DO ^DIK

 +13       KILL ACDBEGDT,ACDIX,DA

 +14       GOTO ^ACDFUL2

 +15       QUIT