EEOEEXE ;HISC/JWR - EEO SERVER ROUTINE (VERSION 1.0 SITES);2/25/93 13:03
;;2.0;EEO Complaint Tracking;;Apr 27, 1995
S:$D(X) EEODX=X S XQSTXT="XQSTXT("
;I '$D(^XMB(3.9,XMZ,2,1,0)) S XQSTXT(10)="<ERROR> Could not find the first line of the message" G EXIT
S STANO=^XMB(3.9,XMZ,2,1,0),TYPE=$P(STANO,"^",2),EEOKEY=$P($G(STANO),"^",3),STANO=+STANO Q:EEOKEY>19
;S X=$O(^DIC(4,"D",STANO,"")) ;I X="" S XQSTXT(10)="<ERROR> Could not find the station requested "_STANO_" Call the ISC. XMZ= "_XMZ G EXIT
;S STAPTR=X
I '(TYPE="DATA") S XQSTXT(10)="<ERROR> Message missent to the EEO_DATA Server" G EXIT
;Q:TYPE["STATUS"
S X="NOW",%DT="DTXO" D ^%DT S NOWP=Y K %DT
S CNTR=10,EEOKEY=$P(^XMB(3.9,XMZ,2,1,0),U,3)
F X=.001:.001 Q:'$D(^XMB(3.9,XMZ,2,X,0)) S Y=^(0) I Y["Message-ID:<" S DOMFROM=$P(Y,"@",2),DOMFROM=$P(DOMFROM,">",1) Q
I '$D(DOMFROM) S DOMFROM=$P(^XMB(1,1,0),"^"),DOMFROM=$P(^DIC(4.2,DOMFROM,0),"^")
K EEOD("MESS") F X=2:1 Q:'$D(^XMB(3.9,XMZ,2,X)) Q:^(X,0)="&&&&&"
S EEOD("&&&&&")=X
F EEO("LINE")=2:1 Q:'$D(^XMB(3.9,XMZ,2,EEO("LINE"),0)) Q:(^(0))="&&&&&" Q:EEO("LINE")'>0
S EEOM("DA")="",EEO("LINE")=EEO("LINE")+1
F EEO("LINE")=EEO("LINE"):2 Q:'$D(^XMB(3.9,XMZ,2,EEO("LINE"),0)) D
.I EEOKEY>10 D DEC S EEO("DA")=$P(EEO("NODE"),U,2),EEO("FILE")=+EEO("NODE"),EEO("NODE")=$P(EEO("NODE"),U,3),EEOQ=-1 D:EEOKEY<20&(EEO("NODE")=1!(EEO("NODE")=3)) F2MUL^EEOUTIL G ELOCK
NORM .S EEO("NODE")=^XMB(3.9,XMZ,2,EEO("LINE"),0),(DIDEL,EEO("FILE"))=+EEO("NODE"),EEO("DA")=$P(EEO("NODE"),"^",2),EEO("NODE")=$P(EEO("NODE"),"^",3),EEOQ=-1
.S EEO("STRING")=^XMB(3.9,XMZ,2,EEO("LINE")+1,0)
ELOCK .L +^EEO(EEO("FILE"),EEO("DA")):0 I '$T H 30 G ELOCK
.F EEO=1:1 S EEO("DATA")=$P(EEO("STRING"),"^",EEO) Q:$P(EEO("STRING"),"^",EEO,999)="" I EEO("DATA")]"" D
..I $O(^DD(EEO("FILE"),"GL",EEO("NODE"),""))=0 D MULT Q
..S EEO("FIELD")=$O(^DD(EEO("FILE"),"GL",EEO("NODE"),EEO,""))
..S EEO("ROOT")=^DIC(EEO("FILE"),0,"GL")
..I '$D(^EEO(EEO("FILE"),EEO("DA"))) K DD,DIC,DINUM,DO S DIC="^EEO("_EEO("FILE")_",",DIC(0)="L",DLAYGO=EEO("FILE"),DINUM=EEO("DA"),X=$P(EEO("DATA"),"^",1) D FILE^DICN Q:Y<1 K DINUM,DLAYGO
..Q:EEO("FIELD")=""
..K DR S DIE=EEO("FILE"),DA=EEO("DA")
..I $P(^DD(EEO("FILE"),EEO("FIELD"),0),U,2)["D" S DR=EEO("FIELD")_"////"_EEO("DATA") D ^DIE Q
..S DIDEL=785
..S DR=EEO("FIELD")_"///"_EEO("DATA") D ^DIE
EXITOK S X="XMA1C" X ^%ZOSF("TEST") I $T S XMSER="S.EEO UPLINK SERVER",XMZ=XQMSG D REMSBMSG^XMA1C
L -^EEO(EEO("FILE"),EEO("DA"))
EXIT ;Kills local variables
S XMDUZ="EEO SERVER FOR "_^DD("SITE") K EEOD,EEODX,EEOE,EEO,DR,STANO,EEOKEY,DIDEL,CN1,CN2,CN3,DATA,EENOD,EEOL,EEON,TYPE Q
ERR G EXIT
Q
DEC ;Decrypts messages from version 1.0 sites
K EEO("STRING") S X=^XMB(3.9,XMZ,2,EEO("LINE"),0),X1=$$SITE^EEOEEXMT,X2=EEO("LINE")
D DE^XUSHSHP S EEO("NODE")=X,X2=X2+1
S EEON1=^XMB(3.9,XMZ,2,EEO("LINE")+1,0),EEOL=$L(EEON1)
I EEOL<50 S X=EEON1 D DE^XUSHSHP S EEO("STRING")=X Q
I EEOL'<50 F EEOC=0:50:250 S X=$E(EEON1,EEOC+1,EEOC+50) D DE^XUSHSHP D
.I $D(EEO("STRING")) S EEO("STRING")=EEO("STRING")_X Q
.I '$D(EEO("STRING")) S EEO("STRING")=X
K EEOL,EEON1,EEOC Q
Q
MULT ;Converts Version 1 non-multiples into version 2 multiple fields
S DIE=EEO("FILE"),EEO("FIELD")=$O(^DD(EEO("FILE"),"GL",EEO("NODE"),0,"")),SUB=+$P($G(^DD(EEO("FILE"),EEO("FIELD"),0)),U,2)
S DR=EEO("FIELD")_"///"_$P(EEO("STRING"),U)
SUBDR ;Makes sub-DR strings for Multiple fields
F EEO1=1:1 Q:$P(EEO("STRING"),U,EEO1,999)="" S EEO("DATA1")=$P(EEO("STRING"),U,EEO1) D
.S SUB1=$O(^DD(SUB,"GL",0,EEO1,"")),DR(2,SUB)=SUB1_"///"_EEO("DATA1")
D ^DIE
K DR,SUB,SUB1,EEO1 Q
STAN S EEO("NODE")=^XMB(3.9,XMZ,2,EEO("LINE"),0)
S EEO("STRING")=^XMB(3.9,XMZ,2,EEO("LINE")+1,0) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEEOEEXE 3727 printed Apr 09, 2024@20:56:23 Page 2
EEOEEXE ;HISC/JWR - EEO SERVER ROUTINE (VERSION 1.0 SITES);2/25/93 13:03
+1 ;;2.0;EEO Complaint Tracking;;Apr 27, 1995
+2 if $DATA(X)
SET EEODX=X
SET XQSTXT="XQSTXT("
+3 ;I '$D(^XMB(3.9,XMZ,2,1,0)) S XQSTXT(10)="<ERROR> Could not find the first line of the message" G EXIT
+4 SET STANO=^XMB(3.9,XMZ,2,1,0)
SET TYPE=$PIECE(STANO,"^",2)
SET EEOKEY=$PIECE($GET(STANO),"^",3)
SET STANO=+STANO
if EEOKEY>19
QUIT
+5 ;S X=$O(^DIC(4,"D",STANO,"")) ;I X="" S XQSTXT(10)="<ERROR> Could not find the station requested "_STANO_" Call the ISC. XMZ= "_XMZ G EXIT
+6 ;S STAPTR=X
+7 IF '(TYPE="DATA")
SET XQSTXT(10)="<ERROR> Message missent to the EEO_DATA Server"
GOTO EXIT
+8 ;Q:TYPE["STATUS"
+9 SET X="NOW"
SET %DT="DTXO"
DO ^%DT
SET NOWP=Y
KILL %DT
+10 SET CNTR=10
SET EEOKEY=$PIECE(^XMB(3.9,XMZ,2,1,0),U,3)
+11 FOR X=.001:.001
if '$DATA(^XMB(3.9,XMZ,2,X,0))
QUIT
SET Y=^(0)
IF Y["Message-ID:<"
SET DOMFROM=$PIECE(Y,"@",2)
SET DOMFROM=$PIECE(DOMFROM,">",1)
QUIT
+12 IF '$DATA(DOMFROM)
SET DOMFROM=$PIECE(^XMB(1,1,0),"^")
SET DOMFROM=$PIECE(^DIC(4.2,DOMFROM,0),"^")
+13 KILL EEOD("MESS")
FOR X=2:1
if '$DATA(^XMB(3.9,XMZ,2,X))
QUIT
if ^(X,0)="&&&&&"
QUIT
+14 SET EEOD("&&&&&")=X
+15 FOR EEO("LINE")=2:1
if '$DATA(^XMB(3.9,XMZ,2,EEO("LINE"),0))
QUIT
if (^(0))="&&&&&"
QUIT
if EEO("LINE")'>0
QUIT
+16 SET EEOM("DA")=""
SET EEO("LINE")=EEO("LINE")+1
+17 FOR EEO("LINE")=EEO("LINE"):2
if '$DATA(^XMB(3.9,XMZ,2,EEO("LINE"),0))
QUIT
Begin DoDot:1
+18 IF EEOKEY>10
DO DEC
SET EEO("DA")=$PIECE(EEO("NODE"),U,2)
SET EEO("FILE")=+EEO("NODE")
SET EEO("NODE")=$PIECE(EEO("NODE"),U,3)
SET EEOQ=-1
if EEOKEY<20&(EEO("NODE")=1!(EEO("NODE")=3))
DO F2MUL^EEOUTIL
GOTO ELOCK
NORM SET EEO("NODE")=^XMB(3.9,XMZ,2,EEO("LINE"),0)
SET (DIDEL,EEO("FILE"))=+EEO("NODE")
SET EEO("DA")=$PIECE(EEO("NODE"),"^",2)
SET EEO("NODE")=$PIECE(EEO("NODE"),"^",3)
SET EEOQ=-1
+1 SET EEO("STRING")=^XMB(3.9,XMZ,2,EEO("LINE")+1,0)
ELOCK LOCK +^EEO(EEO("FILE"),EEO("DA")):0
IF '$TEST
HANG 30
GOTO ELOCK
+1 FOR EEO=1:1
SET EEO("DATA")=$PIECE(EEO("STRING"),"^",EEO)
if $PIECE(EEO("STRING"),"^",EEO,999)=""
QUIT
IF EEO("DATA")]""
Begin DoDot:2
+2 IF $ORDER(^DD(EEO("FILE"),"GL",EEO("NODE"),""))=0
DO MULT
QUIT
+3 SET EEO("FIELD")=$ORDER(^DD(EEO("FILE"),"GL",EEO("NODE"),EEO,""))
+4 SET EEO("ROOT")=^DIC(EEO("FILE"),0,"GL")
+5 IF '$DATA(^EEO(EEO("FILE"),EEO("DA")))
KILL DD,DIC,DINUM,DO
SET DIC="^EEO("_EEO("FILE")_","
SET DIC(0)="L"
SET DLAYGO=EEO("FILE")
SET DINUM=EEO("DA")
SET X=$PIECE(EEO("DATA"),"^",1)
DO FILE^DICN
if Y<1
QUIT
KILL DINUM,DLAYGO
+6 if EEO("FIELD")=""
QUIT
+7 KILL DR
SET DIE=EEO("FILE")
SET DA=EEO("DA")
+8 IF $PIECE(^DD(EEO("FILE"),EEO("FIELD"),0),U,2)["D"
SET DR=EEO("FIELD")_"////"_EEO("DATA")
DO ^DIE
QUIT
+9 SET DIDEL=785
+10 SET DR=EEO("FIELD")_"///"_EEO("DATA")
DO ^DIE
End DoDot:2
End DoDot:1
EXITOK SET X="XMA1C"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET XMSER="S.EEO UPLINK SERVER"
SET XMZ=XQMSG
DO REMSBMSG^XMA1C
+1 LOCK -^EEO(EEO("FILE"),EEO("DA"))
EXIT ;Kills local variables
+1 SET XMDUZ="EEO SERVER FOR "_^DD("SITE")
KILL EEOD,EEODX,EEOE,EEO,DR,STANO,EEOKEY,DIDEL,CN1,CN2,CN3,DATA,EENOD,EEOL,EEON,TYPE
QUIT
ERR GOTO EXIT
+1 QUIT
DEC ;Decrypts messages from version 1.0 sites
+1 KILL EEO("STRING")
SET X=^XMB(3.9,XMZ,2,EEO("LINE"),0)
SET X1=$$SITE^EEOEEXMT
SET X2=EEO("LINE")
+2 DO DE^XUSHSHP
SET EEO("NODE")=X
SET X2=X2+1
+3 SET EEON1=^XMB(3.9,XMZ,2,EEO("LINE")+1,0)
SET EEOL=$LENGTH(EEON1)
+4 IF EEOL<50
SET X=EEON1
DO DE^XUSHSHP
SET EEO("STRING")=X
QUIT
+5 IF EEOL'<50
FOR EEOC=0:50:250
SET X=$EXTRACT(EEON1,EEOC+1,EEOC+50)
DO DE^XUSHSHP
Begin DoDot:1
+6 IF $DATA(EEO("STRING"))
SET EEO("STRING")=EEO("STRING")_X
QUIT
+7 IF '$DATA(EEO("STRING"))
SET EEO("STRING")=X
End DoDot:1
+8 KILL EEOL,EEON1,EEOC
QUIT
+9 QUIT
MULT ;Converts Version 1 non-multiples into version 2 multiple fields
+1 SET DIE=EEO("FILE")
SET EEO("FIELD")=$ORDER(^DD(EEO("FILE"),"GL",EEO("NODE"),0,""))
SET SUB=+$PIECE($GET(^DD(EEO("FILE"),EEO("FIELD"),0)),U,2)
+2 SET DR=EEO("FIELD")_"///"_$PIECE(EEO("STRING"),U)
SUBDR ;Makes sub-DR strings for Multiple fields
+1 FOR EEO1=1:1
if $PIECE(EEO("STRING"),U,EEO1,999)=""
QUIT
SET EEO("DATA1")=$PIECE(EEO("STRING"),U,EEO1)
Begin DoDot:1
+2 SET SUB1=$ORDER(^DD(SUB,"GL",0,EEO1,""))
SET DR(2,SUB)=SUB1_"///"_EEO("DATA1")
End DoDot:1
+3 DO ^DIE
+4 KILL DR,SUB,SUB1,EEO1
QUIT
STAN SET EEO("NODE")=^XMB(3.9,XMZ,2,EEO("LINE"),0)
+1 SET EEO("STRING")=^XMB(3.9,XMZ,2,EEO("LINE")+1,0)
QUIT
