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

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

initial load of FOIAVistA 6/30/08 version

File size: 1.5 KB
Line 
1SOWKDBSR ;B'HAM ISC/SAB-Routine to add/delete surrogate supervisor ; 11/08/91 11:57
2 ;;3.0; Social Work ;;27 Apr 93
3 W ! S DIC("S")="I $D(^VA(200,+Y,654)),$P(^VA(200,+Y,654),""^""),$D(^VA(200,""ASWE"",+Y))",(DIE,DIC)="^VA(200,",DIC("A")="SELECT SURROGATE SUPERVISOR: ",DIC(0)="AEMQZ" D ^DIC G:"^"[X CLO G:Y<0 SOWKDBSR S SUR=+Y
4SUR W !! S DIC("S")="I $D(^VA(200,""ASWE"",+Y)),+Y'=SUR",DIC("A")="SELECT SURROGATED SUPERVISOR: " D ^DIC G:"^"[X CLO G:Y<0 SUR S DA=+Y
5 I DA=SUR W *7,!,"YOU CANNOT BE YOUR OWN SURROGATE !" G TRY
6 E D ADD G CLO
7CLO K SOWKNEW,DA,%,%Y,Q,SUR,DIC,X,DIE,DR,I,PA,Y Q
8ADD S SOWKNEW=1,DR="654.3///^S X=SUR" D ^DIE K DIC S DIE="^SOWK(655.2,",PA=DA,DR=".05////"_SUR F I=0:0 S I=$O(^SOWK(655.2,"E",PA,I)) Q:'I S DA=I W "." D ^DIE
9 S SOWKNEW=1,DR="654.3///^S X=SUR",DIE="^VA(200," F I=0:0 S I=$O(^VA(200,"ACSW",PA,I)) Q:'I S DA=I D ^DIE
10 Q
11TRY K DA F Q=0:0 W !!,"DO YOU WANT TO TRY AGAIN" S %=2 D YN^DICN Q:% I %Y="?" D YN^SOWKHELP
12 G:%=2!(%=-1) CLO
13 G SUR
14 Q
15DEL S DR="654.3///@",(DIE,DIC)="^VA(200,",DIC("A")="SELECT SURROGATE SUPERVISOR: ",DIC(0)="AEQMZ",DIC("S")="I $D(^VA(200,""ACSW"",+Y))" D ^DIC G:"^"[X CLO G:Y<0 DEL S SUR=+Y
16DE S DIC("A")="SELECT SURROGATED SUPERVISOR: ",DIC("S")="I $P(^(0),""^"",4)'=+Y,$D(^VA(200,""ACSW"",SUR,+Y)),$D(^VA(200,""ASWE"",+Y))" D ^DIC G:"^"[X CLO G:Y<0 DE S DA=+Y D ^DIE
17 K DIC S DIE="^SOWK(655.2,",PA=DA,DR=".05///@" F I=0:0 S I=$O(^SOWK(655.2,"E",PA,I)) Q:'I S DA=I D ^DIE W "."
18 S DR="654.3///@",DIE="^VA(200," F I=0:0 S I=$O(^VA(200,"ACSW",SUR,I)) Q:'I S DA=I I PA=I!$P(^VA(200,I,654),"^",4)=SUR D ^DIE
19 G CLO
20 Q
Note: See TracBrowser for help on using the repository browser.