- PSXSITE ;BIR/WPB,BAB-Activate Outpatient Sites for CMOP ;09 SEP 1998 6:52 AM
- ;;2.0;CMOP;**1,18,24,27,38,41**;11 Apr 97
- ;Reference to ^DIC(4, supported by DBIA #10090
- ;Reference to ^DIC(4.2, supported by DBIA #1966
- ;Reference to File #200 supported by DBIA #10060
- ;
- EN1 I '$D(^XUSEC("PSXCMOPMGR",DUZ)) W !,"You are not authorized to use this option!" Q
- D SET^PSXSYS G:$G(PSXSYS)="" EN2
- 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
- I $P($G(^PSX(550,+$G(PSXSYS),0)),"^",3)'="H" W !,"There is a transmission in progress, try later." Q
- I $D(^PSX(550,"TR","T")) W !,"There is a transmission in progress, try later." Q
- ;I S $P(^PSX(550,+$G(PSXSYS),0),"^",3)="T"
- K DIE,DA,DR
- S DIE=550,DA=+PSXSYS,DR="2////T"
- L +^PSX(550,DA):600 I '$T W !,"Sorry, someone else has the CMOP System file!" H 3 Q
- D ^DIE L -^PSX(550,DA)
- K DIE,DA,DR
- EN2 I $D(^PSX(550,"AP")) W !,"A request to activate a system has been sent and action is pending." G EXIT
- I $D(^PSX(550,"C")) D DEACT^PSXSYS G EXIT
- I '$D(^PSX(550,"C")) S SYSFLAG=1 D SYSTEM^PSXSYS
- EXIT I $G(PSXSYS)'="" D
- .S DA=+PSXSYS
- .L +^PSX(550,DA):6 I '$T W !,"Someone else has the CMOP System file in use, quitting" Q
- .K DIE,DA,DR
- .S DIE=550,DA=+PSXSYS,DR="2////H" D ^DIE
- .L -^PSX(550,DA) K DIE,DA,DR
- K SYSFLAG,SYSTEM,SS,SY,Y,CDOM,FDOM,SYSSTAT,PP,PURG,PDTTM,XX,XMIT,STAT,AA,DIR,PSXMDM,TT,DIRUT,DTOUT,DUOUT,DIROUT,PSXSYS
- Q
- ACT W ! K SYSTEM,SS,Y
- 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
- I X="" W !,"Enter the name of the system to activate." G ACT
- I X'="" S (DA,SS)=+Y,SYSTEM=$P($G(Y),U,2) K Y
- I X="^" G EXIT K DIC,Y W !
- I $D(^PSX(550,"C")) S TT=$O(^PSX(550,"C","")) I $G(TT)=SS W !,"The "_SYSTEM_" is already activated." G ACT
- S SYSFLAG=1 G SYS^PSXSYS
- AC 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
- ;S DA=+SS,DIE="^PSX(550,",DR="3////"_PSXMDM D ^DIE K DIE,DA,DR
- D NOTE K S1,S2,S3
- W !!,"Request to activate sent to "_SYSTEM_"."
- Q
- NOTE 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
- 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
- K PSXUTIL
- S XX=$P($G(^PSX(550,SS,0)),U,4),DOMAIN=$$GET1^DIQ(4.2,XX,.01)
- S NM=$$GET1^DIQ(200,DUZ,.01),NAME=$P(NM,",",2)_" "_$P(NM,",",1)
- I '$D(DOMAIN) W !!,"There is no mail domain to send the request to." Q
- D NOW^%DTC S (Y,TIME)=% X ^DD("DD") S RTIME=Y K Y,%
- S XMDUZ=.5,XMSUB=$S(SYSFLAG=1:"CMOP Activation Request",SYSFLAG=0:"CMOP Inactivation Notice",1:""),LCNT=2
- MM D XMZ^XMA2 G:XMZ<1 MM
- 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)
- S ^XMB(3.9,XMZ,2,2,0)="$$ENDACT"
- S ^XMB(3.9,XMZ,2,0)="^3.92A^"_LCNT_U_LCNT_U_DT,XMDUN=NAME
- K XMY S XMDUZ=.5,XMY("S.PSXX CMOP SERVER@"_DOMAIN)=""
- ;S XMY(DUZ)="" H 1 ;****TESTING S.PSXX
- D ENT1^XMD
- MESS S XMDUZ=.5,XMSUB=($S(SYSFLAG=1:"CMOP Activation Request",SYSFLAG=0:"CMOP Inactivation Notice",1:"")),LCNT=5
- D XMZ^XMA2 G:XMZ<1 MESS
- S ^XMB(3.9,XMZ,2,1,0)=$S(SYSFLAG=1:"Request to activate.",SYSFLAG=0:"Inactivation notice sent.",1:"")
- S ^XMB(3.9,XMZ,2,2,0)=""
- S ^XMB(3.9,XMZ,2,3,0)="CMOP : "_SYSTEM
- S ^XMB(3.9,XMZ,2,4,0)="Requester : "_NAME
- S ^XMB(3.9,XMZ,2,5,0)="Action Date/Time: "_$P(RTIME,":",1,2)
- S ^XMB(3.9,XMZ,2,0)="^3.92A^"_LCNT_U_LCNT_U_DT,XMDUN="CMOP MANAGER"
- K XMY S XMDUZ=.5
- D GRP^PSXNOTE,ENT1^XMD
- FILEB S STAT=$S(SYSFLAG=1:"A",SYSFLAG=0:"I",1:"")
- S:'$D(^PSX(550,+SS,1,0)) ^PSX(550,+SS,1,0)="^550.04DA^^"
- K DD,DO S DA(1)=SS,(DA,X)=TIME,DIC="^PSX(550,"_SS_",1,",DIC(0)="Z"
- S DIC("DR")="1////"_DUZ_$S($G(STAT)="A":";3////P",1:"")_";4////"_$G(STAT)
- D FILE^DICN K DIC("DR"),DIC,DA,X
- K LCNT,NAME,NM,SITE,ST,TIME,RTIME,XMY,XMZ,XMDUN,XMDUZ,XMSUB,DOMAIN
- Q
- FILE S FDOM=$O(^DIC(4.2,"B",RDOM,""))
- S REC=$O(^PSX(552,"B",SITENUM,""))
- K DD,DO
- ;Agency Field added for DoD
- 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
- FF .D FILE^DICN K DIC("DR"),DIC,X
- .S RECA=+Y
- .S:'$D(^PSX(552,RECA,1,0)) ^PSX(552,RECA,1,0)="^552.01DA^^"
- FC .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
- I $G(REC)>0 D
- LOCK .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
- .S:'$D(^PSX(552,REC,1,0)) ^PSX(552,REC,1,0)="^552.01DA^^"
- .K DD,DO
- .S DIC(0)="Z",DA(1)=$G(REC),(DA,X)=RDTTM,DIC="^PSX(552,"_REC_",1,"
- .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:"")
- F .D FILE^DICN K DA,DIC("DR"),DIC,REC,X
- Q
- FILEA S REC=$O(^PSX(552,"B",SITENUM,"")) Q:REC=""
- 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
- S XSS=0 F S XSS=$O(^PSX(552,REC,1,XSS)) Q:XSS'>0 S SUBREC=XSS
- D NOW^%DTC
- S STAT=$S(ACTFLAG=1:"A",ACTFLAG=0:"D",1:"")
- LOCK1 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
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXSITE 5754 printed Feb 18, 2025@23:11:33 Page 2
- PSXSITE ;BIR/WPB,BAB-Activate Outpatient Sites for CMOP ;09 SEP 1998 6:52 AM
- +1 ;;2.0;CMOP;**1,18,24,27,38,41**;11 Apr 97
- +2 ;Reference to ^DIC(4, supported by DBIA #10090
- +3 ;Reference to ^DIC(4.2, supported by DBIA #1966
- +4 ;Reference to File #200 supported by DBIA #10060
- +5 ;
- EN1 IF '$DATA(^XUSEC("PSXCMOPMGR",DUZ))
- WRITE !,"You are not authorized to use this option!"
- QUIT
- +1 DO SET^PSXSYS
- if $GET(PSXSYS)=""
- GOTO EN2
- +2 IF $PIECE(PSXSYS,"^",2)=""
- WRITE !!,"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.",!
- QUIT
- +3 IF $PIECE($GET(^PSX(550,+$GET(PSXSYS),0)),"^",3)'="H"
- WRITE !,"There is a transmission in progress, try later."
- QUIT
- +4 IF $DATA(^PSX(550,"TR","T"))
- WRITE !,"There is a transmission in progress, try later."
- QUIT
- +5 ;I S $P(^PSX(550,+$G(PSXSYS),0),"^",3)="T"
- +6 KILL DIE,DA,DR
- +7 SET DIE=550
- SET DA=+PSXSYS
- SET DR="2////T"
- +8 LOCK +^PSX(550,DA):600
- IF '$TEST
- WRITE !,"Sorry, someone else has the CMOP System file!"
- HANG 3
- QUIT
- +9 DO ^DIE
- LOCK -^PSX(550,DA)
- +10 KILL DIE,DA,DR
- EN2 IF $DATA(^PSX(550,"AP"))
- WRITE !,"A request to activate a system has been sent and action is pending."
- GOTO EXIT
- +1 IF $DATA(^PSX(550,"C"))
- DO DEACT^PSXSYS
- GOTO EXIT
- +2 IF '$DATA(^PSX(550,"C"))
- SET SYSFLAG=1
- DO SYSTEM^PSXSYS
- EXIT IF $GET(PSXSYS)'=""
- Begin DoDot:1
- +1 SET DA=+PSXSYS
- +2 LOCK +^PSX(550,DA):6
- IF '$TEST
- WRITE !,"Someone else has the CMOP System file in use, quitting"
- QUIT
- +3 KILL DIE,DA,DR
- +4 SET DIE=550
- SET DA=+PSXSYS
- SET DR="2////H"
- DO ^DIE
- +5 LOCK -^PSX(550,DA)
- KILL DIE,DA,DR
- End DoDot:1
- +6 KILL SYSFLAG,SYSTEM,SS,SY,Y,CDOM,FDOM,SYSSTAT,PP,PURG,PDTTM,XX,XMIT,STAT,AA,DIR,PSXMDM,TT,DIRUT,DTOUT,DUOUT,DIROUT,PSXSYS
- +7 QUIT
- ACT WRITE !
- KILL SYSTEM,SS,Y
- +1 SET DIC(0)="AEQMZ"
- SET DIC("A")="Enter System to activate: "
- SET DIC=550
- DO ^DIC
- KILL DIC
- if (Y=0)!($DATA(DTOUT))!($DATA(DUOUT))
- GOTO EXIT
- KILL DTOUT,DUOUT
- +2 IF X=""
- WRITE !,"Enter the name of the system to activate."
- GOTO ACT
- +3 IF X'=""
- SET (DA,SS)=+Y
- SET SYSTEM=$PIECE($GET(Y),U,2)
- KILL Y
- +4 IF X="^"
- GOTO EXIT
- KILL DIC,Y
- WRITE !
- +5 IF $DATA(^PSX(550,"C"))
- SET TT=$ORDER(^PSX(550,"C",""))
- IF $GET(TT)=SS
- WRITE !,"The "_SYSTEM_" is already activated."
- GOTO ACT
- +6 SET SYSFLAG=1
- GOTO SYS^PSXSYS
- AC WRITE !
- SET DIR(0)="Y"
- SET DIR("A")="Are you sure you want to activate the "_SYSTEM_" system"
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- if (Y=0)!($DATA(DIRUT))
- GOTO EXIT
- KILL DIRUT,DTOUT,DUOUT
- +1 ;S DA=+SS,DIE="^PSX(550,",DR="3////"_PSXMDM D ^DIE K DIE,DA,DR
- +2 DO NOTE
- KILL S1,S2,S3
- +3 WRITE !!,"Request to activate sent to "_SYSTEM_"."
- +4 QUIT
- NOTE SET (S1,DA)=$$KSP^XUPARAM("INST")
- SET DIC="4"
- SET DIQ(0)="IE"
- SET DR=".01;99"
- SET DIQ="PSXUTIL"
- DO EN^DIQ1
- SET ST=$GET(PSXUTIL(4,S1,99,"I"))
- SET SITE=$GET(PSXUTIL(4,S1,.01,"E"))
- KILL DA,DIC,DIQ(0),DR
- +1 IF $GET(ST)=""
- WRITE !!,"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."
- QUIT
- +2 KILL PSXUTIL
- +3 SET XX=$PIECE($GET(^PSX(550,SS,0)),U,4)
- SET DOMAIN=$$GET1^DIQ(4.2,XX,.01)
- +4 SET NM=$$GET1^DIQ(200,DUZ,.01)
- SET NAME=$PIECE(NM,",",2)_" "_$PIECE(NM,",",1)
- +5 IF '$DATA(DOMAIN)
- WRITE !!,"There is no mail domain to send the request to."
- QUIT
- +6 DO NOW^%DTC
- SET (Y,TIME)=%
- XECUTE ^DD("DD")
- SET RTIME=Y
- KILL Y,%
- +7 SET XMDUZ=.5
- SET XMSUB=$SELECT(SYSFLAG=1:"CMOP Activation Request",SYSFLAG=0:"CMOP Inactivation Notice",1:"")
- SET LCNT=2
- MM DO XMZ^XMA2
- if XMZ<1
- GOTO MM
- +1 SET ^XMB(3.9,XMZ,2,1,0)=$SELECT(SYSFLAG=1:"$$ACT^",SYSFLAG=0:"$$DACT^",1:"")_SITE_"^"_TIME_"^"_SS_"^"_ST_"^"_$$GET1^DIQ(200,DUZ,.01)
- +2 SET ^XMB(3.9,XMZ,2,2,0)="$$ENDACT"
- +3 SET ^XMB(3.9,XMZ,2,0)="^3.92A^"_LCNT_U_LCNT_U_DT
- SET XMDUN=NAME
- +4 KILL XMY
- SET XMDUZ=.5
- SET XMY("S.PSXX CMOP SERVER@"_DOMAIN)=""
- +5 ;S XMY(DUZ)="" H 1 ;****TESTING S.PSXX
- +6 DO ENT1^XMD
- MESS SET XMDUZ=.5
- SET XMSUB=($SELECT(SYSFLAG=1:"CMOP Activation Request",SYSFLAG=0:"CMOP Inactivation Notice",1:""))
- SET LCNT=5
- +1 DO XMZ^XMA2
- if XMZ<1
- GOTO MESS
- +2 SET ^XMB(3.9,XMZ,2,1,0)=$SELECT(SYSFLAG=1:"Request to activate.",SYSFLAG=0:"Inactivation notice sent.",1:"")
- +3 SET ^XMB(3.9,XMZ,2,2,0)=""
- +4 SET ^XMB(3.9,XMZ,2,3,0)="CMOP : "_SYSTEM
- +5 SET ^XMB(3.9,XMZ,2,4,0)="Requester : "_NAME
- +6 SET ^XMB(3.9,XMZ,2,5,0)="Action Date/Time: "_$PIECE(RTIME,":",1,2)
- +7 SET ^XMB(3.9,XMZ,2,0)="^3.92A^"_LCNT_U_LCNT_U_DT
- SET XMDUN="CMOP MANAGER"
- +8 KILL XMY
- SET XMDUZ=.5
- +9 DO GRP^PSXNOTE
- DO ENT1^XMD
- FILEB SET STAT=$SELECT(SYSFLAG=1:"A",SYSFLAG=0:"I",1:"")
- +1 if '$DATA(^PSX(550,+SS,1,0))
- SET ^PSX(550,+SS,1,0)="^550.04DA^^"
- +2 KILL DD,DO
- SET DA(1)=SS
- SET (DA,X)=TIME
- SET DIC="^PSX(550,"_SS_",1,"
- SET DIC(0)="Z"
- +3 SET DIC("DR")="1////"_DUZ_$SELECT($GET(STAT)="A":";3////P",1:"")_";4////"_$GET(STAT)
- +4 DO FILE^DICN
- KILL DIC("DR"),DIC,DA,X
- +5 KILL LCNT,NAME,NM,SITE,ST,TIME,RTIME,XMY,XMZ,XMDUN,XMDUZ,XMSUB,DOMAIN
- +6 QUIT
- FILE SET FDOM=$ORDER(^DIC(4.2,"B",RDOM,""))
- +1 SET REC=$ORDER(^PSX(552,"B",SITENUM,""))
- +2 KILL DD,DO
- +3 ;Agency Field added for DoD
- +4 IF $GET(REC)'>0
- SET DIC(0)="Z"
- SET X=SITENUM
- SET DIC("DR")="2////I;4///^S X=RDOM;5////"_$SELECT($GET(AGENCY):AGENCY,1:"")
- SET DIC="^PSX(552,"
- Begin DoDot:1
- FF DO FILE^DICN
- KILL DIC("DR"),DIC,X
- +1 SET RECA=+Y
- +2 if '$DATA(^PSX(552,RECA,1,0))
- SET ^PSX(552,RECA,1,0)="^552.01DA^^"
- FC SET DA(1)=RECA
- SET X=RDTTM
- SET DIC(0)="Z"
- SET DIC="^PSX(552,"_RECA_",1,"
- SET DIC("DR")="1////1;2////"_REQT_";7////P"
- DO FILE^DICN
- KILL DIC("DR"),DIC,RECA
- End DoDot:1
- +1 IF $GET(REC)>0
- Begin DoDot:1
- LOCK LOCK +^PSX(552,REC):600
- if '$TEST
- GOTO LOCK
- SET DA=REC
- SET DIE="^PSX(552,"
- SET DR="2////I;4///^S X=RDOM"
- DO ^DIE
- LOCK -^PSX(552,REC)
- KILL DIE,DA
- +1 if '$DATA(^PSX(552,REC,1,0))
- SET ^PSX(552,REC,1,0)="^552.01DA^^"
- +2 KILL DD,DO
- +3 SET DIC(0)="Z"
- SET DA(1)=$GET(REC)
- SET (DA,X)=RDTTM
- SET DIC="^PSX(552,"_REC_",1,"
- +4 SET DIC("DR")=$SELECT(ACTFLAG=1:"1////"_ACTFLAG_";2////"_REQT_";7////A",ACTFLAG=0:"1////2;2////"_REQT_";3////"_RDTTM_";4////"_DUZ_";7////N",1:"")
- F DO FILE^DICN
- KILL DA,DIC("DR"),DIC,REC,X
- End DoDot:1
- +1 QUIT
- FILEA SET REC=$ORDER(^PSX(552,"B",SITENUM,""))
- if REC=""
- QUIT
- +1 LOCK +^PSX(552,REC):600
- if '$TEST
- GOTO FILEA
- SET DA=REC
- SET DIE="^PSX(552,"
- SET DR="2////"_$SELECT(ACTFLAG=1:"A",ACTFLAG=0:"I",1:0)
- DO ^DIE
- KILL DIE,DA,DR
- +2 SET XSS=0
- FOR
- SET XSS=$ORDER(^PSX(552,REC,1,XSS))
- if XSS'>0
- QUIT
- SET SUBREC=XSS
- +3 DO NOW^%DTC
- +4 SET STAT=$SELECT(ACTFLAG=1:"A",ACTFLAG=0:"D",1:"")
- LOCK1 SET DA(1)=REC
- SET DA=SUBREC
- SET DIE="^PSX(552,"_REC_",1,"
- SET DR="3////"_%_";4////"_DUZ_";7////"_STAT
- DO ^DIE
- LOCK -^PSX(552,REC)
- KILL DIE,DA,SUBREC,REC,STAT,%,XSS
- +1 QUIT