- 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