40 lines
3.0 KiB
Mathematica
40 lines
3.0 KiB
Mathematica
|
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.
|