ORDOTP ; SLC/MAE - Opioid Treatment Components ; Dec 16, 2024@13:29:17
;;3.0;ORDER ENTRY/RESULTS REPORTING;**618**;;Build 14
;
; Reference to ^DPT in ICR# 10035
; Reference to %DTC in ICR# 10000
; Reference to %ZIS in ICR# 10086
; Reference to %ZISC in ICR# 10089
; Reference to %ZISH in ICR# 2320
; Reference to ^DIC in ICR# 10006
; Reference to D^DIQ in ICR# 10004
; Reference to ^DIR in ICR# 10026
; Reference to ^XLFDT in ICR# 10103
; Reference to ^XLFSTR in ICR# 10104
;
EN(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;OTP REPORT
N DSPAMT,DSPAMTCHG,DSPBY,DSPDATE,DSPDOW,DSPDIFF,DSPDTTM,DSPEND,DSPFMDATE,DSPFMDAY,DSPHOW,DSPIEN
N DSPINI,DSPINT,DSPINTDT,DSPLINE,DSPREC,DSPROWS,DSPTIME,DSPMED,DSPWEEK,DSPWKCOL,DSPWKCTR
N FRSTDSPDT,HDR,LASTDSPDT,LEGEND,M,MEDDATE,NODSPCTR,NUMWEEKS,PTIEN,PTNAME,X
I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=$$NOW^XLFDT
Q:'$G(ALPHA) Q:'$G(OMEGA)
;
I $G(OTPVFLG)="" D
.N IOM,IOSL,IOST,IOF
.D HFSOPEN("RPC") I POP S ^TMP("OR OTP",$J,1)="ERROR: UNABLE TO ACCESS HFS DIRECTORY "_$$DEFDIR^%ZISH(),^TMP("OR OTP",$J,2)="PLEASE CHECK DIRECTORY WRITE PRIVILEGES." Q
.U IO
.D GETDATA
.D PRTDATA
.D HFSCLOSE("RPC")
.S ROOT=$NA(^TMP("OR OTP",$J))
I $G(OTPVFLG)=1 D
.U IO
.D GETDATA
.D PRTDATA
.D ^%ZISC
.K OTPSTOP
.K ^TMP("OR OTP",$J)
;
Q
;
GETDATA ;Retrieve OTP Dispense data
K ^TMP("OR OTP",$J,"WEEKS"),^TMP("OR OTP",$J,"OTPREC")
I '$D(^ORD(101.22,"B",DFN)) D HDR W !," **** NO PATIENT DATA FOUND ***" Q
S PTIEN=$O(^ORD(101.22,"B",DFN,""))
S PTNAME=$P(^DPT(DFN,0),U)
S FRSTDSPDT=$O(^ORD(101.22,PTIEN,1,"B",""))
S LASTDSPDT=$O(^ORD(101.22,PTIEN,1,"B",""),-1)
D WEEKS
Q:'$D(^TMP("OR OTP",$J,"WEEKS"))
S MEDDATE="" F S MEDDATE=$O(^ORD(101.22,PTIEN,1,"B",MEDDATE)) Q:MEDDATE="" D
.Q:MEDDATE<ALPHA
.Q:MEDDATE>OMEGA
.S DSPIEN="" F S DSPIEN=$O(^ORD(101.22,PTIEN,1,"B",MEDDATE,DSPIEN)) Q:DSPIEN="" D
..S DSPREC=^ORD(101.22,PTIEN,1,DSPIEN,0)
..S DSPBY=$P(DSPREC,U,4)
..S DSPINI=$P(DSPREC,U,5)
..S DSPHOW=$S($P(DSPREC,U,6)="C":"In Clinic",$P(DSPREC,U,6)="H":"Take Home")
..S DSPMED=$P(DSPREC,U,2) I DSPMED[" " S DSPMED=$E($P(DSPMED," ",1),1,4)_" "_$E($P(DSPMED," ",2),1,3)_" "
..S DSPAMT=$P(DSPREC,U,7) I $G(DSPAMTCHG)="" S DSPAMTCHG=DSPAMT
..I DSPAMTCHG'=DSPAMT S DSPAMTCHG=DSPAMT,DSPAMT=DSPAMT_" **"
..S DSPDATE=$P($P(DSPREC,U,3),".",1)
..S DSPTIME=$P($P(DSPREC,U,3),".",2)_"0000",DSPTIME=$E(DSPTIME,1,2)_":"_$E(DSPTIME,3,4)
..S DSPINTDT=$P(DSPREC,U,8)
..S DSPINT=$P(DSPREC,U,9)
..S DSPWKCOL=$P(^TMP("OR OTP",$J,"WEEKS","DATE",MEDDATE),U)
..I DSPHOW="In Clinic" D
...S ^TMP("OR OTP",$J,"OTPREC",MEDDATE,DSPWKCOL)=$G(^TMP("OR OTP",$J,"OTPREC",MEDDATE,DSPWKCOL))_U_DSPHOW_U_DSPTIME_" "_DSPINI_" "_U_DSPMED_U_DSPAMT_$$REPEAT^XLFSTR(" ",9-$L(DSPAMT))
..I DSPHOW="Take Home" D
...S ^TMP("OR OTP",$J,"OTPREC",MEDDATE,DSPWKCOL)=$G(^TMP("OR OTP",$J,"OTPREC",MEDDATE,DSPWKCOL))_U_DSPHOW_U_" "_U_" "_U_" "
..I $G(DSPBY)'="" I '$D(LEGEND(DSPBY)) S LEGEND(DSPBY)=DSPINI
;
Q
;
PRTDATA ;Print OTP Dispense data
I '$D(^ORD(101.22,"B",DFN)) Q
D HDR
I '$D(^TMP("OR OTP",$J,"WEEKS")) W !," **** NO OTP MEDICATION DISPENSE DATA FOUND ***",! Q
S DSPWEEK="" F S DSPWEEK=$O(^TMP("OR OTP",$J,"WEEKS","COL",DSPWEEK)) Q:DSPWEEK="" D
.S NODSPCTR=0,DSPWKCTR=0
.W !,$TR($J("-",26)," ","-")_" MEDICATION TO BE TAKEN ON: "_$TR($J("-",25)," ","-")
.W !,"| | | | | | | |"
.W !,"|" F X=1:1:7 W $S('$D(^TMP("OR OTP",$J,"WEEKS","COL",DSPWEEK,X)):" ",1:$P(^TMP("OR OTP",$J,"WEEKS","COL",DSPWEEK,X),U,2))_$S(X=7:" |",1:"|")
.W !,"| | | | | | | |"
.W !,$TR($J("",79)," ","-"),!
.S DSPWKCTR=$O(^TMP("OR OTP",$J,"WEEKS","COL",DSPWEEK,""),-1) F X=1:1:DSPWKCTR S DSPFMDAY=$P($G(^TMP("OR OTP",$J,"WEEKS","COL",DSPWEEK,X)),U,1) Q:DSPFMDAY="" D
..I '$D(^TMP("OR OTP",$J,"OTPREC",DSPFMDAY,X)) S NODSPCTR=$G(NODSPCTR)+1
.I NODSPCTR=DSPWKCTR W !," **** NO OTP MEDICATION DISPENSE DATA FOUND ***",! Q
.S DSPROWS=""
.F X=1:1:DSPWKCTR D ;GET NUMBER OF ROWS
..S DSPFMDAY=$P(^TMP("OR OTP",$J,"WEEKS","COL",DSPWEEK,X),"^",1)
..Q:'$D(^TMP("OR OTP",$J,"OTPREC",DSPFMDAY,X))
..S DSPROWS=$S($L(^TMP("OR OTP",$J,"OTPREC",DSPFMDAY,X),"^")-1>DSPROWS:$L(^TMP("OR OTP",$J,"OTPREC",DSPFMDAY,X),"^")-1,1:DSPROWS)
.F M=1:1:DSPROWS D
..S DSPLINE=""
..F X=1:1:7 Q:'$D(^TMP("OR OTP",$J,"WEEKS","COL",DSPWEEK)) D
...S DSPFMDAY=$P($G(^TMP("OR OTP",$J,"WEEKS","COL",DSPWEEK,X)),U,1)
...S DSPFMDATE=$P($G(^TMP("OR OTP",$J,"WEEKS","COL",DSPWEEK,X)),U,2)
...I DSPFMDAY="" S DSPLINE=DSPLINE_"| "_$S(X=7:" |",1:"") Q
...S DSPLINE=DSPLINE_$S($P($G(^TMP("OR OTP",$J,"OTPREC",DSPFMDAY,X)),U,M+1)="":"| ",1:"|"_$P(^TMP("OR OTP",$J,"OTPREC",DSPFMDAY,X),U,M+1)_" ")_$S(X=7:" |",1:"")
..W DSPLINE,!
..I M#4=0,(M'=DSPROWS) W "| | | | | | | |",!
.W $TR($J("",79)," ","-"),!
;
D LEGEND
;
Q
;
HDR ;OTP Report Header
W "OTP MEDICATION DISPENSE REPORT for "_$$FMTE^XLFDT(ALPHA)_" to "_$$FMTE^XLFDT(OMEGA)
D NOW^%DTC S Y=+$E(%,1,12) D D^DIQ
W !,?80-$L("Run Date: "_Y),"Run Date: "_Y
S HDR("PAGE")=$G(HDR("PAGE"))+1
W !,?80-$L("Page: "_HDR("PAGE")),"Page: "_HDR("PAGE")
W !,$TR($J("",80)," ","="),!
Q
;
WEEKS ;Build Weeks Header
S DSPDIFF=$$FMDIFF^XLFDT(OMEGA,ALPHA,1)
S DSPEND=$$FMADD^XLFDT(ALPHA,DSPDIFF)
S MEDDATE=$S(ALPHA<FRSTDSPDT:FRSTDSPDT,1:ALPHA)
F D Q:X>DSPEND
.S X=MEDDATE D H^%DTC S DSPWEEK=%H
.F DSPDOW=1:1:7 D
..S %H=DSPWEEK+DSPDOW-1 D YMD^%DTC
..Q:X>OMEGA!(X>LASTDSPDT)
..S ^TMP("OR OTP",$J,"WEEKS","COL",DSPWEEK,DSPDOW)=X_U_$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3))
..S ^TMP("OR OTP",$J,"WEEKS","DATE",X)=DSPDOW_U_DSPWEEK
.S %H=DSPWEEK+7 D YMD^%DTC S MEDDATE=X
.S NUMWEEKS=$G(NUMWEEKS)+1
Q
;
LEGEND ;Legend
W !!," ** LEGEND **"
W !,$TR($J("",80)," ","=")
W !!,"Initial - Name Legend"
S DSPBY="" F S DSPBY=$O(LEGEND(DSPBY)) Q:DSPBY="" W !,LEGEND(DSPBY)_" - "_DSPBY
W !!,"BLANK SPACE - shows that no dispense information was received via the interface."
W !,"This can indicate the patient was a no-show for their appointment, no medication"
W !,"was prescribed/dispensed, or that the interface failed to send the data."
w !!,"** - Asterisks indicate that Dispense Amount may have changed within the week."
W !,$TR($J("",80)," ","=")
Q
;
HFSOPEN(HANDLE) ;open HFS
N OTPDIR,OTPFILE
S OTPDIR=$$DEFDIR^%ZISH()
S OTPFILE="ORDOTP"_DUZ_".DAT"
D OPEN^%ZISH(HANDLE,OTPDIR,OTPFILE,"W") Q:POP
S IOM=132,IOSL=99999,IOST="P-DUMMY",IOF=""""""
Q
;
HFSCLOSE(HANDLE) ;close HFS
N OTPDIR,OTPFILE,OTPDEL
D CLOSE^%ZISH(HANDLE)
K ^TMP("OR OTP",$J,1)
S OTPDIR=$$DEFDIR^%ZISH()
S OTPFILE="ORDOTP"_DUZ_".DAT",OTPDEL(OTPFILE)=""
S X=$$FTG^%ZISH(OTPDIR,OTPFILE,$NA(^TMP("OR OTP",$J,1)),3)
S X=$$DEL^%ZISH(OTPDIR,$NA(OTPDEL))
Q
;
ASK ;VistA hook for OTP Dispense Report
N PTIEN,VOTPBDT,VOTPEDT,ID,OTPVFLG
S (PTIEN,X)="",DIC(0)="AEQMZ"
S DIC("A")="Select PATIENT: "
S DIC="^DPT(" D ^DIC K DIC I $E(X)="^" Q
I Y="-1" G ASK
I Y>0 S PTIEN=+Y
;
ASKDT ;
S VOTPBDT=+$$READ("DA^::E","Enter START Date: ","T-7","Enter a start date for the report")
Q:'VOTPBDT
S VOTPEDT=+$$READ("DA^::E"," Enter END Date: ","T","Enter an INCLUSIVE end date for the report")
Q:'VOTPEDT
I $L(VOTPEDT,".")=1 S VOTPEDT=VOTPEDT_".2359"
I VOTPBDT>VOTPEDT W !,"END DATE must be more recent than the START DATE" S (VOTPBDT,VOTPEDT)="" G ASKDT
;
Q:$$SELDEV()
S OTPVFLG=1
S ID="OR_OTP:ORRP OTP DISPENSE~;;24;10"
D EN(.ROOT,PTIEN,ID,VOTPBDT,VOTPEDT,"","","","")
Q
;
READ(TYPE,PROMPT,DEFAULT,HELP,SCREEN) ; Calls reader, returns response
N DIR,X,Y
S DIR(0)=TYPE
I $D(SCREEN) S DIR("S")=SCREEN
I $G(PROMPT)]"" S DIR("A")=PROMPT
I $G(DEFAULT)]"" S DIR("B")=DEFAULT
I $D(HELP) S DIR("?")=HELP
D ^DIR
I Y]"",($L($G(Y),U)'=2) S Y=Y_U_$G(Y(0),Y)
Q Y
;
SELDEV() ;*** Ask for device type for report to output to ***
K IOP,%ZIS,POP,IO("Q")
S %ZIS("A")="Select output device: ",%ZIS("B")="",%ZIS="Q"
D ^%ZIS S OTPSTOP=$S(POP:1,1:0) I POP W !,"** No device selected or Report printed **" D EXIT
Q $G(OTPSTOP)
;
EXIT ;
K %,%H,%I,%ZIS,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTRTN
W:$E(IOST,1,2)="C-"&($Y) @IOF
S:$D(ZTQUEUED) ZTREQ="@"
S IOP="HOME" D ^%ZISC
K ZTQUEUED,ZTREQ
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORDOTP 8555 printed Sep 23, 2025@20:06:19 Page 2
ORDOTP ; SLC/MAE - Opioid Treatment Components ; Dec 16, 2024@13:29:17
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**618**;;Build 14
+2 ;
+3 ; Reference to ^DPT in ICR# 10035
+4 ; Reference to %DTC in ICR# 10000
+5 ; Reference to %ZIS in ICR# 10086
+6 ; Reference to %ZISC in ICR# 10089
+7 ; Reference to %ZISH in ICR# 2320
+8 ; Reference to ^DIC in ICR# 10006
+9 ; Reference to D^DIQ in ICR# 10004
+10 ; Reference to ^DIR in ICR# 10026
+11 ; Reference to ^XLFDT in ICR# 10103
+12 ; Reference to ^XLFSTR in ICR# 10104
+13 ;
EN(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;OTP REPORT
+1 NEW DSPAMT,DSPAMTCHG,DSPBY,DSPDATE,DSPDOW,DSPDIFF,DSPDTTM,DSPEND,DSPFMDATE,DSPFMDAY,DSPHOW,DSPIEN
+2 NEW DSPINI,DSPINT,DSPINTDT,DSPLINE,DSPREC,DSPROWS,DSPTIME,DSPMED,DSPWEEK,DSPWKCOL,DSPWKCTR
+3 NEW FRSTDSPDT,HDR,LASTDSPDT,LEGEND,M,MEDDATE,NODSPCTR,NUMWEEKS,PTIEN,PTNAME,X
+4 IF $LENGTH($GET(DTRANGE))
IF '$GET(ALPHA)
SET ALPHA=$$FMADD^XLFDT(DT,-DTRANGE)
SET OMEGA=$$NOW^XLFDT
+5 if '$GET(ALPHA)
QUIT
if '$GET(OMEGA)
QUIT
+6 ;
+7 IF $GET(OTPVFLG)=""
Begin DoDot:1
+8 NEW IOM,IOSL,IOST,IOF
+9 DO HFSOPEN("RPC")
IF POP
SET ^TMP("OR OTP",$JOB,1)="ERROR: UNABLE TO ACCESS HFS DIRECTORY "_$$DEFDIR^%ZISH()
SET ^TMP("OR OTP",$JOB,2)="PLEASE CHECK DIRECTORY WRITE PRIVILEGES."
QUIT
+10 USE IO
+11 DO GETDATA
+12 DO PRTDATA
+13 DO HFSCLOSE("RPC")
+14 SET ROOT=$NAME(^TMP("OR OTP",$JOB))
End DoDot:1
+15 IF $GET(OTPVFLG)=1
Begin DoDot:1
+16 USE IO
+17 DO GETDATA
+18 DO PRTDATA
+19 DO ^%ZISC
+20 KILL OTPSTOP
+21 KILL ^TMP("OR OTP",$JOB)
End DoDot:1
+22 ;
+23 QUIT
+24 ;
GETDATA ;Retrieve OTP Dispense data
+1 KILL ^TMP("OR OTP",$JOB,"WEEKS"),^TMP("OR OTP",$JOB,"OTPREC")
+2 IF '$DATA(^ORD(101.22,"B",DFN))
DO HDR
WRITE !," **** NO PATIENT DATA FOUND ***"
QUIT
+3 SET PTIEN=$ORDER(^ORD(101.22,"B",DFN,""))
+4 SET PTNAME=$PIECE(^DPT(DFN,0),U)
+5 SET FRSTDSPDT=$ORDER(^ORD(101.22,PTIEN,1,"B",""))
+6 SET LASTDSPDT=$ORDER(^ORD(101.22,PTIEN,1,"B",""),-1)
+7 DO WEEKS
+8 if '$DATA(^TMP("OR OTP",$JOB,"WEEKS"))
QUIT
+9 SET MEDDATE=""
FOR
SET MEDDATE=$ORDER(^ORD(101.22,PTIEN,1,"B",MEDDATE))
if MEDDATE=""
QUIT
Begin DoDot:1
+10 if MEDDATE<ALPHA
QUIT
+11 if MEDDATE>OMEGA
QUIT
+12 SET DSPIEN=""
FOR
SET DSPIEN=$ORDER(^ORD(101.22,PTIEN,1,"B",MEDDATE,DSPIEN))
if DSPIEN=""
QUIT
Begin DoDot:2
+13 SET DSPREC=^ORD(101.22,PTIEN,1,DSPIEN,0)
+14 SET DSPBY=$PIECE(DSPREC,U,4)
+15 SET DSPINI=$PIECE(DSPREC,U,5)
+16 SET DSPHOW=$SELECT($PIECE(DSPREC,U,6)="C":"In Clinic",$PIECE(DSPREC,U,6)="H":"Take Home")
+17 SET DSPMED=$PIECE(DSPREC,U,2)
IF DSPMED[" "
SET DSPMED=$EXTRACT($PIECE(DSPMED," ",1),1,4)_" "_$EXTRACT($PIECE(DSPMED," ",2),1,3)_" "
+18 SET DSPAMT=$PIECE(DSPREC,U,7)
IF $GET(DSPAMTCHG)=""
SET DSPAMTCHG=DSPAMT
+19 IF DSPAMTCHG'=DSPAMT
SET DSPAMTCHG=DSPAMT
SET DSPAMT=DSPAMT_" **"
+20 SET DSPDATE=$PIECE($PIECE(DSPREC,U,3),".",1)
+21 SET DSPTIME=$PIECE($PIECE(DSPREC,U,3),".",2)_"0000"
SET DSPTIME=$EXTRACT(DSPTIME,1,2)_":"_$EXTRACT(DSPTIME,3,4)
+22 SET DSPINTDT=$PIECE(DSPREC,U,8)
+23 SET DSPINT=$PIECE(DSPREC,U,9)
+24 SET DSPWKCOL=$PIECE(^TMP("OR OTP",$JOB,"WEEKS","DATE",MEDDATE),U)
+25 IF DSPHOW="In Clinic"
Begin DoDot:3
+26 SET ^TMP("OR OTP",$JOB,"OTPREC",MEDDATE,DSPWKCOL)=$GET(^TMP("OR OTP",$JOB,"OTPREC",MEDDATE,DSPWKCOL))_U_DSPHOW_U_DSPTIME_" "_DSPINI_" "_U_DSPMED_U_DSPAMT_$$REPEAT^XLFSTR(" ",9-$LENGTH(DSPAMT))
End DoDot:3
+27 IF DSPHOW="Take Home"
Begin DoDot:3
+28 SET ^TMP("OR OTP",$JOB,"OTPREC",MEDDATE,DSPWKCOL)=$GET(^TMP("OR OTP",$JOB,"OTPREC",MEDDATE,DSPWKCOL))_U_DSPHOW_U_" "_U_" "_U_" "
End DoDot:3
+29 IF $GET(DSPBY)'=""
IF '$DATA(LEGEND(DSPBY))
SET LEGEND(DSPBY)=DSPINI
End DoDot:2
End DoDot:1
+30 ;
+31 QUIT
+32 ;
PRTDATA ;Print OTP Dispense data
+1 IF '$DATA(^ORD(101.22,"B",DFN))
QUIT
+2 DO HDR
+3 IF '$DATA(^TMP("OR OTP",$JOB,"WEEKS"))
WRITE !," **** NO OTP MEDICATION DISPENSE DATA FOUND ***",!
QUIT
+4 SET DSPWEEK=""
FOR
SET DSPWEEK=$ORDER(^TMP("OR OTP",$JOB,"WEEKS","COL",DSPWEEK))
if DSPWEEK=""
QUIT
Begin DoDot:1
+5 SET NODSPCTR=0
SET DSPWKCTR=0
+6 WRITE !,$TRANSLATE($JUSTIFY("-",26)," ","-")_" MEDICATION TO BE TAKEN ON: "_$TRANSLATE($JUSTIFY("-",25)," ","-")
+7 WRITE !,"| | | | | | | |"
+8 WRITE !,"|"
FOR X=1:1:7
WRITE $SELECT('$DATA(^TMP("OR OTP",$JOB,"WEEKS","COL",DSPWEEK,X)):" ",1:$PIECE(^TMP("OR OTP",$JOB,"WEEKS","COL",DSPWEEK,X),U,2))_$SELECT(X=7:" |",1:"|")
+9 WRITE !,"| | | | | | | |"
+10 WRITE !,$TRANSLATE($JUSTIFY("",79)," ","-"),!
+11 SET DSPWKCTR=$ORDER(^TMP("OR OTP",$JOB,"WEEKS","COL",DSPWEEK,""),-1)
FOR X=1:1:DSPWKCTR
SET DSPFMDAY=$PIECE($GET(^TMP("OR OTP",$JOB,"WEEKS","COL",DSPWEEK,X)),U,1)
if DSPFMDAY=""
QUIT
Begin DoDot:2
+12 IF '$DATA(^TMP("OR OTP",$JOB,"OTPREC",DSPFMDAY,X))
SET NODSPCTR=$GET(NODSPCTR)+1
End DoDot:2
+13 IF NODSPCTR=DSPWKCTR
WRITE !," **** NO OTP MEDICATION DISPENSE DATA FOUND ***",!
QUIT
+14 SET DSPROWS=""
+15 ;GET NUMBER OF ROWS
FOR X=1:1:DSPWKCTR
Begin DoDot:2
+16 SET DSPFMDAY=$PIECE(^TMP("OR OTP",$JOB,"WEEKS","COL",DSPWEEK,X),"^",1)
+17 if '$DATA(^TMP("OR OTP",$JOB,"OTPREC",DSPFMDAY,X))
QUIT
+18 SET DSPROWS=$SELECT($LENGTH(^TMP("OR OTP",$JOB,"OTPREC",DSPFMDAY,X),"^")-1>DSPROWS:$LENGTH(^TMP("OR OTP",$JOB,"OTPREC",DSPFMDAY,X),"^")-1,1:DSPROWS)
End DoDot:2
+19 FOR M=1:1:DSPROWS
Begin DoDot:2
+20 SET DSPLINE=""
+21 FOR X=1:1:7
if '$DATA(^TMP("OR OTP",$JOB,"WEEKS","COL",DSPWEEK))
QUIT
Begin DoDot:3
+22 SET DSPFMDAY=$PIECE($GET(^TMP("OR OTP",$JOB,"WEEKS","COL",DSPWEEK,X)),U,1)
+23 SET DSPFMDATE=$PIECE($GET(^TMP("OR OTP",$JOB,"WEEKS","COL",DSPWEEK,X)),U,2)
+24 IF DSPFMDAY=""
SET DSPLINE=DSPLINE_"| "_$SELECT(X=7:" |",1:"")
QUIT
+25 SET DSPLINE=DSPLINE_$SELECT($PIECE($GET(^TMP("OR OTP",$JOB,"OTPREC",DSPFMDAY,X)),U,M+1)="":"| ",1:"|"_$PIECE(^TMP("OR OTP",$JOB,"OTPREC",DSPFMDAY,X),U,M+1)_" ")_$SELECT(X=7:" |",1:"")
End DoDot:3
+26 WRITE DSPLINE,!
+27 IF M#4=0
IF (M'=DSPROWS)
WRITE "| | | | | | | |",!
End DoDot:2
+28 WRITE $TRANSLATE($JUSTIFY("",79)," ","-"),!
End DoDot:1
+29 ;
+30 DO LEGEND
+31 ;
+32 QUIT
+33 ;
HDR ;OTP Report Header
+1 WRITE "OTP MEDICATION DISPENSE REPORT for "_$$FMTE^XLFDT(ALPHA)_" to "_$$FMTE^XLFDT(OMEGA)
+2 DO NOW^%DTC
SET Y=+$EXTRACT(%,1,12)
DO D^DIQ
+3 WRITE !,?80-$LENGTH("Run Date: "_Y),"Run Date: "_Y
+4 SET HDR("PAGE")=$GET(HDR("PAGE"))+1
+5 WRITE !,?80-$LENGTH("Page: "_HDR("PAGE")),"Page: "_HDR("PAGE")
+6 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","="),!
+7 QUIT
+8 ;
WEEKS ;Build Weeks Header
+1 SET DSPDIFF=$$FMDIFF^XLFDT(OMEGA,ALPHA,1)
+2 SET DSPEND=$$FMADD^XLFDT(ALPHA,DSPDIFF)
+3 SET MEDDATE=$SELECT(ALPHA<FRSTDSPDT:FRSTDSPDT,1:ALPHA)
+4 FOR
Begin DoDot:1
+5 SET X=MEDDATE
DO H^%DTC
SET DSPWEEK=%H
+6 FOR DSPDOW=1:1:7
Begin DoDot:2
+7 SET %H=DSPWEEK+DSPDOW-1
DO YMD^%DTC
+8 if X>OMEGA!(X>LASTDSPDT)
QUIT
+9 SET ^TMP("OR OTP",$JOB,"WEEKS","COL",DSPWEEK,DSPDOW)=X_U_$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_(1700+$EXTRACT(X,1,3))
+10 SET ^TMP("OR OTP",$JOB,"WEEKS","DATE",X)=DSPDOW_U_DSPWEEK
End DoDot:2
+11 SET %H=DSPWEEK+7
DO YMD^%DTC
SET MEDDATE=X
+12 SET NUMWEEKS=$GET(NUMWEEKS)+1
End DoDot:1
if X>DSPEND
QUIT
+13 QUIT
+14 ;
LEGEND ;Legend
+1 WRITE !!," ** LEGEND **"
+2 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","=")
+3 WRITE !!,"Initial - Name Legend"
+4 SET DSPBY=""
FOR
SET DSPBY=$ORDER(LEGEND(DSPBY))
if DSPBY=""
QUIT
WRITE !,LEGEND(DSPBY)_" - "_DSPBY
+5 WRITE !!,"BLANK SPACE - shows that no dispense information was received via the interface."
+6 WRITE !,"This can indicate the patient was a no-show for their appointment, no medication"
+7 WRITE !,"was prescribed/dispensed, or that the interface failed to send the data."
+8 WRITE !!,"** - Asterisks indicate that Dispense Amount may have changed within the week."
+9 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","=")
+10 QUIT
+11 ;
HFSOPEN(HANDLE) ;open HFS
+1 NEW OTPDIR,OTPFILE
+2 SET OTPDIR=$$DEFDIR^%ZISH()
+3 SET OTPFILE="ORDOTP"_DUZ_".DAT"
+4 DO OPEN^%ZISH(HANDLE,OTPDIR,OTPFILE,"W")
if POP
QUIT
+5 SET IOM=132
SET IOSL=99999
SET IOST="P-DUMMY"
SET IOF=""""""
+6 QUIT
+7 ;
HFSCLOSE(HANDLE) ;close HFS
+1 NEW OTPDIR,OTPFILE,OTPDEL
+2 DO CLOSE^%ZISH(HANDLE)
+3 KILL ^TMP("OR OTP",$JOB,1)
+4 SET OTPDIR=$$DEFDIR^%ZISH()
+5 SET OTPFILE="ORDOTP"_DUZ_".DAT"
SET OTPDEL(OTPFILE)=""
+6 SET X=$$FTG^%ZISH(OTPDIR,OTPFILE,$NAME(^TMP("OR OTP",$JOB,1)),3)
+7 SET X=$$DEL^%ZISH(OTPDIR,$NAME(OTPDEL))
+8 QUIT
+9 ;
ASK ;VistA hook for OTP Dispense Report
+1 NEW PTIEN,VOTPBDT,VOTPEDT,ID,OTPVFLG
+2 SET (PTIEN,X)=""
SET DIC(0)="AEQMZ"
+3 SET DIC("A")="Select PATIENT: "
+4 SET DIC="^DPT("
DO ^DIC
KILL DIC
IF $EXTRACT(X)="^"
QUIT
+5 IF Y="-1"
GOTO ASK
+6 IF Y>0
SET PTIEN=+Y
+7 ;
ASKDT ;
+1 SET VOTPBDT=+$$READ("DA^::E","Enter START Date: ","T-7","Enter a start date for the report")
+2 if 'VOTPBDT
QUIT
+3 SET VOTPEDT=+$$READ("DA^::E"," Enter END Date: ","T","Enter an INCLUSIVE end date for the report")
+4 if 'VOTPEDT
QUIT
+5 IF $LENGTH(VOTPEDT,".")=1
SET VOTPEDT=VOTPEDT_".2359"
+6 IF VOTPBDT>VOTPEDT
WRITE !,"END DATE must be more recent than the START DATE"
SET (VOTPBDT,VOTPEDT)=""
GOTO ASKDT
+7 ;
+8 if $$SELDEV()
QUIT
+9 SET OTPVFLG=1
+10 SET ID="OR_OTP:ORRP OTP DISPENSE~;;24;10"
+11 DO EN(.ROOT,PTIEN,ID,VOTPBDT,VOTPEDT,"","","","")
+12 QUIT
+13 ;
READ(TYPE,PROMPT,DEFAULT,HELP,SCREEN) ; Calls reader, returns response
+1 NEW DIR,X,Y
+2 SET DIR(0)=TYPE
+3 IF $DATA(SCREEN)
SET DIR("S")=SCREEN
+4 IF $GET(PROMPT)]""
SET DIR("A")=PROMPT
+5 IF $GET(DEFAULT)]""
SET DIR("B")=DEFAULT
+6 IF $DATA(HELP)
SET DIR("?")=HELP
+7 DO ^DIR
+8 IF Y]""
IF ($LENGTH($GET(Y),U)'=2)
SET Y=Y_U_$GET(Y(0),Y)
+9 QUIT Y
+10 ;
SELDEV() ;*** Ask for device type for report to output to ***
+1 KILL IOP,%ZIS,POP,IO("Q")
+2 SET %ZIS("A")="Select output device: "
SET %ZIS("B")=""
SET %ZIS="Q"
+3 DO ^%ZIS
SET OTPSTOP=$SELECT(POP:1,1:0)
IF POP
WRITE !,"** No device selected or Report printed **"
DO EXIT
+4 QUIT $GET(OTPSTOP)
+5 ;
EXIT ;
+1 KILL %,%H,%I,%ZIS,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTRTN
+2 if $EXTRACT(IOST,1,2)="C-"&($Y)
WRITE @IOF
+3 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 SET IOP="HOME"
DO ^%ZISC
+5 KILL ZTQUEUED,ZTREQ
+6 QUIT
+7 ;
