source: WorldVistAEHR/trunk/r/SOCIAL_WORK-SOW-SWBH-SWFG/SOWKTRAN.m@ 1261

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

initial load of WorldVistAEHR

File size: 1.1 KB
RevLine 
[613]1SOWKTRAN ;B'HAM ISC/SAB-Routine to transfer RCH patients between homes ; 24 Feb 93 / 2:39 PM
2 ;;3.0; Social Work ;;27 Apr 93
3 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
4 S (SOWKRP,DA(1))=+Y F Q=0:0 S Q=$O(^SOWK(655,SOWKRP,4,Q)) Q:'Q S (SOWKLH,DA)=Q
5 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
6 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
7 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
8CLO K DA,DR,DIC,DIE,Q,SOWKLH,SOWKRP,X,CN,Y
9 Q
10CLE S $P(^SOWK(655,SOWKRP,4,SOWKLH,0),"^",3)="",$P(^(0),"^",4)="",$P(^(0),"^",6)="" G CLO
Note: See TracBrowser for help on using the repository browser.