- PSODEARL ;FO-OAKAND/REM - EPCS Logical Access Control Audit Rpt; [5/7/02 5:53am] ;12/2/21 11:00
- ;;7.0;OUTPATIENT PHARMACY;**545**;DEC 1997;Build 270
- ;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
- ;External reference to XUEPCS DATA file (#8991.6) is supported by DBIA 7015
- ;External reference to XUEPCS PSDRPH AUDIT file (#8991.7) is supported by DBIA 7016
- ;External reference to KEYS sub-file (#200.051) is supported by DBIA 7054
- ;
- Q
- GUI ; EPCS Entry point
- N AUDDATA,AUDDATE,AUDIEN,DEA,EPCSDUZ,EPCSSITE,EPCSDIV,AUDSITE,DIV
- S AUDDATA=$NA(^TMP($J,"EPCSAUDITDATA")) K @AUDDATA
- S DIV("ALL")="all divisions"
- ; Get the Audit data and build the ^TMP global
- S AUDDATE=EPCSSD F S AUDDATE=$O(^DIA(100.7,"C",AUDDATE)) Q:AUDDATE=""!(AUDDATE>EPCSED) D
- .S AUDIEN=0 F S AUDIEN=$O(^DIA(100.7,"C",AUDDATE,AUDIEN)) Q:AUDIEN="" D
- ..N AUDNAME,AUDACT,AUDTEXT,AUDFIELD,AUDOUT,AUDCOUNT,ORITM
- ..S AUDFIELD=$P($G(^DIA(100.7,AUDIEN,0)),U,3)
- ..S AUDNAME=$P($G(^DIA(100.7,AUDIEN,3.1)),U)
- ..S:$G(AUDNAME)="" AUDNAME=$P($G(^DIA(100.7,AUDIEN,2.1)),U)
- ..;S:AUDFIELD="1,.01" EPCSDIV=$$HASDIV^ORUTL(AUDNAME,.DIV) Q:EPCSDIV=""
- ..I AUDFIELD="1,.01" D Q:EPCSDIV=""
- ...S EPCSDIV=$$HASDIV^ORUTL(AUDNAME,.DIV)
- ..I $D(^DIA(100.7,AUDIEN,2.1))=1 D
- ...I '$D(^DIA(100.7,AUDIEN,3.1)) S AUDACT="Disabled",AUDNAME(1)=$G(^DIA(100.7,AUDIEN,2))
- ...I $D(^DIA(100.7,AUDIEN,3.1))=1 D
- ....I AUDFIELD=.02 S AUDACT=$S($G(^DIA(100.7,AUDIEN,2))="YES":"Disabled",1:"Enabled")
- ....E S AUDACT="Modified"
- ....S AUDNAME(1)=$G(^DIA(100.7,AUDIEN,3))
- ..I '$D(^DIA(100.7,AUDIEN,2.1)) D
- ...I $D(^DIA(100.7,AUDIEN,3.1))=1 S AUDACT="Enabled",AUDNAME(1)=$G(^DIA(100.7,AUDIEN,3))
- ..I AUDFIELD=.01 S $P(@AUDDATA@("TOP",$P($G(^DIA(100.7,AUDIEN,0)),U)),U,3)=AUDNAME(1) Q
- ..S AUDNAME("USER")=$$GET1^DIQ(200,$P($G(^DIA(100.7,AUDIEN,0)),U,4)_",",.01)
- ..S:AUDNAME("USER")="" AUDNAME("USER")="User #"_$P($G(^DIA(100.7,AUDIEN,0)),U,4)
- ..S AUDTEXT=AUDACT_" on "_$$FMTE^XLFDT(AUDDATE)_" by "_AUDNAME("USER")
- ..I $P($G(^DIA(100.7,AUDIEN,4.1)),U)'="" D
- ...S AUDTEXT=AUDTEXT_" with option "_$$GET1^DIQ(19,$P($G(^DIA(100.7,AUDIEN,4.1)),U)_",",.01)
- ..I AUDFIELD=.02,AUDACT="Modified" D
- ...S AUDTEXT=AUDTEXT_" from "_$G(^DIA(100.7,AUDIEN,2))_" to "_AUDNAME(1)_"."
- ..I AUDFIELD="1,.01" S AUDOUT=$NA(@AUDDATA@(EPCSDIV,AUDNAME,AUDIEN))
- ..E S AUDOUT=$NA(@AUDDATA@("TOP",$P($G(^DIA(100.7,AUDIEN,0)),U),AUDIEN))
- ..S ORITM=1+$P($G(@($P(AUDOUT,","_AUDIEN_")")_")")),U,2)
- ..S AUDTEXT=$$PAD^ORUTL(ORITM,3)_ORITM_": "_AUDTEXT
- ..D WRAP^ORUTL(AUDTEXT,AUDOUT)
- ..S AUDCOUNT=@AUDOUT
- ..S AUDOUT=$P(AUDOUT,","_AUDIEN_")")_")"
- ..S $P(@AUDOUT,U)=AUDCOUNT+$G(@AUDOUT)
- ..S $P(@AUDOUT,U,2)=1+$P($G(@AUDOUT),U,2)
- ..S:AUDFIELD'=.02 $P(@AUDOUT,U,3)=AUDNAME(1)
- ; Loop through the OE/RR EPCS PARAMETERS file (#100.7), but print from the ^TMP global
- D HEADER
- S AUDSITE(1)=$O(^ORD(100.7,0)),AUDSITE=$$GET1^DIQ(100.7,AUDSITE(1)_",",.01)
- S:AUDSITE="" AUDSITE=$P(@AUDDATA@("TOP",AUDSITE(1)),U,3)
- W "SITE: "_AUDSITE
- S AUDIEN=0 F S AUDIEN=$O(@AUDDATA@("TOP",AUDSITE(1),AUDIEN)) Q:AUDIEN="" D
- .N DETLINE
- .S DETLINE=0 F S DETLINE=$O(@AUDDATA@("TOP",AUDSITE(1),AUDIEN,DETLINE)) Q:DETLINE="" D
- ..W !,@AUDDATA@("TOP",AUDSITE(1),AUDIEN,DETLINE)
- S EPCSDIV="" F S EPCSDIV=$O(@AUDDATA@(EPCSDIV)) Q:EPCSDIV="" D
- .Q:EPCSDIV="TOP"
- .W !!,"DIVISION: "_EPCSDIV
- .S EPCSDUZ=0 F S EPCSDUZ=$O(@AUDDATA@(EPCSDIV,EPCSDUZ)) Q:EPCSDUZ="" D
- ..N EPCSIEN,EPCSUSER
- ..S EPCSUSER=$$GET1^DIQ(200,EPCSDUZ_",",.01)
- ..S:EPCSUSER="" EPCSUSER=$P(@AUDDATA@(EPCSDIV,EPCSDUZ),U,3)
- ..W !,"USER: "_EPCSUSER
- ..S EPCSIEN=0 F S EPCSIEN=$O(@AUDDATA@(EPCSDIV,EPCSDUZ,EPCSIEN)) Q:EPCSIEN="" D
- ...N EPCSLINE
- ...S EPCSLINE=0 F S EPCSLINE=$O(@AUDDATA@(EPCSDIV,EPCSDUZ,EPCSIEN,EPCSLINE)) Q:EPCSLINE="" D
- ....W !,@AUDDATA@(EPCSDIV,EPCSDUZ,EPCSIEN,EPCSLINE)
- K @AUDDATA
- S:$D(ZTQUEUED) ZTREQ="@"
- Q
- N NOW
- S NOW=$$UP^XLFSTR($$HTE^XLFDT($H)),NOW=$P(NOW,"@",1)_" "_$P($P(NOW,"@",2),":",1,2)
- W "LOGICAL ACCESS CONTROL AUDIT REPORT",?47,NOW_" PAGE 1",!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODEARL 4083 printed Mar 13, 2025@21:31:31 Page 2
- PSODEARL ;FO-OAKAND/REM - EPCS Logical Access Control Audit Rpt; [5/7/02 5:53am] ;12/2/21 11:00
- +1 ;;7.0;OUTPATIENT PHARMACY;**545**;DEC 1997;Build 270
- +2 ;External reference to DEA NUMBERS file (#8991.9) is supported by DBIA 7002
- +3 ;External reference to XUEPCS DATA file (#8991.6) is supported by DBIA 7015
- +4 ;External reference to XUEPCS PSDRPH AUDIT file (#8991.7) is supported by DBIA 7016
- +5 ;External reference to KEYS sub-file (#200.051) is supported by DBIA 7054
- +6 ;
- +7 QUIT
- GUI ; EPCS Entry point
- +1 NEW AUDDATA,AUDDATE,AUDIEN,DEA,EPCSDUZ,EPCSSITE,EPCSDIV,AUDSITE,DIV
- +2 SET AUDDATA=$NAME(^TMP($JOB,"EPCSAUDITDATA"))
- KILL @AUDDATA
- +3 SET DIV("ALL")="all divisions"
- +4 ; Get the Audit data and build the ^TMP global
- +5 SET AUDDATE=EPCSSD
- FOR
- SET AUDDATE=$ORDER(^DIA(100.7,"C",AUDDATE))
- if AUDDATE=""!(AUDDATE>EPCSED)
- QUIT
- Begin DoDot:1
- +6 SET AUDIEN=0
- FOR
- SET AUDIEN=$ORDER(^DIA(100.7,"C",AUDDATE,AUDIEN))
- if AUDIEN=""
- QUIT
- Begin DoDot:2
- +7 NEW AUDNAME,AUDACT,AUDTEXT,AUDFIELD,AUDOUT,AUDCOUNT,ORITM
- +8 SET AUDFIELD=$PIECE($GET(^DIA(100.7,AUDIEN,0)),U,3)
- +9 SET AUDNAME=$PIECE($GET(^DIA(100.7,AUDIEN,3.1)),U)
- +10 if $GET(AUDNAME)=""
- SET AUDNAME=$PIECE($GET(^DIA(100.7,AUDIEN,2.1)),U)
- +11 ;S:AUDFIELD="1,.01" EPCSDIV=$$HASDIV^ORUTL(AUDNAME,.DIV) Q:EPCSDIV=""
- +12 IF AUDFIELD="1,.01"
- Begin DoDot:3
- +13 SET EPCSDIV=$$HASDIV^ORUTL(AUDNAME,.DIV)
- End DoDot:3
- if EPCSDIV=""
- QUIT
- +14 IF $DATA(^DIA(100.7,AUDIEN,2.1))=1
- Begin DoDot:3
- +15 IF '$DATA(^DIA(100.7,AUDIEN,3.1))
- SET AUDACT="Disabled"
- SET AUDNAME(1)=$GET(^DIA(100.7,AUDIEN,2))
- +16 IF $DATA(^DIA(100.7,AUDIEN,3.1))=1
- Begin DoDot:4
- +17 IF AUDFIELD=.02
- SET AUDACT=$SELECT($GET(^DIA(100.7,AUDIEN,2))="YES":"Disabled",1:"Enabled")
- +18 IF '$TEST
- SET AUDACT="Modified"
- +19 SET AUDNAME(1)=$GET(^DIA(100.7,AUDIEN,3))
- End DoDot:4
- End DoDot:3
- +20 IF '$DATA(^DIA(100.7,AUDIEN,2.1))
- Begin DoDot:3
- +21 IF $DATA(^DIA(100.7,AUDIEN,3.1))=1
- SET AUDACT="Enabled"
- SET AUDNAME(1)=$GET(^DIA(100.7,AUDIEN,3))
- End DoDot:3
- +22 IF AUDFIELD=.01
- SET $PIECE(@AUDDATA@("TOP",$PIECE($GET(^DIA(100.7,AUDIEN,0)),U)),U,3)=AUDNAME(1)
- QUIT
- +23 SET AUDNAME("USER")=$$GET1^DIQ(200,$PIECE($GET(^DIA(100.7,AUDIEN,0)),U,4)_",",.01)
- +24 if AUDNAME("USER")=""
- SET AUDNAME("USER")="User #"_$PIECE($GET(^DIA(100.7,AUDIEN,0)),U,4)
- +25 SET AUDTEXT=AUDACT_" on "_$$FMTE^XLFDT(AUDDATE)_" by "_AUDNAME("USER")
- +26 IF $PIECE($GET(^DIA(100.7,AUDIEN,4.1)),U)'=""
- Begin DoDot:3
- +27 SET AUDTEXT=AUDTEXT_" with option "_$$GET1^DIQ(19,$PIECE($GET(^DIA(100.7,AUDIEN,4.1)),U)_",",.01)
- End DoDot:3
- +28 IF AUDFIELD=.02
- IF AUDACT="Modified"
- Begin DoDot:3
- +29 SET AUDTEXT=AUDTEXT_" from "_$GET(^DIA(100.7,AUDIEN,2))_" to "_AUDNAME(1)_"."
- End DoDot:3
- +30 IF AUDFIELD="1,.01"
- SET AUDOUT=$NAME(@AUDDATA@(EPCSDIV,AUDNAME,AUDIEN))
- +31 IF '$TEST
- SET AUDOUT=$NAME(@AUDDATA@("TOP",$PIECE($GET(^DIA(100.7,AUDIEN,0)),U),AUDIEN))
- +32 SET ORITM=1+$PIECE($GET(@($PIECE(AUDOUT,","_AUDIEN_")")_")")),U,2)
- +33 SET AUDTEXT=$$PAD^ORUTL(ORITM,3)_ORITM_": "_AUDTEXT
- +34 DO WRAP^ORUTL(AUDTEXT,AUDOUT)
- +35 SET AUDCOUNT=@AUDOUT
- +36 SET AUDOUT=$PIECE(AUDOUT,","_AUDIEN_")")_")"
- +37 SET $PIECE(@AUDOUT,U)=AUDCOUNT+$GET(@AUDOUT)
- +38 SET $PIECE(@AUDOUT,U,2)=1+$PIECE($GET(@AUDOUT),U,2)
- +39 if AUDFIELD'=.02
- SET $PIECE(@AUDOUT,U,3)=AUDNAME(1)
- End DoDot:2
- End DoDot:1
- +40 ; Loop through the OE/RR EPCS PARAMETERS file (#100.7), but print from the ^TMP global
- +41 DO HEADER
- +42 SET AUDSITE(1)=$ORDER(^ORD(100.7,0))
- SET AUDSITE=$$GET1^DIQ(100.7,AUDSITE(1)_",",.01)
- +43 if AUDSITE=""
- SET AUDSITE=$PIECE(@AUDDATA@("TOP",AUDSITE(1)),U,3)
- +44 WRITE "SITE: "_AUDSITE
- +45 SET AUDIEN=0
- FOR
- SET AUDIEN=$ORDER(@AUDDATA@("TOP",AUDSITE(1),AUDIEN))
- if AUDIEN=""
- QUIT
- Begin DoDot:1
- +46 NEW DETLINE
- +47 SET DETLINE=0
- FOR
- SET DETLINE=$ORDER(@AUDDATA@("TOP",AUDSITE(1),AUDIEN,DETLINE))
- if DETLINE=""
- QUIT
- Begin DoDot:2
- +48 WRITE !,@AUDDATA@("TOP",AUDSITE(1),AUDIEN,DETLINE)
- End DoDot:2
- End DoDot:1
- +49 SET EPCSDIV=""
- FOR
- SET EPCSDIV=$ORDER(@AUDDATA@(EPCSDIV))
- if EPCSDIV=""
- QUIT
- Begin DoDot:1
- +50 if EPCSDIV="TOP"
- QUIT
- +51 WRITE !!,"DIVISION: "_EPCSDIV
- +52 SET EPCSDUZ=0
- FOR
- SET EPCSDUZ=$ORDER(@AUDDATA@(EPCSDIV,EPCSDUZ))
- if EPCSDUZ=""
- QUIT
- Begin DoDot:2
- +53 NEW EPCSIEN,EPCSUSER
- +54 SET EPCSUSER=$$GET1^DIQ(200,EPCSDUZ_",",.01)
- +55 if EPCSUSER=""
- SET EPCSUSER=$PIECE(@AUDDATA@(EPCSDIV,EPCSDUZ),U,3)
- +56 WRITE !,"USER: "_EPCSUSER
- +57 SET EPCSIEN=0
- FOR
- SET EPCSIEN=$ORDER(@AUDDATA@(EPCSDIV,EPCSDUZ,EPCSIEN))
- if EPCSIEN=""
- QUIT
- Begin DoDot:3
- +58 NEW EPCSLINE
- +59 SET EPCSLINE=0
- FOR
- SET EPCSLINE=$ORDER(@AUDDATA@(EPCSDIV,EPCSDUZ,EPCSIEN,EPCSLINE))
- if EPCSLINE=""
- QUIT
- Begin DoDot:4
- +60 WRITE !,@AUDDATA@(EPCSDIV,EPCSDUZ,EPCSIEN,EPCSLINE)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +61 KILL @AUDDATA
- +62 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +63 QUIT
- +1 NEW NOW
- +2 SET NOW=$$UP^XLFSTR($$HTE^XLFDT($HOROLOG))
- SET NOW=$PIECE(NOW,"@",1)_" "_$PIECE($PIECE(NOW,"@",2),":",1,2)
- +3 WRITE "LOGICAL ACCESS CONTROL AUDIT REPORT",?47,NOW_" PAGE 1",!
- +4 QUIT
