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