source: WorldVistAEHR/trunk/r/SOCIAL_WORK-SOW-SWBH-SWFG/SOWKND.m@ 1006

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

initial load of WorldVistAEHR

File size: 3.5 KB
Line 
1SOWKND ;B'HAM ISC/SAB-POST INIT ROUTINE ; 09 Mar 93 / 1:27 PM [ 03/27/97 9:52 AM ]
2VER ;;3.0; Social Work ;**10,45,49**;27 Apr 93
3 I $O(^DD(654,0)) W !!,"DELETING SW POSITIONS FILE (#654)",! S DIU=654,DIU(0)="DT" D EN^DIU2
4 F KEY="XMQ-SWA","XMQ-SWM","XMQ-SWK" I '$O(^DIC(19.1,"B",KEY,0)) W !!,"INSTALLING SECURITY KEY '"_KEY_"' FOR SOCIAL WORK DATA TRANSMISSION" S DIC="^DIC(19.1,",DIC(0)="L",X=KEY K DD,DO D FILE^DICN K DIC,X,KEY W !,"HOLDERS WILL HAVE TO BE ADDED"
5 I $O(^DIC(4.2,"B","Q-SWA.VA.GOV",0)) G EN0
6 W !!,"INSTALLING RELAY DOMAIN 'Q-SWA.VA.GOV' FOR SOCIAL WORK DATA TRANSMISSION..." S DIC="^DIC(4.2,",DIC(0)="L",X="Q-SWA.VA.GOV",DIC("DR")="1///S;1.5///XMQ-SWA;2///FOC-AUSTIN.VA.GOV;6.2///SWA;17" K DD,DO D FILE^DICN K DIC,X
7EN0 I $O(^DIC(4.2,"B","Q-RHC.VA.GOV",0)) G EN1
8 W !!,"INSTALLING RELAY DOMAIN 'Q-RHC.VA.GOV' FOR SOCIAL WORK DATA TRANSMISSION..." S DIC="^DIC(4.2,",DIC(0)="L",X="Q-RHC.VA.GOV",DIC("DR")="1///S;1.5///XMQ-SWK;2///FOC-AUSTIN.VA.GOV;6.2///SWK;17" K DD,DO D FILE^DICN K DIC,X
9EN1 I $O(^XMB(3.8,"B","SWS",0)) G EN
10 W !!,"INSTALLING MAIL GROUP 'SWA' TO RECEIVE SOCIAL WORK TRANSMISSION CONFIRMATION..." S DIC="^XMB(3.8,",DIC(0)="L",X="SWA",DIC("DR")="4///PU;7///y" K DD,DO D FILE^DICN K DIC,X W !,"MEMBERS WILL HAVE TO BE ADDED...",!
11EN I $O(^DIC(4.2,"B","Q-SWM.VA.GOV",0)) G EN2
12 W !!,"INSTALLING RELAY DOMAIN 'Q-SWM.VA.GOV' FOR SOCIAL WORK DATA TRANSMISSION..." S DIC="^DIC(4.2,",DIC(0)="L",X="Q-SWM.VA.GOV",DIC("DR")="1///S;1.5///XMQ-SWM;2///FOC-AUSTIN.VA.GOV;6.2///SWM;17" K DD,DO D FILE^DICN K DIC,X
13EN2 I $O(^XMB(3.8,"B","RHC",0)) G EN3
14 W !!,"INSTALLING MAIL GROUP 'RHC' TO RECEIVE SOCIAL WORK TRANSMISSION CONFIRMATION..." S DIC="^XMB(3.8,",DIC(0)="L",X="RHC",DIC("DR")="4///PU;7///y" K DD,DO D FILE^DICN K DIC,X W !,"MEMBERS WILL HAVE TO BE ADDED...",!
15EN3 I $O(^XMB(3.8,"B","SWM",0)) G EN4
16 W !!,"INSTALLING MAIL GROUP 'SWM' TO RECEIVE SOCIAL WORK TRANSMISSION CONFIRMATION..." S DIC="^XMB(3.8,",DIC(0)="L",X="SWM",DIC("DR")="4///PU;7///y" K DD,DO D FILE^DICN K DIC,X W !,"MEMBERS WILL HAVE TO BE ADDED...",!
17EN4 F I=0:0 S I=$O(^SOWK(652,I)) Q:'I S:'$D(^SOWK(652,I,1)) $P(^SOWK(652,I,1),"^",2)=0
18 I $O(CDC(0)) F CDC=0:0 Q:'$O(CDC(CDC)) S CDC=$O(CDC(CDC)),^SOWK(651,CDC,0)=CDC(CDC)
19 S (SWPT,SWSW,SWSITE,SHEMP)=0 F S SWPT=$O(^SOWK(650,"AC",SWPT)) Q:'SWPT F S SWSW=$O(^SOWK(650,"AC",SWPT,SWSW)) Q:'SWSW F S SWSITE=$O(^SOWK(650,"AC",SWPT,SWSW,SWSITE)) Q:'SWSITE D
20 .F S SHEMP=$O(^SOWK(650,"AC",SWPT,SWSW,SWSITE,SHEMP)) Q:'SHEMP I '$D(^SOWK(650,SHEMP,0)) K ^SOWK(650,"AC",SWPT,SWSW,SWSITE,SHEMP)
21 K SHEMP
22 S ^SOWK(650.1,1,"VER")=$P($T(VER),";",3),DIK="^SOWK(651,",DIK(1)="4^AC" D ENALL^DIK K DIK
23QU K SWS,SWSITE,SWPT,CDC,Y,KEY,OC,DIU,HOC,HIR,HR,I,SOWKND,DIK,X
24LOCK ;deletes SOWKNEW lock from all options and adds it to SOWKNEW and SOWKXREF
25 N XX,SOW,SOWK,OPT
26 S SOWK="SOW" F S SOWK=$O(^DIC(19,"B",SOWK)) Q:$E(SOWK,1,6)'["SOWK" S SOW=$O(^DIC(19,"B",SOWK,0)) D
27 .I $P(^DIC(19,SOW,0),U,6)="SOWKNEW" K DR,DIE,DA S DIE=19,DR="3///@",DA=SOW I DA D ^DIE K DR,DIE,DA
28 .I SOWK="SOWKDELETE",($P(^DIC(19,SOW,0),U,6)'="SOWKSITE") K DR,DIE,DA S DIE=19,DR="3///SOWKSITE",DA=SOW I DA D ^DIE K DR,DA,DIE
29SOWKNEW ;
30 F XX="SOWKNEW","SOWKXREF" K DR,DIE,DA S DIE=19,DR="3///SOWKNEW",DA=$O(^DIC(19,"B",XX,0)) D ^DIE K DR,DIE,DA
31ALL ;Clean-up of all other option locks
32 F XX="SOWKARS","SOWKCMR","SOWKHINC" K DR,DIE,DA S DIE=19,DR="3///@",DA=$O(^DIC(19,"B",XX,0)) I DA D ^DIE K DR,DIE,DA
33OPTDEL ;deletes option SOWKDBPRN and SOWKALL
34 F OPT="SOWKALL","SOWKDBPRN" I $O(^DIC(19,"B",OPT,0)) S DA=$O(^DIC(19,"B",OPT,0)) S DIK="^DIC(19," D ^DIK K DIK,DA
35 Q
Note: See TracBrowser for help on using the repository browser.