RMPFED ;KLQ/DDC;SERVER- ROES FILE UPDATES; [ 06/25/98 12:16 PM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;**1,13,16**;JUN 16, 1995
;;Reference to ^XMB(3.9) supported by DBIA #10113
G END:'$D(XMZ),END:'XMZ S X=$$SUBGET^XMGAPI0(XMZ) G END:X=""
S RMPFUN=$P(X,"*",2),RMPFNUM=$P(X,"*",3),RMPFMENU=0 D ^RMPFUTL
F CT=1:1:4 S XQSTXT(CT)=" "
S CT=CT+1,XQSTXT(CT)="The following entries in the indicated file"
S CT=CT+1,XQSTXT(CT)="have been modified by Update #"_RMPFUN
S CT=CT+1,XQSTXT(CT)=" "
S CT=CT+1,XQSTXT(CT)="FILE: "_$S($D(^RMPF(RMPFNUM,0)):$P(^(0),U,1),1:RMPFNUM)
S CT=CT+1,XQSTXT(CT)=" "
I RMPFNUM'?1"791"1.NP S ER=4 D ERROR G QUE
T1 K XS F ML=1:1:4 X XMREC Q:XMER=-1 S XS(ML)=XMRG
I XMER>-1 D PROCESS,ERROR:ER G T1
QUE I $P($H,",",2)>86000 S VW=($P($H,",",1)+1)_",00090"
E S VW=$P($H,",",1)_","_($P($H,",",2)+90)
CONFIRM S XMSUB="ROES UPDATE CONFIRMATION*"_RMPFUN,XMDUZ=.5 D XMZ^XMA2 Q:XMZ=""
S ^XMB(3.9,XMZ,2,0)="^3.92A^1^1^"_DT
S ^XMB(3.9,XMZ,2,1,0)=RMPFUN_U_RMPFSTAP
S XMY("S.RMPE-FILE-UPDATE-CONFIRM@DDC.DOMAIN.EXT")=""
D ENT1^XMD
END K BE,BF,CT,ER,ET,I,ML,RMPFNUM,RMPFUN,VW,RMPFSTAP
K X,XMDUZ,XMSUB,XMY,XMZ,XS,ZTDESC,ZTDTH,ZTRTN,ZTSAVE Q
PROCESS S (BF,BE,ER)=0 F I=1:1:4 S:'$D(XS(I)) ER=1 Q:ER
I XS(1)?1"S (DIC,DLAYGO)=""^RMPF(791".8NP1",DIC(0)=""MX""".1",DIC(""DR"")="".03///".E
E I XS(1)?1"S DA(1)=RMI,DLAYGO=791".8NP1",DIC=""^RMPF(791".22ANP1",DIC(0)=""MX""" S:'$D(RMI) ER=6
E I XS(1)?1"S DIE=""^RMPF(791".8NP!(XS(1)?1"S DA(1)=RMI,DIE=""^RMPF(791".22ANP)
E S ER=5
I XS(2)'?1"S X=".ANP,XS(2)'?1"S DR=".ANP S ER=7
I XS(3)'?1"D ^DIC".E,XS(3)'?1"D ^DIE" S ER=8
I XS(4)?1"K DIC,DLAYGO,DD,DO Q:Y=-1".ANP
E I XS(4)="K DIC,DA,DLAYGO,DD,DO Q:Y=-1 S (RMJ,DA)=+Y"!(XS(4)="K DIE,DA,DR")
E S ER=9
G PX:ER
X XS(1) I $D(DIC),$D(DIC(0)) S BF=1 S:'$D(DA(1)) BE=1
E I $D(DIE)
E S ER=2 G PX
X XS(2) S ER=$S($D(X):0,$D(DR):0,1:3) G PX:ER
X XS(3) I BF,Y=-1 K DD,DO S DIC(0)=DIC(0)_"L" D FILE^DICN
I BF,BE S CT=CT+1,XQSTXT(CT)="ENTRY: "_$P(Y,U,2)
X XS(4)
I RMPFNUM=791811!(RMPFNUM=791811.1) D MULTI
PX Q
MULTI I RMPFNUM=791811,'$D(^RMPF(791811,RMI,101,0)) S ^(0)="^791811.0101PA^0^0"
I RMPFNUM=791811,'$D(^RMPF(791811,RMI,102,0)) S ^(0)="^791811.0102PA^0^0"
I RMPFNUM=791811.1,'$D(^RMPF(791811.1,RMI,101,0)) S ^(0)="^791811.1101P^0^0"
Q
ERROR S ET=$P($T(ETEXT+ER),";",3)
S CT=CT+1,XQSTXT(CT)="ERROR: "_$P($T(ETEXT+ER),";",3)
F I=1:1:4 S CT=CT+1,XQSTXT(CT)=" XS("_I_")="_$S($D(XS(I)):XS(I),1:"UNDEF")
Q
;
ETEXT ;;
;;ARRAY NODE NOT DEFINED
;;VARIABLE NEEDED FOR OPERATION NOT DEFINED
;;INPUT VARIABLE STRING NOT DEFINED
;;GLOBAL CANNOT BE PROCESSED BY THIS SERVER
;;INVALID INSTRUCTION SPECIFIED - XS(1)
;;PREVIOUS-LEVEL LOOKUP NOT SUCCESSFUL
;;INVALID INSTRUCTION SPECIFIED - XS(2)
;;INVALID INSTRUCTION SPECIFIED - XS(3)
;;INVALID INSTRUCTION SPECIFIED - XS(4)
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFED 2894 printed Apr 09, 2024@21:39:08 Page 2
RMPFED ;KLQ/DDC;SERVER- ROES FILE UPDATES; [ 06/25/98 12:16 PM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**1,13,16**;JUN 16, 1995
+2 ;;Reference to ^XMB(3.9) supported by DBIA #10113
+3 if '$DATA(XMZ)
GOTO END
if 'XMZ
GOTO END
SET X=$$SUBGET^XMGAPI0(XMZ)
if X=""
GOTO END
+4 SET RMPFUN=$PIECE(X,"*",2)
SET RMPFNUM=$PIECE(X,"*",3)
SET RMPFMENU=0
DO ^RMPFUTL
+5 FOR CT=1:1:4
SET XQSTXT(CT)=" "
+6 SET CT=CT+1
SET XQSTXT(CT)="The following entries in the indicated file"
+7 SET CT=CT+1
SET XQSTXT(CT)="have been modified by Update #"_RMPFUN
+8 SET CT=CT+1
SET XQSTXT(CT)=" "
+9 SET CT=CT+1
SET XQSTXT(CT)="FILE: "_$SELECT($DATA(^RMPF(RMPFNUM,0)):$PIECE(^(0),U,1),1:RMPFNUM)
+10 SET CT=CT+1
SET XQSTXT(CT)=" "
+11 IF RMPFNUM'?1"791"1.NP
SET ER=4
DO ERROR
GOTO QUE
T1 KILL XS
FOR ML=1:1:4
XECUTE XMREC
if XMER=-1
QUIT
SET XS(ML)=XMRG
+1 IF XMER>-1
DO PROCESS
if ER
DO ERROR
GOTO T1
QUE IF $PIECE($HOROLOG,",",2)>86000
SET VW=($PIECE($HOROLOG,",",1)+1)_",00090"
+1 IF '$TEST
SET VW=$PIECE($HOROLOG,",",1)_","_($PIECE($HOROLOG,",",2)+90)
CONFIRM SET XMSUB="ROES UPDATE CONFIRMATION*"_RMPFUN
SET XMDUZ=.5
DO XMZ^XMA2
if XMZ=""
QUIT
+1 SET ^XMB(3.9,XMZ,2,0)="^3.92A^1^1^"_DT
+2 SET ^XMB(3.9,XMZ,2,1,0)=RMPFUN_U_RMPFSTAP
+3 SET XMY("S.RMPE-FILE-UPDATE-CONFIRM@DDC.DOMAIN.EXT")=""
+4 DO ENT1^XMD
END KILL BE,BF,CT,ER,ET,I,ML,RMPFNUM,RMPFUN,VW,RMPFSTAP
+1 KILL X,XMDUZ,XMSUB,XMY,XMZ,XS,ZTDESC,ZTDTH,ZTRTN,ZTSAVE
QUIT
PROCESS SET (BF,BE,ER)=0
FOR I=1:1:4
if '$DATA(XS(I))
SET ER=1
if ER
QUIT
+1 IF XS(1)?1"S (DIC,DLAYGO)=""^RMPF(791".8NP1",DIC(0)=""MX""".1",DIC(""DR"")="".03///".E
+2 IF '$TEST
IF XS(1)?1"S DA(1)=RMI,DLAYGO=791".8NP1",DIC=""^RMPF(791".22ANP1",DIC(0)=""MX"""
if '$DATA(RMI)
SET ER=6
+3 IF '$TEST
IF XS(1)?1"S DIE=""^RMPF(791".8NP!(XS(1)?1"S DA(1)=RMI,DIE=""^RMPF(791".22ANP)
+4 IF '$TEST
SET ER=5
+5 IF XS(2)'?1"S X=".ANP
IF XS(2)'?1"S DR=".ANP
SET ER=7
+6 IF XS(3)'?1"D ^DIC".E
IF XS(3)'?1"D ^DIE"
SET ER=8
+7 IF XS(4)?1"K DIC,DLAYGO,DD,DO Q:Y=-1".ANP
+8 IF '$TEST
IF XS(4)="K DIC,DA,DLAYGO,DD,DO Q:Y=-1 S (RMJ,DA)=+Y"!(XS(4)="K DIE,DA,DR")
+9 IF '$TEST
SET ER=9
+10 if ER
GOTO PX
+11 XECUTE XS(1)
IF $DATA(DIC)
IF $DATA(DIC(0))
SET BF=1
if '$DATA(DA(1))
SET BE=1
+12 IF '$TEST
IF $DATA(DIE)
+13 IF '$TEST
SET ER=2
GOTO PX
+14 XECUTE XS(2)
SET ER=$SELECT($DATA(X):0,$DATA(DR):0,1:3)
if ER
GOTO PX
+15 XECUTE XS(3)
IF BF
IF Y=-1
KILL DD,DO
SET DIC(0)=DIC(0)_"L"
DO FILE^DICN
+16 IF BF
IF BE
SET CT=CT+1
SET XQSTXT(CT)="ENTRY: "_$PIECE(Y,U,2)
+17 XECUTE XS(4)
+18 IF RMPFNUM=791811!(RMPFNUM=791811.1)
DO MULTI
PX QUIT
MULTI IF RMPFNUM=791811
IF '$DATA(^RMPF(791811,RMI,101,0))
SET ^(0)="^791811.0101PA^0^0"
+1 IF RMPFNUM=791811
IF '$DATA(^RMPF(791811,RMI,102,0))
SET ^(0)="^791811.0102PA^0^0"
+2 IF RMPFNUM=791811.1
IF '$DATA(^RMPF(791811.1,RMI,101,0))
SET ^(0)="^791811.1101P^0^0"
+3 QUIT
ERROR SET ET=$PIECE($TEXT(ETEXT+ER),";",3)
+1 SET CT=CT+1
SET XQSTXT(CT)="ERROR: "_$PIECE($TEXT(ETEXT+ER),";",3)
+2 FOR I=1:1:4
SET CT=CT+1
SET XQSTXT(CT)=" XS("_I_")="_$SELECT($DATA(XS(I)):XS(I),1:"UNDEF")
+3 QUIT
+4 ;
ETEXT ;;
+1 ;;ARRAY NODE NOT DEFINED
+2 ;;VARIABLE NEEDED FOR OPERATION NOT DEFINED
+3 ;;INPUT VARIABLE STRING NOT DEFINED
+4 ;;GLOBAL CANNOT BE PROCESSED BY THIS SERVER
+5 ;;INVALID INSTRUCTION SPECIFIED - XS(1)
+6 ;;PREVIOUS-LEVEL LOOKUP NOT SUCCESSFUL
+7 ;;INVALID INSTRUCTION SPECIFIED - XS(2)
+8 ;;INVALID INSTRUCTION SPECIFIED - XS(3)
+9 ;;INVALID INSTRUCTION SPECIFIED - XS(4)
+10 ;
+11 QUIT
