source: WorldVistAEHR/trunk/r/CMOP-PSX/PSXSITE.m@ 701

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

initial load of WorldVistAEHR
File size: 5.5 KB
RevLine 
[613]1PSXSITE ;BIR/WPB,BAB-Activate Outpatient Sites for CMOP ;09 SEP 1998 6:52 AM
2 ;;2.0;CMOP;**1,18,24,27,38,41**;11 Apr 97
3 ;Reference to ^DIC(4, supported by DBIA #10090
4 ;Reference to ^DIC(4.2, supported by DBIA #1966
5 ;Reference to File #200 supported by DBIA #10060
6 ;
7EN1 I '$D(^XUSEC("PSXCMOPMGR",DUZ)) W !,"You are not authorized to use this option!" Q
8 D SET^PSXSYS G:$G(PSXSYS)="" EN2
9 I $P(PSXSYS,"^",2)="" W !!,"The Station number is missing in the Institution file.",!,"The Station number is required for CMOP transmissions.",!,"Please contact your IRM and have this problem corrected, then try again.",! Q
10 I $P($G(^PSX(550,+$G(PSXSYS),0)),"^",3)'="H" W !,"There is a transmission in progress, try later." Q
11 I $D(^PSX(550,"TR","T")) W !,"There is a transmission in progress, try later." Q
12 ;I S $P(^PSX(550,+$G(PSXSYS),0),"^",3)="T"
13 K DIE,DA,DR
14 S DIE=550,DA=+PSXSYS,DR="2////T"
15 L +^PSX(550,DA):600 I '$T W !,"Sorry, someone else has the CMOP System file!" H 3 Q
16 D ^DIE L -^PSX(550,DA)
17 K DIE,DA,DR
18EN2 I $D(^PSX(550,"AP")) W !,"A request to activate a system has been sent and action is pending." G EXIT
19 I $D(^PSX(550,"C")) D DEACT^PSXSYS G EXIT
20 I '$D(^PSX(550,"C")) S SYSFLAG=1 D SYSTEM^PSXSYS
21EXIT I $G(PSXSYS)'="" D
22 .S DA=+PSXSYS
23 .L +^PSX(550,DA):6 I '$T W !,"Someone else has the CMOP System file in use, quitting" Q
24 .K DIE,DA,DR
25 .S DIE=550,DA=+PSXSYS,DR="2////H" D ^DIE
26 .L -^PSX(550,DA) K DIE,DA,DR
27 K SYSFLAG,SYSTEM,SS,SY,Y,CDOM,FDOM,SYSSTAT,PP,PURG,PDTTM,XX,XMIT,STAT,AA,DIR,PSXMDM,TT,DIRUT,DTOUT,DUOUT,DIROUT,PSXSYS
28 Q
29ACT W ! K SYSTEM,SS,Y
30 S DIC(0)="AEQMZ",DIC("A")="Enter System to activate: ",DIC=550 D ^DIC K DIC G:(Y=0)!($D(DTOUT))!($D(DUOUT)) EXIT K DTOUT,DUOUT
31 I X="" W !,"Enter the name of the system to activate." G ACT
32 I X'="" S (DA,SS)=+Y,SYSTEM=$P($G(Y),U,2) K Y
33 I X="^" G EXIT K DIC,Y W !
34 I $D(^PSX(550,"C")) S TT=$O(^PSX(550,"C","")) I $G(TT)=SS W !,"The "_SYSTEM_" is already activated." G ACT
35 S SYSFLAG=1 G SYS^PSXSYS
36AC W ! S DIR(0)="Y",DIR("A")="Are you sure you want to activate the "_SYSTEM_" system",DIR("B")="NO" D ^DIR K DIR G:(Y=0)!($D(DIRUT)) EXIT K DIRUT,DTOUT,DUOUT
37 ;S DA=+SS,DIE="^PSX(550,",DR="3////"_PSXMDM D ^DIE K DIE,DA,DR
38 D NOTE K S1,S2,S3
39 W !!,"Request to activate sent to "_SYSTEM_"."
40 Q
41NOTE S (S1,DA)=$$KSP^XUPARAM("INST"),DIC="4",DIQ(0)="IE",DR=".01;99",DIQ="PSXUTIL" D EN^DIQ1 S ST=$G(PSXUTIL(4,S1,99,"I")),SITE=$G(PSXUTIL(4,S1,.01,"E")) K DA,DIC,DIQ(0),DR
42 I $G(ST)="" W !!,"The Station number is missing in the Institution file.",!,"The Station number is required for CMOP transmissions.",!,"Please contact your IRM and have this problem corrected, then try again." Q
43 K PSXUTIL
44 S XX=$P($G(^PSX(550,SS,0)),U,4),DOMAIN=$$GET1^DIQ(4.2,XX,.01)
45 S NM=$$GET1^DIQ(200,DUZ,.01),NAME=$P(NM,",",2)_" "_$P(NM,",",1)
46 I '$D(DOMAIN) W !!,"There is no mail domain to send the request to." Q
47 D NOW^%DTC S (Y,TIME)=% X ^DD("DD") S RTIME=Y K Y,%
48 S XMDUZ=.5,XMSUB=$S(SYSFLAG=1:"CMOP Activation Request",SYSFLAG=0:"CMOP Inactivation Notice",1:""),LCNT=2
49MM D XMZ^XMA2 G:XMZ<1 MM
50 S ^XMB(3.9,XMZ,2,1,0)=$S(SYSFLAG=1:"$$ACT^",SYSFLAG=0:"$$DACT^",1:"")_SITE_"^"_TIME_"^"_SS_"^"_ST_"^"_$$GET1^DIQ(200,DUZ,.01)
51 S ^XMB(3.9,XMZ,2,2,0)="$$ENDACT"
52 S ^XMB(3.9,XMZ,2,0)="^3.92A^"_LCNT_U_LCNT_U_DT,XMDUN=NAME
53 K XMY S XMDUZ=.5,XMY("S.PSXX CMOP SERVER@"_DOMAIN)=""
54 ;S XMY(DUZ)="" H 1 ;****TESTING S.PSXX
55 D ENT1^XMD
56MESS S XMDUZ=.5,XMSUB=($S(SYSFLAG=1:"CMOP Activation Request",SYSFLAG=0:"CMOP Inactivation Notice",1:"")),LCNT=5
57 D XMZ^XMA2 G:XMZ<1 MESS
58 S ^XMB(3.9,XMZ,2,1,0)=$S(SYSFLAG=1:"Request to activate.",SYSFLAG=0:"Inactivation notice sent.",1:"")
59 S ^XMB(3.9,XMZ,2,2,0)=""
60 S ^XMB(3.9,XMZ,2,3,0)="CMOP : "_SYSTEM
61 S ^XMB(3.9,XMZ,2,4,0)="Requester : "_NAME
62 S ^XMB(3.9,XMZ,2,5,0)="Action Date/Time: "_$P(RTIME,":",1,2)
63 S ^XMB(3.9,XMZ,2,0)="^3.92A^"_LCNT_U_LCNT_U_DT,XMDUN="CMOP MANAGER"
64 K XMY S XMDUZ=.5
65 D GRP^PSXNOTE,ENT1^XMD
66FILEB S STAT=$S(SYSFLAG=1:"A",SYSFLAG=0:"I",1:"")
67 S:'$D(^PSX(550,+SS,1,0)) ^PSX(550,+SS,1,0)="^550.04DA^^"
68 K DD,DO S DA(1)=SS,(DA,X)=TIME,DIC="^PSX(550,"_SS_",1,",DIC(0)="Z"
69 S DIC("DR")="1////"_DUZ_$S($G(STAT)="A":";3////P",1:"")_";4////"_$G(STAT)
70 D FILE^DICN K DIC("DR"),DIC,DA,X
71 K LCNT,NAME,NM,SITE,ST,TIME,RTIME,XMY,XMZ,XMDUN,XMDUZ,XMSUB,DOMAIN
72 Q
73FILE S FDOM=$O(^DIC(4.2,"B",RDOM,""))
74 S REC=$O(^PSX(552,"B",SITENUM,""))
75 K DD,DO
76 ;Agency Field added for DoD
77 I $G(REC)'>0 S DIC(0)="Z",X=SITENUM,DIC("DR")="2////I;4///^S X=RDOM;5////"_$S($G(AGENCY):AGENCY,1:""),DIC="^PSX(552," D
78FF .D FILE^DICN K DIC("DR"),DIC,X
79 .S RECA=+Y
80 .S:'$D(^PSX(552,RECA,1,0)) ^PSX(552,RECA,1,0)="^552.01DA^^"
81FC .S DA(1)=RECA,X=RDTTM,DIC(0)="Z",DIC="^PSX(552,"_RECA_",1,",DIC("DR")="1////1;2////"_REQT_";7////P" D FILE^DICN K DIC("DR"),DIC,RECA
82 I $G(REC)>0 D
83LOCK .L +^PSX(552,REC):600 G:'$T LOCK S DA=REC,DIE="^PSX(552,",DR="2////I;4///^S X=RDOM" D ^DIE L -^PSX(552,REC) K DIE,DA
84 .S:'$D(^PSX(552,REC,1,0)) ^PSX(552,REC,1,0)="^552.01DA^^"
85 .K DD,DO
86 .S DIC(0)="Z",DA(1)=$G(REC),(DA,X)=RDTTM,DIC="^PSX(552,"_REC_",1,"
87 .S DIC("DR")=$S(ACTFLAG=1:"1////"_ACTFLAG_";2////"_REQT_";7////A",ACTFLAG=0:"1////2;2////"_REQT_";3////"_RDTTM_";4////"_DUZ_";7////N",1:"")
88F .D FILE^DICN K DA,DIC("DR"),DIC,REC,X
89 Q
90FILEA S REC=$O(^PSX(552,"B",SITENUM,"")) Q:REC=""
91 L +^PSX(552,REC):600 G:'$T FILEA S DA=REC,DIE="^PSX(552,",DR="2////"_$S(ACTFLAG=1:"A",ACTFLAG=0:"I",1:0) D ^DIE K DIE,DA,DR
92 S XSS=0 F S XSS=$O(^PSX(552,REC,1,XSS)) Q:XSS'>0 S SUBREC=XSS
93 D NOW^%DTC
94 S STAT=$S(ACTFLAG=1:"A",ACTFLAG=0:"D",1:"")
95LOCK1 S DA(1)=REC,DA=SUBREC,DIE="^PSX(552,"_REC_",1,",DR="3////"_%_";4////"_DUZ_";7////"_STAT D ^DIE L -^PSX(552,REC) K DIE,DA,SUBREC,REC,STAT,%,XSS
96 Q
Note: See TracBrowser for help on using the repository browser.