ABSPOSRS ; IHS/OIT/CNI/SCR - TM Audit report
;;1.0;PHARMACY POINT OF SALE;**39,40,41**;JUN 21, 2001;Build 38
;
;This is to do a report based on fields being audited.
;They are listed below under FILES tag. To add new fields
;to report just list them under FILES and turn the audit on
;using FM.
;
;K ABM,ABMY
;
SEL ;EP FOR POS PARAMATER AUDIT TRAIL REPORT
N ABSP,ABSPY,ABSPQ
S ABSP("RTYP")=1
S ABSP("RTYP","NM")="AUDIT LISTING"
D LOOP Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
S ABSP("HD",0)="LISTING of Audited fields "
S ABSP("LVL")=0
;S ABSPQ("RC")="COMPUTE^ABSPOSRS",ABMQ("RX")="POUT^ABSPOSRS",ABMQ("NS")="ABSP"
S ABSPQ("RC")="COMPUTE^ABSPOSRS",ABSPQ("RX")="POUT^ABSPOSRS",ABSPQ("NS")="ABSP" ;IHS/OIT/CNI/SCR 083010 patch 40
S ABSPQ("RP")="OUTPUT^ABSPOSRS"
D SET^ABSPOSUQ(.ABSPQ)
Q
;
FILES ;These fields must be 'audited' at the site to show up on this report
;;9002313.56;.01;Name
;;9002313.56;.06;ENVOY TERMINAL ID
;;9002313.56;.02;NCPDP #
;;9002313.56;.03;DEFAULT DEA #
;;9002313.56;3001.01;MEDICAID #
;;9002313.56;3001.02;DEFAULT CAID PROVIDER #
;;9002313.56;115;AUTOPRINT PHARMACY EXPENSE RPT
;;9002313.56;115.01;DEFAULT DEVICE
;;9002313.56;950,.01;INSURER
;;9002313.56;950,.02;INSURER-ASSIGNED #
;;9002313.56;950,.03;MED-CAL SUBSCRIBER ID
;;9002313.56;950,.04;CA FAMILY PACT ID
;;9002313.55;.01;NAME
;;9002313.55;450.01;PHONE NUMBER
;;9002313.55;.03;SWITCH TYPE
;;9002313.55;.02;MODEM TYPE
;;9002313.55;208;BAUD RATE
;;9002313.55;420.02;CONNECTION TYPE
;;9002313.55;420.03;CACHE DEVICE #
;;9002313.55;2021.01;IP ADDRESS
;;9002313.55;2021.02;TCP PORT NUMBER
;;9002313.55;1660.01;ETB
;;9002313.4;.01;NAME
;;9002313.4;100.01;RX - NCPDP Record Format
;;9002313.4;100.14;INSURER NPI FLAG
;;9002313.4;100.07;RX - DIAL OUT TO
;;9002313.4;100.06;RX - PRICING METHOD
;;9002313.4;100.02;RX - Dispensing Fee
;;9002313.4;100.08;GRACE PERIOD
;;9002313.4;100.05;RX - Help Telephone #
;;9002313.4;104.01;RX PRIORITY
;;9002313.4;107.01;WORKERS COMP INSURANCE
;;9002313.4;228.11,.01;BILLABLE NDC #
;;9002313.4;2128.11,.01;UNBILLABLE NDC #
;;9002313.4;2128.13;UNBILLABLE OTC
;;9002313.53;.01;NAME
;;9002313.53;.02;UNIT PRICE SOURCE
;;9002313.53;.04; MULTIPLIER
;;9002313.53;.05;DISPENSING FEE
;;9002313.99;943;USUAL INPUT METHOD
;;9002313.99;440.01;DEFAULT DIAL OUT
;;9002313.99;1501;OUTSIDE LINE
;;9002313.99;170.01;A/R PACKAGE
;;9002313.99;170.02;SEND 3PB REJECT
;;9002313.99;2128.13;OTC DRUGS ARE UNBILLABLE
;;9002313.99;2128.11,.01;NAME
;;9002313.99;1960.01;OK MEDICAID INSURANCE NAME
;;9002313.99;1960.03;OK MEDICAID LIMIT
;;9002313.99;1960.02;OK MEDICAID CYCLE
;;9002313.99;960.01;INS BASE PRVT
;;9002313.99;960.02;INS BASE CARE
;;9002313.99;960.03;INS BASE CAID
;;9002313.99;960.04; INS BASE RR
;;9002313.99;960.05; INS BASE SELF
;;9002313.99;970.01,.01;INS RULE ORDER
;;9002313.99;970.01,.02;INS RULE NAME
;;9002313.99;970.01,.03;INS RULE POINTS PLUS
;;9002313.99;970.01,.04;INS RULE POINTS MINUS
;;9002313.99;6000;GLOBAL NPI FLAG
;;END
LOOP ;
; Display current exclusion parameters
;S ABMY("X")="W $$SDT^ABMDUTL(X)"
S ABSPY("X")="W $$FM2EXT^ABSPOSU1(X)"
;G XIT:$D(DUOUT)!$D(DTOUT)!$D(DIROUT)
I $D(DTOUT)!$D(DIROUT) D XIT Q
W !!?3,"EXCLUSION PARAMETERS Currently in Effect for RESTRICTING the EXPORT to:",!?3,"======================================================================="
;I $D(ABSPY("LOC")) W !?3,"- Pharmacy.....: ",$P(^DIC(4,ABSPY("LOC"),0),"^",1)
;IHS/OIT/CASSEVERN/RAN - 12/30/2010 - Patch 41 Changed to point to PHARMACY FILE...not INSTITUTION file.
I $D(ABSPY("LOC")) W !?3,"- Pharmacy.....: ",$P(^ABSP(9002313.56,ABSPY("LOC"),0),"^",1)
I $D(ABSPY("DT")) W !?3,"- Edit Date Range....:"
I S X=ABSPY("DT",1) X ABSPY("X") W " to: " S X=ABSPY("DT",2) X ABSPY("X")
; Choose additional exclusion parameters
N DIR
S DIR(0)="SO^1:PHARMACY;2:DATE RANGE"
S DIR("A")="Select ONE or MORE of the above EXCLUSION PARAMETERS"
S DIR("?")="The report can be restricted to one or more of the listed parameters. A parameter can be removed by reselecting it and making a null entry."
D ^DIR
;G XIT:$D(DIRUT)!$D(DIROUT)
I $D(DTOUT)!$D(DIROUT) D XIT Q
I Y=1!(Y=2) D @($S(Y=1:"LOC",1:"DT")_"^ABSPOSRS") D LOOP
;
COMPUTE ;
S ABSP("SUBR")="ABSPOSRS"
K ^TMP($J,"ABSPOSRS")
F ABSPCNT=1:1 S ABSPSEL=$P($T(FILES+ABSPCNT),";;",2) Q:ABSPSEL="END" D
.S ABSPFILE=$P(ABSPSEL,";")
.S ABSPFLD=$P(ABSPSEL,";",2)
.S ABSPFNAM=$P(ABSPSEL,";",3)
.I $G(ABSPY("DT",1))'="" S ABSPSDT=($G(ABSPY("DT",1))-1),ABSPEDT=$G(ABSPY("DT",2))+1
.E S ABSPSDT=0,ABSPEDT=9999999
.F S ABSPSDT=$O(^DIA(ABSPFILE,"C",ABSPSDT)) Q:+ABSPSDT=0!(ABSPSDT>ABSPEDT) D
..S ABSPAIEN=0
..F S ABSPAIEN=$O(^DIA(ABSPFILE,"C",ABSPSDT,ABSPAIEN)) Q:+ABSPAIEN=0 D
...Q:$P($G(^DIA(ABSPFILE,ABSPAIEN,0)),U,3)'=ABSPFLD ;quit if not Printable Name of Payment Site
...S ABSPUSER=$P($G(^DIA(ABSPFILE,ABSPAIEN,0)),U,4)
...S ABSPOLD=$P($G(^DIA(ABSPFILE,ABSPAIEN,2)),U)
...S ABSPNEW=$P($G(^DIA(ABSPFILE,ABSPAIEN,3)),U)
...S ^TMP($J,"ABSPOSRS",ABSPFILE,ABSPFLD,ABSPFNAM,ABSPSDT,ABSPUSER)=ABSPOLD_"^"_ABSPNEW
Q
OUTPUT ;
D HDB
N ABSPFNAM,ABSPFILE,ABSPADT,ABSPUSER,ABSPFLD,ABSPOLD,ABSPNEW
S (ABSPADT,ABSPUSER,ABSPFILE,ABSPFLD,ABSPOLD,ABSPNEW)=0
F S ABSPFILE=$O(^TMP($J,"ABSPOSRS",ABSPFILE)) Q:+ABSPFILE=0 D Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
.S ABSPFLD=0,ABSPSFLD=0
.F S ABSPFLD=$O(^TMP($J,"ABSPOSRS",ABSPFILE,ABSPFLD)) Q:+ABSPFLD=0 D Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
..S ABSPSDT=0
..S ABSPFNAM=""
..S ABSPFNAM=$O(^TMP($J,"ABSPOSRS",ABSPFILE,ABSPFLD,ABSPFNAM))
..I ABSPFLD'=ABSPSFLD D
...;W !!?5,$P($G(^DIC(ABSPFILE,0)),U)_" Fld: "_$P($G(^DD(ABSPFILE,+ABSPFLD,0)),U)
...W !!?5,$P($G(^DIC(ABSPFILE,0)),U)_" Fld: "_ABSPFNAM
..S ABSPSFLD=ABSPFLD
..F S ABSPSDT=$O(^TMP($J,"ABSPOSRS",ABSPFILE,ABSPFLD,ABSPFNAM,ABSPSDT)) Q:+ABSPSDT=0 D Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
...S ABSPUSER=0
...F S ABSPUSER=$O(^TMP($J,"ABSPOSRS",ABSPFILE,ABSPFLD,ABSPFNAM,ABSPSDT,ABSPUSER)) Q:+ABSPUSER=0 D Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
....I $Y>(IOSL-5) D HD Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT) W " (cont)"
....W !,$$FM2EXT^ABSPOSU1(ABSPSDT) ;date/time external format
....W ?22,$E($P($G(^VA(200,ABSPUSER,0)),U),1,17) ;user
....W ?42,$E($P($G(^TMP($J,"ABSPOSRS",ABSPFILE,ABSPFLD,ABSPFNAM,ABSPSDT,ABSPUSER)),U),1,20) ;old value
....W ?64,$E($P($G(^TMP($J,"ABSPOSRS",ABSPFILE,ABSPFLD,ABSPFNAM,ABSPSDT,ABSPUSER)),U,2),1,20) ;new value
K ^TMP($J,"ABSPOSRS")
Q
LOC ;EP
W !
N DIC
S DIC="^ABSP(9002313.56,"
S DIC(0)="AEMQ"
S DIC("A")="Select PHARMACY: "
D ^DIC K DIC
Q:+Y<1
S ABSPY("LOC")=+Y
Q
DT ;EP
K DIR,ABSPY("DT")
Q:$D(DIRUT)
S ABSPY("DT")="E"
S Y="EDIT DATE"
W !!," ============ Entry of ",Y," Range =============",!
S DIR("A")="Enter STARTING "_Y_" for the Report"
S DIR(0)="DO^::EP"
D ^DIR
G DT:$D(DIRUT)
S ABSPY("DT",1)=Y
W !
S DIR("A")="Enter ENDING DATE for the Report"
D ^DIR
K DIR
G DT:$D(DIRUT)
S ABSPY("DT",2)=Y
I ABSPY("DT",1)>ABSPY("DT",2) W !!,*7,"INPUT ERROR: Start Date is Greater than than the End Date, TRY AGAIN!",!! G DT
Q
XIT ;
K ABSPY("I"),ABSPY("X"),DIR
Q
HDR ;
I $D(ABSPY("LOC")) S ABSP("TXT")=$P(^DIC(4,ABSPY("LOC"),0),U),ABSPM("CONJ")="at " D CHK
Q:$G(ABSPY("DT",1))="" ;no dates
S ABSP("CONJ")="with "
S ABSP("TXT")="Edit Date" D CHK
S ABSP("CONJ")="from ",ABSP("TXT")=$$FM2EXT^ABSPOSU1(ABSPY("DT",1)) D CHK
S ABSP("CONJ")="to ",ABSP("TXT")=$$FM2EXT^ABSPOSU1(ABSPY("DT",2)) D CHK
Q
WHD ;EP for writing Report Header
W $$EN^ABMVDF("IOF"),!
N ABSPLINE
S $P(ABSPLINE,"=",$S($D(ABSP(132)):132,1:80))="" W ABSPLINE,!
W ABSP("HD",0),?$S($D(ABSP(132)):108,1:57) S Y=DT X ^DD("DD") W Y," Page ",ABSP("PG")
W:$G(ABSP("HD",1))]"" !,ABSP("HD",1)
W:$G(ABSP("HD",2))]"" !,ABSP("HD",2)
W !,ABSPLINE
Q
CHK I ($L(ABSP("HD",ABSP("LVL")))+1+$L(ABSP("CONJ"))+$L(ABSP("TXT")))<($S($D(ABSP(132)):104,1:52)+$S(ABM("LVL")>0:28,1:0)) S ABM("HD",ABM("LVL"))=ABM("HD",ABM("LVL"))_" "_ABM("CONJ")_ABM("TXT")
E S ABSP("LVL")=ABSP("LVL")+1,ABSP("HD",ABM("LVL"))=ABSP("CONJ")_ABSP("TXT")
Q
HD ;
I '$D(IO("Q")),$E(IOST)="C",'$D(IO("S")) D
.F W ! Q:$Y+3>IOSL!($D(DTOUT)!($D(DUOUT)!$D(DIROUT)))
.N DIR S DIR(0)="E" D ^DIR
HDB S ABSP("PG")=+$G(ABSP("PG"))+1 D WHD
N ABSPLINE
W !,"Date/Time",?17,"User",?35,"Old Value",?58,"New Value"
S $P(ABSPLINE,"-",80)="" W !,ABSPLINE
Q
POUT ;EP for exiting report
K ^TMP($J,"ABSPOSRS")
D KILL^%ZTLOAD
K ABSPY,ABSPP,ABSP,IO("Q"),POP,DIR,DUOUT,DTOUT,ZTSK,DIROUT,DIRUT,%ZIS
Q
ABSPOSRS ; IHS/OIT/CNI/SCR - TM Audit report
+1 ;;1.0;PHARMACY POINT OF SALE;**39,40,41**;JUN 21, 2001;Build 38
+2 ;
+3 ;This is to do a report based on fields being audited.
+4 ;They are listed below under FILES tag. To add new fields
+5 ;to report just list them under FILES and turn the audit on
+6 ;using FM.
+7 ;
+8 ;K ABM,ABMY
+9 ;
SEL ;EP FOR POS PARAMATER AUDIT TRAIL REPORT
+1 NEW ABSP,ABSPY,ABSPQ
+2 SET ABSP("RTYP")=1
+3 SET ABSP("RTYP","NM")="AUDIT LISTING"
+4 DO LOOP
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT
+5 SET ABSP("HD",0)="LISTING of Audited fields "
+6 SET ABSP("LVL")=0
+7 ;S ABSPQ("RC")="COMPUTE^ABSPOSRS",ABMQ("RX")="POUT^ABSPOSRS",ABMQ("NS")="ABSP"
+8 ;IHS/OIT/CNI/SCR 083010 patch 40
SET ABSPQ("RC")="COMPUTE^ABSPOSRS"
SET ABSPQ("RX")="POUT^ABSPOSRS"
SET ABSPQ("NS")="ABSP"
+9 SET ABSPQ("RP")="OUTPUT^ABSPOSRS"
+10 DO SET^ABSPOSUQ(.ABSPQ)
+11 QUIT
+12 ;
FILES ;These fields must be 'audited' at the site to show up on this report
+1 ;;9002313.56;.01;Name
+2 ;;9002313.56;.06;ENVOY TERMINAL ID
+3 ;;9002313.56;.02;NCPDP #
+4 ;;9002313.56;.03;DEFAULT DEA #
+5 ;;9002313.56;3001.01;MEDICAID #
+6 ;;9002313.56;3001.02;DEFAULT CAID PROVIDER #
+7 ;;9002313.56;115;AUTOPRINT PHARMACY EXPENSE RPT
+8 ;;9002313.56;115.01;DEFAULT DEVICE
+9 ;;9002313.56;950,.01;INSURER
+10 ;;9002313.56;950,.02;INSURER-ASSIGNED #
+11 ;;9002313.56;950,.03;MED-CAL SUBSCRIBER ID
+12 ;;9002313.56;950,.04;CA FAMILY PACT ID
+13 ;;9002313.55;.01;NAME
+14 ;;9002313.55;450.01;PHONE NUMBER
+15 ;;9002313.55;.03;SWITCH TYPE
+16 ;;9002313.55;.02;MODEM TYPE
+17 ;;9002313.55;208;BAUD RATE
+18 ;;9002313.55;420.02;CONNECTION TYPE
+19 ;;9002313.55;420.03;CACHE DEVICE #
+20 ;;9002313.55;2021.01;IP ADDRESS
+21 ;;9002313.55;2021.02;TCP PORT NUMBER
+22 ;;9002313.55;1660.01;ETB
+23 ;;9002313.4;.01;NAME
+24 ;;9002313.4;100.01;RX - NCPDP Record Format
+25 ;;9002313.4;100.14;INSURER NPI FLAG
+26 ;;9002313.4;100.07;RX - DIAL OUT TO
+27 ;;9002313.4;100.06;RX - PRICING METHOD
+28 ;;9002313.4;100.02;RX - Dispensing Fee
+29 ;;9002313.4;100.08;GRACE PERIOD
+30 ;;9002313.4;100.05;RX - Help Telephone #
+31 ;;9002313.4;104.01;RX PRIORITY
+32 ;;9002313.4;107.01;WORKERS COMP INSURANCE
+33 ;;9002313.4;228.11,.01;BILLABLE NDC #
+34 ;;9002313.4;2128.11,.01;UNBILLABLE NDC #
+35 ;;9002313.4;2128.13;UNBILLABLE OTC
+36 ;;9002313.53;.01;NAME
+37 ;;9002313.53;.02;UNIT PRICE SOURCE
+38 ;;9002313.53;.04; MULTIPLIER
+39 ;;9002313.53;.05;DISPENSING FEE
+40 ;;9002313.99;943;USUAL INPUT METHOD
+41 ;;9002313.99;440.01;DEFAULT DIAL OUT
+42 ;;9002313.99;1501;OUTSIDE LINE
+43 ;;9002313.99;170.01;A/R PACKAGE
+44 ;;9002313.99;170.02;SEND 3PB REJECT
+45 ;;9002313.99;2128.13;OTC DRUGS ARE UNBILLABLE
+46 ;;9002313.99;2128.11,.01;NAME
+47 ;;9002313.99;1960.01;OK MEDICAID INSURANCE NAME
+48 ;;9002313.99;1960.03;OK MEDICAID LIMIT
+49 ;;9002313.99;1960.02;OK MEDICAID CYCLE
+50 ;;9002313.99;960.01;INS BASE PRVT
+51 ;;9002313.99;960.02;INS BASE CARE
+52 ;;9002313.99;960.03;INS BASE CAID
+53 ;;9002313.99;960.04; INS BASE RR
+54 ;;9002313.99;960.05; INS BASE SELF
+55 ;;9002313.99;970.01,.01;INS RULE ORDER
+56 ;;9002313.99;970.01,.02;INS RULE NAME
+57 ;;9002313.99;970.01,.03;INS RULE POINTS PLUS
+58 ;;9002313.99;970.01,.04;INS RULE POINTS MINUS
+59 ;;9002313.99;6000;GLOBAL NPI FLAG
+60 ;;END
LOOP ;
+1 ; Display current exclusion parameters
+2 ;S ABMY("X")="W $$SDT^ABMDUTL(X)"
+3 SET ABSPY("X")="W $$FM2EXT^ABSPOSU1(X)"
+4 ;G XIT:$D(DUOUT)!$D(DTOUT)!$D(DIROUT)
+5 IF $DATA(DTOUT)!$DATA(DIROUT)
DO XIT
QUIT
+6 WRITE !!?3,"EXCLUSION PARAMETERS Currently in Effect for RESTRICTING the EXPORT to:",!?3,"======================================================================="
+7 ;I $D(ABSPY("LOC")) W !?3,"- Pharmacy.....: ",$P(^DIC(4,ABSPY("LOC"),0),"^",1)
+8 ;IHS/OIT/CASSEVERN/RAN - 12/30/2010 - Patch 41 Changed to point to PHARMACY FILE...not INSTITUTION file.
+9 IF $DATA(ABSPY("LOC"))
WRITE !?3,"- Pharmacy.....: ",$PIECE(^ABSP(9002313.56,ABSPY("LOC"),0),"^",1)
+10 IF $DATA(ABSPY("DT"))
WRITE !?3,"- Edit Date Range....:"
+11 IF $TEST
SET X=ABSPY("DT",1)
XECUTE ABSPY("X")
WRITE " to: "
SET X=ABSPY("DT",2)
XECUTE ABSPY("X")
+12 ; Choose additional exclusion parameters
+13 NEW DIR
+14 SET DIR(0)="SO^1:PHARMACY;2:DATE RANGE"
+15 SET DIR("A")="Select ONE or MORE of the above EXCLUSION PARAMETERS"
+16 SET DIR("?")="The report can be restricted to one or more of the listed parameters. A parameter can be removed by reselecting it and making a null entry."
+17 DO ^DIR
+18 ;G XIT:$D(DIRUT)!$D(DIROUT)
+19 IF $DATA(DTOUT)!$DATA(DIROUT)
DO XIT
QUIT
+20 IF Y=1!(Y=2)
DO @($SELECT(Y=1:"LOC",1:"DT")_"^ABSPOSRS")
DO LOOP
+21 ;
COMPUTE ;
+1 SET ABSP("SUBR")="ABSPOSRS"
+2 KILL ^TMP($JOB,"ABSPOSRS")
+3 FOR ABSPCNT=1:1
SET ABSPSEL=$PIECE($TEXT(FILES+ABSPCNT),";;",2)
IF ABSPSEL="END"
QUIT
Begin DoDot:1
+4 SET ABSPFILE=$PIECE(ABSPSEL,";")
+5 SET ABSPFLD=$PIECE(ABSPSEL,";",2)
+6 SET ABSPFNAM=$PIECE(ABSPSEL,";",3)
+7 IF $GET(ABSPY("DT",1))'=""
SET ABSPSDT=($GET(ABSPY("DT",1))-1)
SET ABSPEDT=$GET(ABSPY("DT",2))+1
+8 IF '$TEST
SET ABSPSDT=0
SET ABSPEDT=9999999
+9 FOR
SET ABSPSDT=$ORDER(^DIA(ABSPFILE,"C",ABSPSDT))
IF +ABSPSDT=0!(ABSPSDT>ABSPEDT)
QUIT
Begin DoDot:2
+10 SET ABSPAIEN=0
+11 FOR
SET ABSPAIEN=$ORDER(^DIA(ABSPFILE,"C",ABSPSDT,ABSPAIEN))
IF +ABSPAIEN=0
QUIT
Begin DoDot:3
+12 ;quit if not Printable Name of Payment Site
IF $PIECE($GET(^DIA(ABSPFILE,ABSPAIEN,0)),U,3)'=ABSPFLD
QUIT
+13 SET ABSPUSER=$PIECE($GET(^DIA(ABSPFILE,ABSPAIEN,0)),U,4)
+14 SET ABSPOLD=$PIECE($GET(^DIA(ABSPFILE,ABSPAIEN,2)),U)
+15 SET ABSPNEW=$PIECE($GET(^DIA(ABSPFILE,ABSPAIEN,3)),U)
+16 SET ^TMP($JOB,"ABSPOSRS",ABSPFILE,ABSPFLD,ABSPFNAM,ABSPSDT,ABSPUSER)=ABSPOLD_"^"_ABSPNEW
End DoDot:3
End DoDot:2
End DoDot:1
+17 QUIT
OUTPUT ;
+1 DO HDB
+2 NEW ABSPFNAM,ABSPFILE,ABSPADT,ABSPUSER,ABSPFLD,ABSPOLD,ABSPNEW
+3 SET (ABSPADT,ABSPUSER,ABSPFILE,ABSPFLD,ABSPOLD,ABSPNEW)=0
+4 FOR
SET ABSPFILE=$ORDER(^TMP($JOB,"ABSPOSRS",ABSPFILE))
IF +ABSPFILE=0
QUIT
Begin DoDot:1
+5 SET ABSPFLD=0
SET ABSPSFLD=0
+6 FOR
SET ABSPFLD=$ORDER(^TMP($JOB,"ABSPOSRS",ABSPFILE,ABSPFLD))
IF +ABSPFLD=0
QUIT
Begin DoDot:2
+7 SET ABSPSDT=0
+8 SET ABSPFNAM=""
+9 SET ABSPFNAM=$ORDER(^TMP($JOB,"ABSPOSRS",ABSPFILE,ABSPFLD,ABSPFNAM))
+10 IF ABSPFLD'=ABSPSFLD
Begin DoDot:3
+11 ;W !!?5,$P($G(^DIC(ABSPFILE,0)),U)_" Fld: "_$P($G(^DD(ABSPFILE,+ABSPFLD,0)),U)
+12 WRITE !!?5,$PIECE($GET(^DIC(ABSPFILE,0)),U)_" Fld: "_ABSPFNAM
End DoDot:3
+13 SET ABSPSFLD=ABSPFLD
+14 FOR
SET ABSPSDT=$ORDER(^TMP($JOB,"ABSPOSRS",ABSPFILE,ABSPFLD,ABSPFNAM,ABSPSDT))
IF +ABSPSDT=0
QUIT
Begin DoDot:3
+15 SET ABSPUSER=0
+16 FOR
SET ABSPUSER=$ORDER(^TMP($JOB,"ABSPOSRS",ABSPFILE,ABSPFLD,ABSPFNAM,ABSPSDT,ABSPUSER))
IF +ABSPUSER=0
QUIT
Begin DoDot:4
+17 IF $Y>(IOSL-5)
DO HD
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT
WRITE " (cont)"
+18 ;date/time external format
WRITE !,$$FM2EXT^ABSPOSU1(ABSPSDT)
+19 ;user
WRITE ?22,$EXTRACT($PIECE($GET(^VA(200,ABSPUSER,0)),U),1,17)
+20 ;old value
WRITE ?42,$EXTRACT($PIECE($GET(^TMP($JOB,"ABSPOSRS",ABSPFILE,ABSPFLD,ABSPFNAM,ABSPSDT,ABSPUSER)),U),1,20)
+21 ;new value
WRITE ?64,$EXTRACT($PIECE($GET(^TMP($JOB,"ABSPOSRS",ABSPFILE,ABSPFLD,ABSPFNAM,ABSPSDT,ABSPUSER)),U,2),1,20)
End DoDot:4
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT
End DoDot:3
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT
End DoDot:2
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT
End DoDot:1
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT
+22 KILL ^TMP($JOB,"ABSPOSRS")
+23 QUIT
LOC ;EP
+1 WRITE !
+2 NEW DIC
+3 SET DIC="^ABSP(9002313.56,"
+4 SET DIC(0)="AEMQ"
+5 SET DIC("A")="Select PHARMACY: "
+6 DO ^DIC
KILL DIC
+7 IF +Y<1
QUIT
+8 SET ABSPY("LOC")=+Y
+9 QUIT
DT ;EP
+1 KILL DIR,ABSPY("DT")
+2 IF $DATA(DIRUT)
QUIT
+3 SET ABSPY("DT")="E"
+4 SET Y="EDIT DATE"
+5 WRITE !!," ============ Entry of ",Y," Range =============",!
+6 SET DIR("A")="Enter STARTING "_Y_" for the Report"
+7 SET DIR(0)="DO^::EP"
+8 DO ^DIR
+9 IF $DATA(DIRUT)
GOTO DT
+10 SET ABSPY("DT",1)=Y
+11 WRITE !
+12 SET DIR("A")="Enter ENDING DATE for the Report"
+13 DO ^DIR
+14 KILL DIR
+15 IF $DATA(DIRUT)
GOTO DT
+16 SET ABSPY("DT",2)=Y
+17 IF ABSPY("DT",1)>ABSPY("DT",2)
WRITE !!,*7,"INPUT ERROR: Start Date is Greater than than the End Date, TRY AGAIN!",!!
GOTO DT
+18 QUIT
XIT ;
+1 KILL ABSPY("I"),ABSPY("X"),DIR
+2 QUIT
HDR ;
+1 IF $DATA(ABSPY("LOC"))
SET ABSP("TXT")=$PIECE(^DIC(4,ABSPY("LOC"),0),U)
SET ABSPM("CONJ")="at "
DO CHK
+2 ;no dates
IF $GET(ABSPY("DT",1))=""
QUIT
+3 SET ABSP("CONJ")="with "
+4 SET ABSP("TXT")="Edit Date"
DO CHK
+5 SET ABSP("CONJ")="from "
SET ABSP("TXT")=$$FM2EXT^ABSPOSU1(ABSPY("DT",1))
DO CHK
+6 SET ABSP("CONJ")="to "
SET ABSP("TXT")=$$FM2EXT^ABSPOSU1(ABSPY("DT",2))
DO CHK
+7 QUIT
WHD ;EP for writing Report Header
+1 WRITE $$EN^ABMVDF("IOF"),!
+2 NEW ABSPLINE
+3 SET $PIECE(ABSPLINE,"=",$SELECT($DATA(ABSP(132)):132,1:80))=""
WRITE ABSPLINE,!
+4 WRITE ABSP("HD",0),?$SELECT($DATA(ABSP(132)):108,1:57)
SET Y=DT
XECUTE ^DD("DD")
WRITE Y," Page ",ABSP("PG")
+5 IF $GET(ABSP("HD",1))]""
WRITE !,ABSP("HD",1)
+6 IF $GET(ABSP("HD",2))]""
WRITE !,ABSP("HD",2)
+7 WRITE !,ABSPLINE
+8 QUIT
CHK IF ($LENGTH(ABSP("HD",ABSP("LVL")))+1+$LENGTH(ABSP("CONJ"))+$LENGTH(ABSP("TXT")))<($SELECT($DATA(ABSP(132)):104,1:52)+$SELECT(ABM("LVL")>0:28,1:0))
SET ABM("HD",ABM("LVL"))=ABM("HD",ABM("LVL"))_" "_ABM("CONJ")_ABM("TXT")
+1 IF '$TEST
SET ABSP("LVL")=ABSP("LVL")+1
SET ABSP("HD",ABM("LVL"))=ABSP("CONJ")_ABSP("TXT")
+2 QUIT
HD ;
+1 IF '$DATA(IO("Q"))
IF $EXTRACT(IOST)="C"
IF '$DATA(IO("S"))
Begin DoDot:1
+2 FOR
WRITE !
IF $Y+3>IOSL!($DATA(DTOUT)!($DATA(DUOUT)!$DATA(DIROUT)))
QUIT
+3 NEW DIR
SET DIR(0)="E"
DO ^DIR
End DoDot:1
HDB SET ABSP("PG")=+$GET(ABSP("PG"))+1
DO WHD
+1 NEW ABSPLINE
+2 WRITE !,"Date/Time",?17,"User",?35,"Old Value",?58,"New Value"
+3 SET $PIECE(ABSPLINE,"-",80)=""
WRITE !,ABSPLINE
+4 QUIT
POUT ;EP for exiting report
+1 KILL ^TMP($JOB,"ABSPOSRS")
+2 DO KILL^%ZTLOAD
+3 KILL ABSPY,ABSPP,ABSP,IO("Q"),POP,DIR,DUOUT,DTOUT,ZTSK,DIROUT,DIRUT,%ZIS
+4 QUIT
