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 Dec 13, 2024@02:26:39 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
