source: WorldVistAEHR/trunk/r/SOCIAL_WORK-SOW-SWBH-SWFG/SOWKNEW.m@ 810

Last change on this file since 810 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.4 KB
RevLine 
[613]1SOWKNEW ;B'HAM ISC/SAB-Routine to add new worker and to replace old worker ; 17 Nov 93 / 9:40 AM
2 ;;3.0; Social Work ;**3,13,16**;27 Apr 93
3 W !!,"Are You: ",!,?5,"1. Adding and Replacing a Worker",!,?5,"2. Replacing a Worker" R !,"Enter 1 or 2 1// ",SWK:DTIME,! S:SWK="" SWK="1" G:"^"[SWK!('$T) CLO I "12"'[SWK D HP G SOWKNEW
4 G:"2"[SWK SWP
5WRK W ! S DIE("NO^")="OUTOK",DIC("S")="I '$D(^VA(200,+Y,654)),'$P(^VA(200,+Y,0),""^"",11)!($P(^(0),""^"",11)'<DT)",DIC="^VA(200,",DIC(0)="AQEM",DIC("A")="SELECT NEW WORKER: " D ^DIC G:"^"[X CLO S (DA,SWN)=+Y K DIC G:+Y'>0 WRK
6 S SOWKNEW=1,DIE="^VA(200,",DR="654///1;654.15;S SOWKXX=1;654.1;654.2;K SOWKXX" W ! D ^DIE
7 I $D(Y)!'$P(^VA(200,DA,654),"^",2)!'$P(^(654),"^",3)!'$P(^(654),"^",5) W !!,*7,"INCOMPLETE WORKER INFORMATION!! DATA NOT ADDED." D DEL G CLO
8 G SWR
9 Q
10SWR W !! S DIC="^VA(200,",DIC("A")="WHICH WORKER TO REPLACE ? ",DIC(0)="AQEM",DIC("S")="I SWN'=+Y,$O(^SOWK(650,""W"",+Y,0))" D ^DIC G:$D(DUOUT)!(Y<0) CLO S SWO=+Y K DIC
11YN F Q=0:0 W !,"ARE YOU SURE YOU WANT TO REPLACE THIS WORKER" S %=2 D YN^DICN Q:% I %Y["?" D YN^SOWKHELP
12 G:%=2!(%=-1) CLO
13 D WAIT^DICD F I=0:0 S I=$O(^SOWK(650,"W",SWO,I)) Q:'I S $P(^SOWK(650,I,0),"^",3)=SWN,SWPT=$P(^(0),"^",8),^SOWK(650,"W",SWN,I)="" D DB I '$P(^SOWK(650,I,0),"^",18) D AC
14 K ^SOWK(650,"W",SWO)
15CLO K IFN,SWPT,II,%,VAR,%Y,Q,DIC,X,DA,SWN,Y,DIE,DR,SWO,I,SWK,SOWKNEW,SOWKXX,SOWKREC,SOWKEDIT,SOWKOUT
16 Q
17SWP W !! S DIC="^VA(200,",DIC("A")="REPLACEMENT WORKER ? ",DIC(0)="AQEM",DIC("S")="I $D(^VA(200,+Y,654)),$P(^VA(200,+Y,654),""^"")" D ^DIC G:$D(DUOUT)!(Y<0) CLO S SWN=+Y K DIC G SWR
18 Q
19AC S ^SOWK(650,"AC",$P(^SOWK(650,I,0),"^",8),SWN,$P(^(0),"^",5),I)="" K ^SOWK(650,"AC",$P(^SOWK(650,I,0),"^",8),SWO) Q
20ADD ;ENTRY POINT TO ENTER/EDIT WORKERS
21 W !! S DIC="^VA(200,",DIC("A")="SELECT WORKER: "
22 S DIC(0)=$S($G(SOWKEDIT)=1:"EMQ",1:"AEQM") D ^DIC G:"^"[X CLO G:Y<0 ADD S DA=+Y,SOWKREC=$P(Y,U,2) K SOWKEDIT S:$D(^VA(200,+Y,654)) SOWKEDIT=1 K DIC S SOWKNEW=1 S DIE="^VA(200,",DR="[SOWKNWRK]",DIE("NO^")="OUTOK" W ! D ^DIE
23 I '$P(^VA(200,DA,654),"^",2)!'$P(^(654),"^",3)!'$P(^(654),"^",5) W *7,!!,"INCOMPLETE WORKER INFORMATION!! DATA NOT ADDED.",! I '$D(SOWKEDIT) D DEL Q
24 I $D(SOWKEDIT),('$P(^VA(200,DA,654),"^",2)!('$P(^(654),"^",3))!('$P(^(654),"^",5))) K DIE,DA,DR S X=SOWKREC W:$D(SOWKEDIT) !,"WORKERS INFORMATION MUST BE COMPLETE" G ADD
25 G CLO
26 Q
27DEL K ^VA(200,DA,654),^VA(200,"ASWB",DA,DA),^VA(200,"ASWE",DA) F I=0:0 S I=$O(^VA(200,"ASWC",I)) Q:'I F II=0:0 S II=$O(^VA(200,"ASWC",I,II)) Q:'II I II=DA K ^VA(200,"ASWC",I,II)
28 S VAR="" F I=0:0 S VAR=$O(^VA(200,"ASWD",VAR)) Q:VAR="" F II=0:0 S II=$O(^VA(200,"ASWD",VAR,II)) Q:'II I II=DA K ^VA(200,"ASWD",VAR,II)
29 F I=0:0 S I=$O(^VA(200,"ASWE",I)) Q:'I F II=0:0 S II=$O(^VA(200,"ASWE",I,II)) Q:'II I II=DA K ^VA(200,"ASWE",I,II)
30 Q
31HP W !!,"Entering the number one (1) will allow you to add a new worker and then assign",!,"that new worker a current worker's case load.",!,"The number two (2) allows you to assign a current worker's case load to another current worker."
32 Q
33DB I $D(^SOWK(655.2,SWPT,0)),$P(^(0),"^",3)=SWO S $P(^SOWK(655.2,SWPT,0),"^",3)=SWN,$P(^(0),"^",13)=$P(^VA(200,SWN,654),"^",2),^SOWK(655.2,"C",SWN,SWPT)="",^SOWK(655.2,"E",$P(^VA(200,SWN,654),"^",2),SWPT)="" D KXRF
34 I $O(^SOWK(655.2,SWPT,23,"B",SWO,0)) S IFN=$O(^SOWK(655.2,SWPT,23,"B",SWO,0)),$P(^SOWK(655.2,SWPT,23,IFN,0),"^")=SWN,^SOWK(655.2,SWPT,23,"B",SWN,IFN)="" K ^SOWK(655.2,SWPT,23,"B",SWO,IFN)
35 Q
36KXRF K ^SOWK(655.2,"C",SWO,SWPT),^SOWK(655.2,"E",$P(^VA(200,SWO,654),"^",2),SWPT)
37 Q
Note: See TracBrowser for help on using the repository browser.