SOWKDBSR ;B'HAM ISC/SAB-Routine to add/delete surrogate supervisor ; 11/08/91 11:57
 ;;3.0; Social Work ;;27 Apr 93
 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
SUR 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
 I DA=SUR W *7,!,"YOU CANNOT BE YOUR OWN SURROGATE !" G TRY
 E  D ADD G CLO
CLO K SOWKNEW,DA,%,%Y,Q,SUR,DIC,X,DIE,DR,I,PA,Y Q
ADD 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
 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
 Q
TRY K DA F Q=0:0 W !!,"DO YOU WANT TO TRY AGAIN" S %=2 D YN^DICN Q:%  I %Y="?" D YN^SOWKHELP
 G:%=2!(%=-1) CLO
 G SUR
 Q
DEL 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
DE 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
 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 "."
 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
 G CLO
 Q