EEOEOSE ;HISC/JWR - Security check ;11/11/92 13:35
;;2.0;EEO Complaint Tracking;**1,8**;Apr 27, 1995
S U="^" K FAIL
I '$D(DUZ) D ERROR S FAIL=1 Q
D EEOYSTN I '$D(EEOYSTN) D ERROR S FAIL=1 Q
I EEOYSTN="" D ERROR S FAIL=1 Q
S (EEOYSCR,DIC("S"),FAIL)=""
S EEOSTNAM=$P(^DIC(4,EEOYSPTR,0),U,1) Q
ERROR ;Comes here for error message
W !!,?3,$C(7),"Contact Information Resource Management for access privileges."
Q
KILL ;kills local variables
K EEOSTPTR,EEOYSTN,EEOYANS,EEOSTNAM,EEOYSPTR,EEOYSCR,EEOYQ,DIC,DIE,DA,DIR,DR,EDA,FAIL,EDIT,SITE,CLIENT,CLIENTNO,SERV,SERVNO,STANO,WHAT,EN2,EN1,EP1,EP2,EF,EG,EH,EI,HE,EEODIC,EEONAME,EEOY
K A3,A5,ACP,ACR,ADDINV,ADV,AZ,B1,BLANK,BOX,BYCASE,CLO,CN,CN1,CN2,CN3,CNT,CNTR,CNT5,CNZ,CRT,CX,CT,D1,DATA,DATA1,DECR,DEL,DHD,DIDEL,DINUM,DOMFROM,E3,EC1,EDO,EEO,EEO1,EEO1J,EEO1L,EEO2,EEOA,EEOAX,EEOB,EEOC,EEODAD,EEODATE,EEODT
K EEOEE,EEOI,EEOFILE,EEOINV,EEOKEY,EEOM,EEON0,EEON5,EEOO,EEOOE,EEOP1,EEOPL,EEOQ,EEOR,EEOREV,EEOS,EEOSEQ,EEOT,EEOTMP,EEOTYPE,EEOXX,EEOY1,EEOYI,EEOYZ,EEOZI,EEX,EF,EFLG,EN3,ENP1,ENP2,ENP3,EO1,EOO,EOO1,F1,F2,F3,FAD,FF,FLD,FYI,HEA
K INP,INV,KN,KN1,KT,KT1,KT7,LABEL,MFILE,NOD,NOW,NOWP,PFILE,PIE,PIECE,SPOT,STN,STRING,SUB,SUB1,TYPE,XMY,XMZ,EEOVA,EEOTITL,CNT1,CON,DTO,EEOG,EEON3,POP,XMSER,XMSUB,XMTEXT,XQMSG,DIS(0)
K AEE,BEE,CEE,DEE,EEE,FEE,GEE,VEE,NEE,OEE,LEE,KEE,JEE,PEE,EEOII,EEON1,EEON2,EEON3,EEON5,EEON6,EEON12,EEOZ,EEOFF,EEOCTF,EEOMU,EEO3,EEOOF,EEOPT,TMP,C,CNO,CNQ,CNU,CNY,DO,DDH,DI,DQ,EEO3,EEOOF,EEOP,TMP("EEOACK"),D0
Q
EEOYSTN ;Determines station number
K EEOYSTN I $$SITE^EEOEEXMT'=$$SERVNO^EEOEEXMT S EEOYSTN=$$SITE^EEOEEXMT D PTR Q
K DIC,DIC(0)
S EEOYSTN=$P(^EEO(789.5,1,0),"^")
Q:'$D(EEOYSTN)
PTR ;Determines Institution file IEN for station
S EEOYSPTR=$O(^DIC(4,"D",EEOYSTN,""))
Q
SCREEN(Y) ;Provides a general security check for access to complaints
N DIC S DIC=$S($D(DIE):DIE,$D(DIC):DIC,1:$G(DCC)) N DIE S DIE=DIC
I $G(EEOCOUNS)>0 D SECED^EEOUTIL G:EEOSEC=1 NAY K EEOSEC
I $G(EEOCOUNS)'>0 I $P($G(^EEO(785,Y,1)),U,3)'>0&(+$G(^EEO(785,Y,"SEC"))'>0) G Q
I $G(XQY0)["Edit" G:$P($G(^EEO(785,Y,1)),U,3)'="" DELL I $P($G(^(1)),U,3)=""&(+$G(^EEO(785,Y,"SEC"))'=DUZ) G NAY
I XQY0["Informal" D SECED^EEOUTIL I $G(EEOSEC)=1 K EEOSEC G NAY
DELL ;Checks for delete status
I +Y>0 I $P($G(^EEO(785,+Y,12)),U,2)="D" G NAY
I $G(EEOCOUNS)'>0,$P($G(^EEO(785,+Y,1)),U,3)="",+$G(^EEO(785,+Y,"SEC"))="" G Q
I $G(EEOCOUNS)>0,+$G(^EEO(785,+Y,"SEC"))=DUZ G Q
I $G(EEOCOUNS)'>0 I $P($G(^EEO(785,+Y,1)),U,3)>0!(+$G(^EEO(785,+Y,"SEC"))=DUZ) G Q
NAY K EEOSEC I 0
Q Q $T
CASENO ;Calculates the case number
Q:$G(DA)'>0&($G(XMZ)>0)
S EEOZ=$S('$D(^EEO(785,DA,1)):"P",'$P(^(1),"^",3):"P",$E($P(^(1),"^",3),4,5)>9:$E($P(^(1),"^",3),2,3)+1,1:$E($P(^(1),"^",3),2,3))
S EEOZ=EEOZ_"-"_(DA\100000)_"-"_(100000-(DA-((DA\100000)*100000)))
N DR S DR="1.3///"_EEOZ D ^DIE K DR
Q
INPUT ;Entry point to determine most computed date fields
;I EN1="1;2" I $P($G(^EEO(785,D0,1)),U,3)<1&($P($G(^(1)),U,2)<1)&($P($G(^EEO(785,D0,6)),U,3)>0) S X1=$P($G(^(6)),U,3),X2=$P($G(^EEO(785,D0,1)),U,12) D ^%DTC Q
S EP1=$P(EN1,";",2),EN1=$P(EN1,";"),EP2=$P(EN2,";",2),EN2=$P(EN2,";")
S ET2=$P($G(^EEO(785,D0,EN2)),U,EP2)
S ET1=$P($G(^EEO(785,D0,EN1)),U,EP1)
S ETC=$S($P($G(^EEO(785,D0,4)),U)>0:+$G(^(4)),$P($G(^EEO(785,D0,5)),U,12)>0&(EN1'=4):$P(^(5),U,12),1:"")
S X2=$S(ET2'="":ET2,1:"")
S (EN4,X1)=$S(ET1'="":ET1,ET2="":X2,ETC'="":ETC,1:DT)
I X2>ETC&(ETC=X1) S X=" " D KINP Q
D ^%DTC S:ETC=""&(EN4=DT) X=X_"*"
KINP K EP1,EN1,EN2,EP1,EP2,EG,EH,EN4,ETC,ET1,ET2
Q
DEL() ;Security check for deletions to EEO files
I '($D(STANO)!($D(EEOYSTN))) W !!,"NO DELETEIONS EXCEPT THROUGH EEO PACKAGE",!! G Q
G NAY
NOSEC ;No security message
K EEOYSTN,EEOYSPTR W !!,"NO SECURITY FOR EEO DATA ACCESS FOR THIS STATION",!! Q
NODE ;Assignments of file 785 IENs are made here
I 'STANO W !!,"MUST ENTER THROUGH ASSOCIATED PACKAGE",!! K X Q
Q:$G(DIC(0))'["L"
L +^EEO(785,0):0 S Z=$O(^EEO(785,"ANODE",STANO*100000)) I Z=""!(Z>(STANO+1*100000-1)) S DINUM=STANO+1*100000-1 G NODE1
S DINUM=Z-1 I $D(EEO("DA")),$D(^EEO(785,EEO("DA"))) K DINUM L -^EEO(785,0) Q
NODE1 I $D(^EEO(785,"ANODE",DINUM)) S DINUM=DINUM-1 G NODE1
L -^EEO(785,0) Q
TEST ;Part of input transform for .01 field of file 785
S Y(0)=Y S:'$D(XQY0) XQY0="" S D0=$S($D(D0):D0,+Y>0:+Y,$D(DS):+DS,1:"")
I D0'>0 Q
S:$P($G(^EEO(785,D0,1)),U,3)=""&($G(^EEO(785,D0,"SEC"))'=DUZ!(XQY0["REPORT")!(XQY0["ADHOC")) Y=$P($G(^EEO(785,D0,5)),U,6) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEEOEOSE 4496 printed Apr 09, 2024@20:56:26 Page 2
EEOEOSE ;HISC/JWR - Security check ;11/11/92 13:35
+1 ;;2.0;EEO Complaint Tracking;**1,8**;Apr 27, 1995
+2 SET U="^"
KILL FAIL
+3 IF '$DATA(DUZ)
DO ERROR
SET FAIL=1
QUIT
+4 DO EEOYSTN
IF '$DATA(EEOYSTN)
DO ERROR
SET FAIL=1
QUIT
+5 IF EEOYSTN=""
DO ERROR
SET FAIL=1
QUIT
+6 SET (EEOYSCR,DIC("S"),FAIL)=""
+7 SET EEOSTNAM=$PIECE(^DIC(4,EEOYSPTR,0),U,1)
QUIT
ERROR ;Comes here for error message
+1 WRITE !!,?3,$CHAR(7),"Contact Information Resource Management for access privileges."
+2 QUIT
KILL ;kills local variables
+1 KILL EEOSTPTR,EEOYSTN,EEOYANS,EEOSTNAM,EEOYSPTR,EEOYSCR,EEOYQ,DIC,DIE,DA,DIR,DR,EDA,FAIL,EDIT,SITE,CLIENT,CLIENTNO,SERV,SERVNO,STANO,WHAT,EN2,EN1,EP1,EP2,EF,EG,EH,EI,HE,EEODIC,EEONAME,EEOY
+2 KILL A3,A5,ACP,ACR,ADDINV,ADV,AZ,B1,BLANK,BOX,BYCASE,CLO,CN,CN1,CN2,CN3,CNT,CNTR,CNT5,CNZ,CRT,CX,CT,D1,DATA,DATA1,DECR,DEL,DHD,DIDEL,DINUM,DOMFROM,E3,EC1,EDO,EEO,EEO1,EEO1J,EEO1L,EEO2,EEOA,EEOAX,EEOB,EEOC,EEODAD,EEODATE,EEODT
+3 KILL EEOEE,EEOI,EEOFILE,EEOINV,EEOKEY,EEOM,EEON0,EEON5,EEOO,EEOOE,EEOP1,EEOPL,EEOQ,EEOR,EEOREV,EEOS,EEOSEQ,EEOT,EEOTMP,EEOTYPE,EEOXX,EEOY1,EEOYI,EEOYZ,EEOZI,EEX,EF,EFLG,EN3,ENP1,ENP2,ENP3,EO1,EOO,EOO1,F1,F2,F3,FAD,FF,FLD,FYI,HEA
+4 KILL INP,INV,KN,KN1,KT,KT1,KT7,LABEL,MFILE,NOD,NOW,NOWP,PFILE,PIE,PIECE,SPOT,STN,STRING,SUB,SUB1,TYPE,XMY,XMZ,EEOVA,EEOTITL,CNT1,CON,DTO,EEOG,EEON3,POP,XMSER,XMSUB,XMTEXT,XQMSG,DIS(0)
+5 KILL AEE,BEE,CEE,DEE,EEE,FEE,GEE,VEE,NEE,OEE,LEE,KEE,JEE,PEE,EEOII,EEON1,EEON2,EEON3,EEON5,EEON6,EEON12,EEOZ,EEOFF,EEOCTF,EEOMU,EEO3,EEOOF,EEOPT,TMP,C,CNO,CNQ,CNU,CNY,DO,DDH,DI,DQ,EEO3,EEOOF,EEOP,TMP("EEOACK"),D0
+6 QUIT
EEOYSTN ;Determines station number
+1 KILL EEOYSTN
IF $$SITE^EEOEEXMT'=$$SERVNO^EEOEEXMT
SET EEOYSTN=$$SITE^EEOEEXMT
DO PTR
QUIT
+2 KILL DIC,DIC(0)
+3 SET EEOYSTN=$PIECE(^EEO(789.5,1,0),"^")
+4 if '$DATA(EEOYSTN)
QUIT
PTR ;Determines Institution file IEN for station
+1 SET EEOYSPTR=$ORDER(^DIC(4,"D",EEOYSTN,""))
+2 QUIT
SCREEN(Y) ;Provides a general security check for access to complaints
+1 NEW DIC
SET DIC=$SELECT($DATA(DIE):DIE,$DATA(DIC):DIC,1:$GET(DCC))
NEW DIE
SET DIE=DIC
+2 IF $GET(EEOCOUNS)>0
DO SECED^EEOUTIL
if EEOSEC=1
GOTO NAY
KILL EEOSEC
+3 IF $GET(EEOCOUNS)'>0
IF $PIECE($GET(^EEO(785,Y,1)),U,3)'>0&(+$GET(^EEO(785,Y,"SEC"))'>0)
GOTO Q
+4 IF $GET(XQY0)["Edit"
if $PIECE($GET(^EEO(785,Y,1)),U,3)'=""
GOTO DELL
IF $PIECE($GET(^(1)),U,3)=""&(+$GET(^EEO(785,Y,"SEC"))'=DUZ)
GOTO NAY
+5 IF XQY0["Informal"
DO SECED^EEOUTIL
IF $GET(EEOSEC)=1
KILL EEOSEC
GOTO NAY
DELL ;Checks for delete status
+1 IF +Y>0
IF $PIECE($GET(^EEO(785,+Y,12)),U,2)="D"
GOTO NAY
+2 IF $GET(EEOCOUNS)'>0
IF $PIECE($GET(^EEO(785,+Y,1)),U,3)=""
IF +$GET(^EEO(785,+Y,"SEC"))=""
GOTO Q
+3 IF $GET(EEOCOUNS)>0
IF +$GET(^EEO(785,+Y,"SEC"))=DUZ
GOTO Q
+4 IF $GET(EEOCOUNS)'>0
IF $PIECE($GET(^EEO(785,+Y,1)),U,3)>0!(+$GET(^EEO(785,+Y,"SEC"))=DUZ)
GOTO Q
NAY KILL EEOSEC
IF 0
Q QUIT $TEST
CASENO ;Calculates the case number
+1 if $GET(DA)'>0&($GET(XMZ)>0)
QUIT
+2 SET EEOZ=$SELECT('$DATA(^EEO(785,DA,1)):"P",'$PIECE(^(1),"^",3):"P",$EXTRACT($PIECE(^(1),"^",3),4,5)>9:$EXTRACT($PIECE(^(1),"^",3),2,3)+1,1:$EXTRACT($PIECE(^(1),"^",3),2,3))
+3 SET EEOZ=EEOZ_"-"_(DA\100000)_"-"_(100000-(DA-((DA\100000)*100000)))
+4 NEW DR
SET DR="1.3///"_EEOZ
DO ^DIE
KILL DR
+5 QUIT
INPUT ;Entry point to determine most computed date fields
+1 ;I EN1="1;2" I $P($G(^EEO(785,D0,1)),U,3)<1&($P($G(^(1)),U,2)<1)&($P($G(^EEO(785,D0,6)),U,3)>0) S X1=$P($G(^(6)),U,3),X2=$P($G(^EEO(785,D0,1)),U,12) D ^%DTC Q
+2 SET EP1=$PIECE(EN1,";",2)
SET EN1=$PIECE(EN1,";")
SET EP2=$PIECE(EN2,";",2)
SET EN2=$PIECE(EN2,";")
+3 SET ET2=$PIECE($GET(^EEO(785,D0,EN2)),U,EP2)
+4 SET ET1=$PIECE($GET(^EEO(785,D0,EN1)),U,EP1)
+5 SET ETC=$SELECT($PIECE($GET(^EEO(785,D0,4)),U)>0:+$GET(^(4)),$PIECE($GET(^EEO(785,D0,5)),U,12)>0&(EN1'=4):$PIECE(^(5),U,12),1:"")
+6 SET X2=$SELECT(ET2'="":ET2,1:"")
+7 SET (EN4,X1)=$SELECT(ET1'="":ET1,ET2="":X2,ETC'="":ETC,1:DT)
+8 IF X2>ETC&(ETC=X1)
SET X=" "
DO KINP
QUIT
+9 DO ^%DTC
if ETC=""&(EN4=DT)
SET X=X_"*"
KINP KILL EP1,EN1,EN2,EP1,EP2,EG,EH,EN4,ETC,ET1,ET2
+1 QUIT
DEL() ;Security check for deletions to EEO files
+1 IF '($DATA(STANO)!($DATA(EEOYSTN)))
WRITE !!,"NO DELETEIONS EXCEPT THROUGH EEO PACKAGE",!!
GOTO Q
+2 GOTO NAY
NOSEC ;No security message
+1 KILL EEOYSTN,EEOYSPTR
WRITE !!,"NO SECURITY FOR EEO DATA ACCESS FOR THIS STATION",!!
QUIT
NODE ;Assignments of file 785 IENs are made here
+1 IF 'STANO
WRITE !!,"MUST ENTER THROUGH ASSOCIATED PACKAGE",!!
KILL X
QUIT
+2 if $GET(DIC(0))'["L"
QUIT
+3 LOCK +^EEO(785,0):0
SET Z=$ORDER(^EEO(785,"ANODE",STANO*100000))
IF Z=""!(Z>(STANO+1*100000-1))
SET DINUM=STANO+1*100000-1
GOTO NODE1
+4 SET DINUM=Z-1
IF $DATA(EEO("DA"))
IF $DATA(^EEO(785,EEO("DA")))
KILL DINUM
LOCK -^EEO(785,0)
QUIT
NODE1 IF $DATA(^EEO(785,"ANODE",DINUM))
SET DINUM=DINUM-1
GOTO NODE1
+1 LOCK -^EEO(785,0)
QUIT
TEST ;Part of input transform for .01 field of file 785
+1 SET Y(0)=Y
if '$DATA(XQY0)
SET XQY0=""
SET D0=$SELECT($DATA(D0):D0,+Y>0:+Y,$DATA(DS):+DS,1:"")
+2 IF D0'>0
QUIT
+3 if $PIECE($GET(^EEO(785,D0,1)),U,3)=""&($GET(^EEO(785,D0,"SEC"))'=DUZ!(XQY0["REPORT")!(XQY0["ADHOC"))
SET Y=$PIECE($GET(^EEO(785,D0,5)),U,6)
QUIT
