EEOEXE1.m

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 ---EEOEXE1   4985     printed  Apr 23, 2025@18:05:39                                                                                                                                                                                                     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