- 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 Jan 18, 2025@02:52:07 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