source: FOIAVistA/trunk/r/SOCIAL_WORK-SOW-SWBH-SWFG/SOWKCLEA.m@ 1169

SOWKCLEA ;B'HAM ISC/SAB-ROUTINE TO DELETE CLOSED AND TRANSMITTED CASES ; 10/26/92 17:53
 ;;3.0; Social Work ;**53**;27 Apr 93
 S SOWKAU=$P(^SOWK(650.1,1,0),"^",3),J=0,%DT="AEXP",%DT("A")="CUTOFF DATE: " D ^%DT G:"^"[$E(X) CLOS S CUT=Y H 3 W @IOF
 W !!,*7,"ALL CASES ON OR BEFORE "_$E(CUT,4,5)_"/"_$E(CUT,6,7)_"/"_$E(CUT,2,3)_".",! F I=1:1 S T=$T(K+I) Q:T=""  W !,$P(T,";",3,99)
 F Q=0:0 W !!!,"ARE YOU SURE YOU WANT TO RUN THIS OPTION" S %=2 D YN^DICN Q:%  I %Y["?" D YN^SOWKHELP
 G:%=2!(%=-1) CLOS
 F Q=0:0 W !!,"DO YOU WANT THIS OPTION QUEUED" S %=2 D YN^DICN Q:%  I %Y["?" D YN^SOWKHELP
 G:%=-1 CLOS I %=1 S ZTIO="",ZTDESC="Option to Purge Case Management Data (files 650 and 655)",ZTRTN="BEG^SOWKCLEA" F G="SOWKAU","CUT","J" S:$D(@G) ZTSAVE(G)=""
 W ! I %=1 D ^%ZTLOAD G:'$D(ZTSK) CLOS W:$D(ZTSK) *7,!!,"Purge Case Management Data option Queued to run" K ZTSK G CLOS
BEG D:'$D(ZTSK) WAIT^DICD I SOWKAU F I=0:0 S I=$O(^SOWK(650,I)) Q:'I  S C=^SOWK(650,I,0) I $P(C,"^",18),$P(C,"^",6),$P(C,"^",18)'>CUT S CN=I,FLAG=$S($P(^SOWK(651,$P(C,"^",13),0),"^",6)="R":1,1:0),P=$P(C,"^",8) D REM,DB
 I 'SOWKAU F I=0:0 S I=$O(^SOWK(650,I)) Q:'I  S C=^SOWK(650,I,0) I $P(C,"^",18),$P(C,"^",18)'>CUT S CN=I,FLAG=$S($P(^SOWK(651,$P(C,"^",13),0),"^",6)="R":1,1:0),P=$P(C,"^",8) D REM,DB
 W:'$D(ZTSK) " <"_J_" RECORDS DELETED>"
CLOS K G,ZTDESC,ZTIO,ZTRTN,ZTSAVE,%,%Y,FLAG,%DT,I,P,Y,DA,K,T,Q,X,AL,C,J,DIC,DIK,HM,CN,CUT,SOWKAU D:$D(ZTSK) KILL^%ZTLOAD Q
REM I 'FLAG S DA=I,DIK="^SOWK(650," W:'$D(ZTSK) "." D ^DIK S J=J+1 I $D(^SOWK(655,P,0)),'$P(^SOWK(655,P,0),"^",2) S DIK="^SOWK(655,",DA=P D ^DIK Q
 Q:'FLAG
 F HM=0:0 S HM=$O(^SOWK(655,P,4,HM)) Q:'HM  I $P(^SOWK(655,P,4,HM,0),"^",5)=I D CHK
 Q
CHK I SOWKAU,$P(^SOWK(655,P,4,HM,0),"^",3),$P(^(0),"^",4) S J=J+1,DA(1)=P,DIK="^SOWK(655,"_DA(1)_",4,",DA=HM D ^DIK S DA=I,DIK="^SOWK(650," D ^DIK
 I 'SOWKAU S J=J+1,DA(1)=P,DIK="^SOWK(655,"_DA(1)_",4,",DA=HM D ^DIK S DA=I,DIK="^SOWK(650," D ^DIK
 I '$O(^SOWK(655,P,4,0)) S DA=P,DIK="^SOWK(655," D ^DIK
 Q
DEL ;Entry point to delete cases entered in error
 S (DIC,DIK)="^SOWK(650,",DIC(0)="AEFQM",DIC("A")="SELECT CASE: " D ^DIC G:Y'>0 CLOS S (CN,DA)=+Y,AL=$P(^SOWK(650,CN,0),"^",13),P=$P(^(0),"^",8) D ^DIK D DB
 I $P(^SOWK(651,AL,0),"^",6)="R" F I=0:0 S I=$O(^SOWK(655,P,4,I)) Q:'I  I $P(^SOWK(655,P,4,I,0),"^",5)=CN S DA=I,DA(1)=P,DIK="^SOWK(655,"_DA(1)_",4," D ^DIK
 I '$O(^SOWK(655,P,4,0)) S DA=P,DIK="^SOWK(655," D ^DIK
 W *7," <RECORD DELETED>"
 G CLOS Q
DB S DA(1)=P,DIK="^SOWK(655.2,"_DA(1)_",23,",DA=$O(^SOWK(655.2,P,23,"AG",CN,0)) I DA D ^DIK
 Q
K ;TEXT TO EXPLAIN CLEAR PROBLEMS AND OUTCOME OPTION
 ;;THERE ARE TWO WAYS TO CLEAR PROBLEMS/OUTCOMES.
 ;;IF TRANSMITTING TO AUSTIN, THIS OPTION DELETES CASES THAT HAVE BEEN CLOSED,
 ;;TRANSMITTED TO AUSTIN AND RCH CASES REMOVED FROM RCH PROGRAM.
 ;;IF YOU ANSWER 'YES' TO THIS OPTION IT WILL DELETE THESE RECORDS.  ONCE
 ;;THESE RECORDS ARE DELETED THERE IS NO WAY TO RECOVER THEM, SO BE VERY
 ;;CERTAIN THAT IT IS END OF QUARTER AND YOUR AMIS DATA TO AUSTIN IS ERROR
 ;;FREE !!
 ;;
 ;;IF YOU ARE NOT TRANSMITTING TO AUSTIN ALL CASES THAT ARE CLOSED WILL BE DELETED.