SOWKTRAN ;B'HAM ISC/SAB-Routine to transfer RCH patients between homes ; 24 Feb 93 / 2:39 PM
 ;;3.0; Social Work ;;27 Apr 93
 S (DIE,DIC)="^SOWK(655,",DIC(0)="AEQMZ",DIC("A")="SELECT RCH PATIENT: ",DIC("S")="I $O(^SOWK(655,+Y,4,0))" D ^DIC G:Y<0 CLO K DIC
 S (SOWKRP,DA(1))=+Y F Q=0:0 S Q=$O(^SOWK(655,SOWKRP,4,Q)) Q:'Q  S (SOWKLH,DA)=Q
 S DIE="^SOWK(655,"_DA(1)_",4,",DR="3"_"///"_1_";"_4_";"_6_"///"_1 D ^DIE S CN=$P(^SOWK(655,DA(1),4,DA,0),"^",5) I '$P(^(0),"^",4) S $P(^(0),"^",3)="",$P(^(0),"^",6)="" W !!,"INCOMPLETE TRANFER INFORMATION - PATIENT WAS NOT TRANSFERED" G CLO
 S DIC("S")="I $P(^SOWK(655,SOWKRP,4,SOWKLH,0),""^"",1)'=+Y",DIC="^SOWK(652,",DIC(0)="AQEMZ",DIC("A")="SELECT HOME: " D ^DIC I Y<0 W !!,"INCOMPLETE TRANFER INFORMATION - PATIENT WAS NOT TRANSFERED" G CLE
 S DA=+Y,(DIC,DIE)="^SOWK(655,"_DA(1)_",4,",DIC("DR")=".01;1;2;5"_"///"_CN,DIC(0)="L",(DA,X)=+Y K DD,DO D FILE^DICN I Y<0 W !!,"INCOMPLETE TRANFER INFORMATION - PATIENT WAS NOT TRANSFERED" G CLE
CLO K DA,DR,DIC,DIE,Q,SOWKLH,SOWKRP,X,CN,Y
 Q
CLE S $P(^SOWK(655,SOWKRP,4,SOWKLH,0),"^",3)="",$P(^(0),"^",4)="",$P(^(0),"^",6)="" G CLO