EEOEXE1 ;HISC/JWR - EEO SERVER ROUTINE (VERSION 2.0 SITES);2/25/93 13:03
;;2.0;EEO Complaint Tracking;**2**;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,X=$O(^DIC(4,"D",STANO,""))
G:EEOKEY'>19 ^EEOEEXE
I TYPE'="DATA"&(TYPE'="FILE")&(TYPE'="INV") S XQSTXT(10)="<ERROR> Message missent to the EEO_DATA Server" G EXIT
S X="NOW",%DT="DTXO" D ^%DT S NOWP=Y K %DT
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),"^")
F X=2:1 Q:'$D(^XMB(3.9,XMZ,2,X)) Q:^(X,0)="&&&&&"
F EEO("LINE")=2:1 Q:'$D(^XMB(3.9,XMZ,2,EEO("LINE"),0)) Q:(^(0))="&&&&&"
S EEO("LINE")=EEO("LINE")+1
F EEO("LINE")=EEO("LINE"):2 Q:'$D(^XMB(3.9,XMZ,2,EEO("LINE"),0)) D
.D:TYPE="DATA" DEC D:TYPE="FILE"!(TYPE="INV") STAN S EEO("LABEL")=$P(EEO("NODE"),U),EEO("DA")=$P(EEO("NODE"),U,3),(DIDEL,EEO("FILE"))=$P(EEO("NODE"),U,2),GEE=$P(EEO("NODE"),U,5),EEO("NODE")=$P(EEO("NODE"),U,4)
ELOCK .;Breaks doun data strings for decryption
.S:EEO("FILE")=789 EEO("FILE")=785 L +^EEO(EEO("FILE"),EEO("DA")):0 I $T=0 H 10 G ELOCK
.I EEO("LABEL")'="ANODE" S DA=EEO("DA"),DATA=$P(EEO("STRING"),U),DIE=EEO("FILE") K DR D @EEO("LABEL") K DR L -^EEO(EEO("FILE"),EEO("DA")) Q
.F EEO=1:1 S EEO("DATA")=$P(EEO("STRING"),"^",EEO) Q:$P(EEO("STRING"),"^",EEO,999)="" I EEO("DATA")]"" D
..S EEO("FIELD")=$O(^DD(EEO("FILE"),"GL",EEO("NODE"),EEO,""))
..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
.I EEO("FILE")=785 S DA=EEO("DA") D CASENO^EEOEOSE
.L -^EEO(EEO("FILE"),EEO("DA"))
EXITOK ;
I $G(EEO("FILE"))>780 L -^EEO(EEO("FILE"),0)
S X="XMA1C" X ^%ZOSF("TEST") I $T S XMSER="S.EEO UPLINK SERVER",XMZ=XQMSG D REMSBMSG^XMA1C
EXIT ;
S XMDUZ="EEO SERVER FOR "_^DD("SITE") K EEOD,EEODX,EEOE,EEO,DR,STANO,EEOKEY,DIDEL,CN1,CN2,CN3,DATA,TYPE,EEON1,EEONOD,EEOL Q
DEC ;Decryption on data strings
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
BASIS ;Basis data served
S DR="18.5///"_DATA,DR(2,785.01)=".01///"_DATA D ^DIE
Q
ISSUE ;Issue code served
S DR="17.5///"_DATA,DR(2,785.02)=".01///"_DATA_";1///"_$P(EEO("STRING"),U,2) D ^DIE
Q
CORR ;Corrective action served
S DR="61///"_DATA,DR(2,785.061)=".01///"_DATA D ^DIE
Q
INVEST ;Investigator data served
S EEO("ROOT")=""
I $D(^EEO(785,DA,11,"B",DATA)) S EEOETE=$O(^(DATA,0)) Q:EEOETE'>0 D
.F S EEOETE=$O(^EEO(785,DA,11,"B",DATA,EEOETE)) Q:EEOETE'>0 D
..K ^EEO(785,DA,11,"B",DATA,EEOETE),^EEO(785,DA,11,EEOETE)
.S (EEOFF,EEOETE)=0 F S EEOETE=$O(^EEO(785,DA,11,EEOETE)) Q:EEOETE'>0 S EEOFF=EEOFF+1,EEOFIV=EEOETE
.S:EEOFF>0 ^EEO(785,DA,11,0)="^785.03P^"_EEOFIV_"^"_EEOFF
.K EEOFF,EEOETE,EEOFIV
Q:GEE=0!('$D(^EEO(787.5,DATA))) S DATA(1)=$P($G(^EEO(787.5,DATA,0)),U)
S DR="27.5///"_DATA(1),DR(2,785.03)=".01///"_DATA(1)
F CN1=2:1:10 S DATA1=$P(EEO("STRING"),U,CN1) I DATA1'="" D
.S CN3=$O(^DD(785.03,"GL",0,CN1,""))
.S DR(2,785.03)=DR(2,785.03)_";"_CN3_"///"_DATA1
D ^DIE
WP 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
ADINV ;Update an investigator in file 787.5
S EEO("ROOT")="",DIE=787.5 S:EEO("NODE")=0 EEOINV=$P(EEO("STRING"),U)
F EEOPL=1:1:6 S EEOI(EEOPL)=$P(EEO("STRING"),U,EEOPL)
S DA=EEO("DA")
I EEO("NODE")=0 S DR=".01///"_EEOINV_";2///"_EEOI(3)_";3///"_EEOI(4)_";4///"_EEOI(5)_";5///"_EEOI(6)
I EEO("NODE")>0 S DR="27.5///"_EEOINV_";1///"_EEOI(1),DR(2,787.51)=".01///"_EEOI(1)_";1///"_EEOI(2)_";2///"_EEOI(3)
D ^DIE K EEOI,DR Q
INFILE ;Adds an investigator to file 787.5
N DIC S DINUM=DA,X=EEOINV,DIC="^EEO(787.5,",DIC(0)="L" D FILE^DICN
Q
IN ;Test for incomplete investigator info
S:EEO("DA")=0 DR="1///"_DATA,DR(2,787.51)=".01///"_DATA_";1///"_$P(EEO("STRING"),U,2)_";2///"_$P(EEO("STRING"),U,3) D ^DIE Q
ADDINV F CNT5=1:1:3 S ADDINV(CNT5)=$P(EEO("STRING"),U,CNT5)
S DR(2,787.51)=".01///"_ADDINV(1)_";1///"_ADDINV(2)_";2///"_ADDINV(3)
S DR="1///"_ADDINV(1),DA=EEO("DA"),DIE=787.5 D ^DIE
K CNT5,ADDINV,DR,DIE,DA Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEEOEXE1 4985 printed Dec 13, 2024@01:51:09 Page 2
EEOEXE1 ;HISC/JWR - EEO SERVER ROUTINE (VERSION 2.0 SITES);2/25/93 13:03
+1 ;;2.0;EEO Complaint Tracking;**2**;Apr 27, 1995
+2 if $DATA(X)
SET EEODX=X
SET XQSTXT="XQSTXT("
+3 IF '$DATA(^XMB(3.9,XMZ,2,1,0))
SET XQSTXT(10)="<ERROR> Could not find the first line of the message"
GOTO 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
SET X=$ORDER(^DIC(4,"D",STANO,""))
+5 if EEOKEY'>19
GOTO ^EEOEEXE
+6 IF TYPE'="DATA"&(TYPE'="FILE")&(TYPE'="INV")
SET XQSTXT(10)="<ERROR> Message missent to the EEO_DATA Server"
GOTO EXIT
+7 SET X="NOW"
SET %DT="DTXO"
DO ^%DT
SET NOWP=Y
KILL %DT
+8 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
+9 IF '$DATA(DOMFROM)
SET DOMFROM=$PIECE(^XMB(1,1,0),"^")
SET DOMFROM=$PIECE(^DIC(4.2,DOMFROM,0),"^")
+10 FOR X=2:1
if '$DATA(^XMB(3.9,XMZ,2,X))
QUIT
if ^(X,0)="&&&&&"
QUIT
+11 FOR EEO("LINE")=2:1
if '$DATA(^XMB(3.9,XMZ,2,EEO("LINE"),0))
QUIT
if (^(0))="&&&&&"
QUIT
+12 SET EEO("LINE")=EEO("LINE")+1
+13 FOR EEO("LINE")=EEO("LINE"):2
if '$DATA(^XMB(3.9,XMZ,2,EEO("LINE"),0))
QUIT
Begin DoDot:1
+14 if TYPE="DATA"
DO DEC
if TYPE="FILE"!(TYPE="INV")
DO STAN
SET EEO("LABEL")=$PIECE(EEO("NODE"),U)
SET EEO("DA")=$PIECE(EEO("NODE"),U,3)
SET (DIDEL,EEO("FILE"))=$PIECE(EEO("NODE"),U,2)
SET GEE=$PIECE(EEO("NODE"),U,5)
SET EEO("NODE")=$PIECE(EEO("NODE"),U,4)
ELOCK ;Breaks doun data strings for decryption
+1 if EEO("FILE")=789
SET EEO("FILE")=785
LOCK +^EEO(EEO("FILE"),EEO("DA")):0
IF $TEST=0
HANG 10
GOTO ELOCK
+2 IF EEO("LABEL")'="ANODE"
SET DA=EEO("DA")
SET DATA=$PIECE(EEO("STRING"),U)
SET DIE=EEO("FILE")
KILL DR
DO @EEO("LABEL")
KILL DR
LOCK -^EEO(EEO("FILE"),EEO("DA"))
QUIT
+3 FOR EEO=1:1
SET EEO("DATA")=$PIECE(EEO("STRING"),"^",EEO)
if $PIECE(EEO("STRING"),"^",EEO,999)=""
QUIT
IF EEO("DATA")]""
Begin DoDot:2
+4 SET EEO("FIELD")=$ORDER(^DD(EEO("FILE"),"GL",EEO("NODE"),EEO,""))
+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 ;S DIDEL=785
+10 SET DR=EEO("FIELD")_"///"_EEO("DATA")
DO ^DIE
End DoDot:2
+11 IF EEO("FILE")=785
SET DA=EEO("DA")
DO CASENO^EEOEOSE
+12 LOCK -^EEO(EEO("FILE"),EEO("DA"))
End DoDot:1
EXITOK ;
+1 IF $GET(EEO("FILE"))>780
LOCK -^EEO(EEO("FILE"),0)
+2 SET X="XMA1C"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET XMSER="S.EEO UPLINK SERVER"
SET XMZ=XQMSG
DO REMSBMSG^XMA1C
EXIT ;
+1 SET XMDUZ="EEO SERVER FOR "_^DD("SITE")
KILL EEOD,EEODX,EEOE,EEO,DR,STANO,EEOKEY,DIDEL,CN1,CN2,CN3,DATA,TYPE,EEON1,EEONOD,EEOL
QUIT
DEC ;Decryption on data strings
+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
BASIS ;Basis data served
+1 SET DR="18.5///"_DATA
SET DR(2,785.01)=".01///"_DATA
DO ^DIE
+2 QUIT
ISSUE ;Issue code served
+1 SET DR="17.5///"_DATA
SET DR(2,785.02)=".01///"_DATA_";1///"_$PIECE(EEO("STRING"),U,2)
DO ^DIE
+2 QUIT
CORR ;Corrective action served
+1 SET DR="61///"_DATA
SET DR(2,785.061)=".01///"_DATA
DO ^DIE
+2 QUIT
INVEST ;Investigator data served
+1 SET EEO("ROOT")=""
+2 IF $DATA(^EEO(785,DA,11,"B",DATA))
SET EEOETE=$ORDER(^(DATA,0))
if EEOETE'>0
QUIT
Begin DoDot:1
+3 FOR
SET EEOETE=$ORDER(^EEO(785,DA,11,"B",DATA,EEOETE))
if EEOETE'>0
QUIT
Begin DoDot:2
+4 KILL ^EEO(785,DA,11,"B",DATA,EEOETE),^EEO(785,DA,11,EEOETE)
End DoDot:2
+5 SET (EEOFF,EEOETE)=0
FOR
SET EEOETE=$ORDER(^EEO(785,DA,11,EEOETE))
if EEOETE'>0
QUIT
SET EEOFF=EEOFF+1
SET EEOFIV=EEOETE
+6 if EEOFF>0
SET ^EEO(785,DA,11,0)="^785.03P^"_EEOFIV_"^"_EEOFF
+7 KILL EEOFF,EEOETE,EEOFIV
End DoDot:1
+8 if GEE=0!('$DATA(^EEO(787.5,DATA)))
QUIT
SET DATA(1)=$PIECE($GET(^EEO(787.5,DATA,0)),U)
+9 SET DR="27.5///"_DATA(1)
SET DR(2,785.03)=".01///"_DATA(1)
+10 FOR CN1=2:1:10
SET DATA1=$PIECE(EEO("STRING"),U,CN1)
IF DATA1'=""
Begin DoDot:1
+11 SET CN3=$ORDER(^DD(785.03,"GL",0,CN1,""))
+12 SET DR(2,785.03)=DR(2,785.03)_";"_CN3_"///"_DATA1
End DoDot:1
+13 DO ^DIE
WP 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)
+2 QUIT
ADINV ;Update an investigator in file 787.5
+1 SET EEO("ROOT")=""
SET DIE=787.5
if EEO("NODE")=0
SET EEOINV=$PIECE(EEO("STRING"),U)
+2 FOR EEOPL=1:1:6
SET EEOI(EEOPL)=$PIECE(EEO("STRING"),U,EEOPL)
+3 SET DA=EEO("DA")
+4 IF EEO("NODE")=0
SET DR=".01///"_EEOINV_";2///"_EEOI(3)_";3///"_EEOI(4)_";4///"_EEOI(5)_";5///"_EEOI(6)
+5 IF EEO("NODE")>0
SET DR="27.5///"_EEOINV_";1///"_EEOI(1)
SET DR(2,787.51)=".01///"_EEOI(1)_";1///"_EEOI(2)_";2///"_EEOI(3)
+6 DO ^DIE
KILL EEOI,DR
QUIT
INFILE ;Adds an investigator to file 787.5
+1 NEW DIC
SET DINUM=DA
SET X=EEOINV
SET DIC="^EEO(787.5,"
SET DIC(0)="L"
DO FILE^DICN
+2 QUIT
IN ;Test for incomplete investigator info
+1 if EEO("DA")=0
SET DR="1///"_DATA
SET DR(2,787.51)=".01///"_DATA_";1///"_$PIECE(EEO("STRING"),U,2)_";2///"_$PIECE(EEO("STRING"),U,3)
DO ^DIE
QUIT
ADDINV FOR CNT5=1:1:3
SET ADDINV(CNT5)=$PIECE(EEO("STRING"),U,CNT5)
+1 SET DR(2,787.51)=".01///"_ADDINV(1)_";1///"_ADDINV(2)_";2///"_ADDINV(3)
+2 SET DR="1///"_ADDINV(1)
SET DA=EEO("DA")
SET DIE=787.5
DO ^DIE
+3 KILL CNT5,ADDINV,DR,DIE,DA
QUIT
