PSBOSF ;BIRMINGHAM/EFC-UNABLE TO SCAN DETAIL REPORT ; 29 Aug 2008 11:33 PM
;;3.0;BAR CODE MED ADMIN;**28,52,80**;Mar 2004;Build 6
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; Reference/IA
; ^NURSF(211.4/1409
; WARD^NURSUT5/3052
;
EN ; UTS Report Entry Point - Report OPTION used by PSB UNABLE TO SCAN (UTS) key holders.
N PSBX1,PSBX2,PSBX3,PSBIEN,PSBMRGST,PSBHDR,PSBTOT,PSBDSCN
N PSBCMNT0,PSBCMNTX,PSBCMTLN,PSBCRLF,PSBI,PSBINDAT,PSBNDENT,PSBMRG,PSBX,I,J
K PSBSRTBY,PSBSTWD
; Set Wards based on selection and user's Division - DUZ(2).
S PSBSTWD=$P(PSBRPT(.1),U,3) I $G(PSBSTWD)'="" K PSBWARD D LISTWD
K PSBWDDV D WARDDIV^PSBOST(.PSBWDDV,DUZ(2))
; Set Start and End dates/times.
S PSBDTST=+$P(PSBRPT(.1),U,6)_$P(PSBRPT(.1),U,7)
S PSBDTSP=+$P(PSBRPT(.1),U,8)_$P(PSBRPT(.1),U,9)
; Set the sort options internal values. If no sort option
; selected, default to ascending date/time.
S PSBSRTBY=$G(PSBRPT(.52)) S:$G(PSBSRTBY)="" PSBSRTBY="2,,"
D NOW^%DTC S Y=% D DD^%DT S PSBDTTM=Y
; Kill the scratch sort file.
K ^XTMP("PSBO",$J,"PSBLIST"),^TMP("PSBSF",$J),PSBLIST ;PSB*3*52 will now store report data in ^TMP("PSBSF",$J) instead of PSBOUTP array
S (PSBLNTOT,PSBTOT,PSBX1)="",PSBPGNUM=0
S PSBX1=$$FMADD^XLFDT(PSBDTST,,,,-.1)
; Get the records from the MSF UTS log by date (PSBX1) and IEN (PSBX2).
F S PSBX1=$O(^PSB(53.77,"ASFDT",PSBX1)) Q:(PSBX1>PSBDTSP)!(+PSBX1=0) D
.S PSBX2="" F S PSBX2=$O(^PSB(53.77,"ASFDT",PSBX1,PSBX2)) Q:PSBX2="" D
..; Don't report successful scans.
..N PSBSCTYP S PSBSCTYP=$P(^PSB(53.77,PSBX2,0),U,5)
..; Don't list successful scans.
..I "WSCN,WKEY,MSCN,MKEY,MMME"[PSBSCTYP Q
..I '$D(^PSB(53.77,PSBX2,0))!($D(PSBLIST(PSBX2))) Q
..S PSBWRD=$P($P($G(^PSB(53.77,PSBX2,0)),U,3),"$",1)_"$"
..; Filter data by institution.
..I '$D(PSBWDDV(PSBWRD)),'$D(PSBWARD(+PSBSTWD,PSBWRD)) Q ;Add check for report run by nursing ward, PSB*3*80
..I $G(PSBSTWD)]"",'$D(PSBWARD(PSBSTWD)) Q
..I $G(PSBSTWD)]"",'$D(PSBWARD(PSBSTWD,PSBWRD)) Q
..L +^PSB(53.77,PSBX2):3 I L -^PSB(53.77,PSBX2) S PSBLIST(PSBX2)=""
S Y=PSBDTST D DD^%DT S Y1=Y S Y=PSBDTSP D DD^%DT S Y2=Y
; Create the Sort Option Header text.
F X=1:1:3 D
.S PSBHDR=$G(PSBHDR)_$S($P(PSBSRTBY,",",X)=1:"PATIENT'S NAME; ",$P(PSBSRTBY,",",X)=2:"DATE/TIME of UTS (ascending); ",$P(PSBSRTBY,",",X)=3:"LOCATION WARD/RmBd; ",1:"")
.S PSBHDR=$G(PSBHDR)_$S($P(PSBSRTBY,",",X)=4:"TYPE; ",$P(PSBSRTBY,",",X)=5:"DRUG; ",$P(PSBSRTBY,",",X)=6:"USER'S NAME; ",1:"")
.S PSBHDR=$G(PSBHDR)_$S($P(PSBSRTBY,",",X)=7:"REASON UNABLE TO SCAN; ",$P(PSBSRTBY,",",X)=-2:"DATE/TIME of UTS (descending); ",1:"")
.Q
S PSBHDR=$E(PSBHDR,1,($L(PSBHDR)-2))
; Add the record to the scratch sort file.
D BLDRPT
I PSBTOT=0 S ^TMP("PSBSF",$J,0,14)="W !!,""<<<< NO DOCUMENTED BCMA UNABLE TO SCAN EVENTS FOR THIS DATE RANGE >>>>"",!!"
;
; Send the report.
D WRTRPT
K %,O,PSBBLANK,PSBDTSP,PSBDTST,PSBDTTM
K PSBFLD,PSBLNO,PSBLNTOT,PSBMORE
K PSBPG,PSBPGNUM,PSBPGRM,PSBRPT,PSBSFCMT,PSBSFHD2,PSBSRTBY,PSBSRTNM
K PSBSTWD,PSBCMNT0,PSBTAB0,PSBTAB4,PSBTAB7,PSBTOT1,PSBTOTX,PSBVAL
K PSBVAL1,PSBVAL2,PSBVAL3,PSBWARD,PSBWRD,PSBXORX,XX,Y1,Y2,YY,ZZ
Q
;
BLDRPT ; Compile the report.
S PSBPGNUM="",PSBX3="" D CREATHDR
S PSBPGNUM=1,PSBTOT1=0
I '$D(^XUSEC("PSB UNABLE TO SCAN",DUZ)) D Q
.S ^TMP("PSBSF",$J,0,14)="W !!,""<<<< BCMA UNABLE TO SCAN REPORTS HAVE RESTRICTED ACCESS >>>>"",!!"
I '$D(PSBSFHD1) D Q
.S ^TMP("PSBSF",$J,0,14)="W !!,""<<<< Print format NOT SUPPORTED. 80&132 col formats ARE supported. >>>>"",!!"
I '$D(PSBLIST) D Q
.S ^TMP("PSBSF",$J,0,14)="W !!,""<<<< NO DOCUMENTED BCMA UNABLE TO SCAN EVENTS FOR THIS DATE RANGE >>>>"",!!"
;
; Extract the data for the list of records.
F S PSBX3=$O(PSBLIST(PSBX3)) Q:+PSBX3=0 K PSBDATA D
.;
.; Patient's Name (VAID)
.I $P(^PSB(53.77,PSBX3,0),U,2)]"" D
..N DFN,VA,VADM S DFN=$P(^PSB(53.77,PSBX3,0),U,2)
..D DEM^VADPT,PID^VADPT
..S PSBDATA(1)=VADM(1),PSBDATA(1,0)="("_$S(DUZ("AG")="I":(VA("PID")),1:$E(VA("PID"),$L(VA("PID"))-3,999))_")" ;Add code to send full HRN for IHS sites, PSB*3*80
.;
.; Scan Failure Date/Time
.S PSBINDAT=$$GET1^DIQ(53.77,PSBX3_",",.04,"I"),Y=PSBINDAT D DD^%DT
.S PSBDATA(2)=$TR($P(Y,"@")," "),PSBDATA(2,0)="@"_$P(Y,"@",2)
.;
.; UTS Location
.S PSBDATA(3)=$P($$GET1^DIQ(53.77,PSBX3_",",.03),"$"),PSBDATA(3,0)="/"_($P($$GET1^DIQ(53.77,PSBX3_",",.03),"$",2))
.;
.; UTS Type - Get the parameter from File #53.69, compare it to the value below,and quit if not compatible.
.S PSBDATA(4)=$S($E($P($$GET1^DIQ(53.77,PSBX3_",",.05)," "),1)="M":"MED",$E($P($$GET1^DIQ(53.77,PSBX3_",",.05)," "),1)="W":"WRIST")
.I $P($G(PSBRPT(3)),",",1)=1&(PSBDATA(4)="WRIST") Q
.I $P($G(PSBRPT(3)),",",1)=2&(PSBDATA(4)="MED") Q
.;
.; Drug (IEN)
.S (PSBDATA(5),PSBDATA(5,0))=""
.F PSBI=2,3,4 I $D(^PSB(53.77,PSBX3,PSBI,1,0)) S PSBDATA(5,0)="("_$P(^PSB(53.77,PSBX3,PSBI,1,0),U)_")",PSBDATA(5)=$P(^PSB(53.77,PSBX3,PSBI,1,0),U,2) Q
.I $$GET1^DIQ(53.77,PSBX3_",",13)["WS" S PSBDATA(4,0)="(WS)",PSBDATA(5,0)="("_$$GET1^DIQ(53.77,PSBX3_",",13)_")",PSBDATA(5)=$P(^PSB(53.77,PSBX3,5),U,2)
.I $$GET1^DIQ(53.77,PSBX3_",",13)]"",$$GET1^DIQ(53.77,PSBX3_",",13)'["WS" D
..S PSBDATA(4,0)="(UID)",PSBDATA(5,0)="("_$$GET1^DIQ(53.77,PSBX3_",",13)_")",PSBDATA(5)=$$GET1^DIQ(53.77,PSBX3_",",15)
.S:PSBDATA(5)="" PSBDATA(5)=" " S:PSBDATA(5,0)="" PSBDATA(5.0)=" "
.;
.; User Name
.S PSBDATA(6)=$$GET1^DIQ(53.77,PSBX3_",",.01)
.;
.; UTS Reason - Get the parameter from File #53.69. Quit if defined and '= reason.
.S PSBDATA(7)=$$GET1^DIQ(53.77,PSBX3_",",.06)
.I $P($G(PSBRPT(3)),",",2)=1&(PSBDATA(7)'="Damaged Medication Label") Q
.I $P($G(PSBRPT(3)),",",2)=2&(PSBDATA(7)'="Damaged Wristband") Q
.I $P($G(PSBRPT(3)),",",2)=3&(PSBDATA(7)'="No Bar Code") Q
.I $P($G(PSBRPT(3)),",",2)=4&(PSBDATA(7)'="Scanning Equipment Failure") Q
.I $P($G(PSBRPT(3)),",",2)=5&(PSBDATA(7)'="Unable to Determine") Q
.I $P($G(PSBRPT(3)),",",2)=6&(PSBDATA(7)'="Dose Discrepancy") Q
.;
.; Create sort subscripts.
.S (PSBDATA(0),PSBIEN)=PSBX3
.;
SORT .; Sort the line.
.; Sort Option internal values:
.; 1=PATIENT'S NAME
.; 2=DATE/TIME OF SCAN FAILURE (ascending)
.; 3=LOCATION WARD/RmBd
.; 4=TYPE
.; 5=DRUG
.; 6=USER'S NAME
.; 7=UNABLE TO SCAN REASON
.; -2=DATE/TIME OF SCAN FAILURE (descending)
.;
.; Count how many sort options were selected.
.F X=0:1:2 Q:$P(PSBSRTBY,",",X+1)="" S PSBSRTNM=X+1
.;
.; Add current line to sort file using the sort option data as the
.; record's file subscripts. Convert commas in the data to a $ in
.; case the data (PSBX2) is one of the sort keys.
.S (PSBX1,PSBX2)="",PSBMRG="^XTMP(""PSBO"",$J,""PSBLIST"""
.F X=1:1:PSBSRTNM S PSBX1=$P(PSBSRTBY,",",X) Q:PSBX1="" S PSBDSCN="" D
..I PSBX1=2!(PSBX1=-2) S:PSBX1=-2 PSBDSCN="-" S PSBX2=PSBINDAT D
...I PSBSRTNM>1,X=1!(X=2) S PSBX2=$P(PSBINDAT,".")
...S PSBX2=PSBDSCN_PSBX2
..I PSBX1'=2&(PSBX1'=-2) S PSBX2=PSBDATA(PSBX1),PSBX2=$TR(PSBX2,",","$")
..S PSBMRG=PSBMRG_","_""""_PSBX2_""""
.S PSBMRG=PSBMRG_","_PSBIEN_")" M @PSBMRG=PSBDATA
.S PSBTOT=PSBTOT+1 I +PSBTOT=0 K PSBLIST,^XTMP("PSBO",$J,"PSBLIST")
; Retrieve the sorted records.
; Set sort file root.
S PSBMRG="^XTMP(""PSBO"",$J,""PSBLIST"")"
; Work through the sort file zero node for each scan event and load the data into
; the local array PSBDATA.
F S PSBMRG=$Q(@PSBMRG) Q:PSBMRG=""!($P(PSBMRG,",")'["PSBO")!($P(PSBMRG,",",2)'=$J) D
.K PSBRPLN,PSBCMNT1,PSBCMNT2,PSBCMNT3 S PSBX1=$P(PSBMRG,",",PSBSRTNM+4)
.;
.; Get comment. Skip the comment parsing if no comment.
.S PSBSFCMT=$G(^PSB(53.77,PSBX1,1)),PSBCMNTX="COMMENT: "_PSBSFCMT,PSBNDENT=" "
.S $E(PSBCMNT0,PSBTAB7)="|"
.I PSBCMNTX="COMMENT: " S PSBCMNT1=PSBCMNTX G CONSTR
.;
.; Replace any quotes in comment.
.I $F(PSBCMNTX,"""")>0 S PSBCMNTX=$TR(PSBCMNTX,"""","'")
.;
.; # of lines needed to parse comment.
.S PSBCMTLN=$L(PSBCMNTX)\PSBTAB7+($L(PSBCMNTX)#PSBTAB7>0)
.;
.; Parse and wrap the comment by space character. Treat consecutive spaces
.; as one space. Treat a "!~" sequence as a forced CRLF token from GUI.
.; PSBTAB7 is the report width based on the user's device.
.; If "!~" CRLF token sent by GUI, separate the system comment from the user comment.
.S PSBX=$F(PSBCMNTX,"!~"),PSBCRLF=0 I PSBX>0 S PSBCRLF=1 D
..S PSBCMNT1=$E(PSBCMNTX,1,PSBX-3),PSBCMNTX=$E(PSBCMNTX,PSBX,999)
.;
.; Wrap the system comment if needed.
.I PSBCRLF=1,$L(PSBCMNT1)>PSBTAB7 D
..S PSBCMNT2=PSBNDENT
..F PSBI=1:1:$L(PSBCMNT1," ") I $L($P(PSBCMNT1," ",1,PSBI))>PSBTAB7 D Q
...S PSBCMNT2=PSBCMNT2_$P(PSBCMNT1," ",PSBI,999)
...S PSBCMNT1=$P(PSBCMNT1," ",1,PSBI-1)
..S PSBCRLF=2
.;
.; If no space character in user comment, insert a space in the comment
.; based on line length in PSBTAB7.
.I $E(PSBCMNTX,10,999)'[" " S PSBCMNTX=$E(PSBCMNTX,1,PSBTAB7-15)_" "_$E(PSBCMNTX,PSBTAB7-14,999)
.;
.; Wrap the comment into multiple lines if needed.
.S PSBLNO=1+PSBCRLF F PSBI=1:1:$L(PSBCMNTX," ") D
..I PSBCRLF,PSBLNO>1,$G(@("PSBCMNT"_PSBLNO))="" S @("PSBCMNT"_PSBLNO)=PSBNDENT
..S PSBX=$P(PSBCMNTX," ",PSBI) Q:PSBX="" ; Don't wrap for contiguous spaces.
..D
...I $L($G(@("PSBCMNT"_PSBLNO)))+$L(PSBX)'>PSBTAB7 S @("PSBCMNT"_PSBLNO)=$G(@("PSBCMNT"_PSBLNO))_PSBX_" " Q
...S PSBLNO=PSBLNO+1,@("PSBCMNT"_PSBLNO)=PSBNDENT_PSBX_" "
.;
CONSTR .; Construct output from UTS event record.
.S PSBTOT1=PSBTOT1+1,PSBTOTX=PSBBLANK,$E(PSBTOTX,0,$L(PSBTOT1_".")-1)=PSBTOT1_"."
.S PSBXORX=$$GET1^DIQ(53.77,PSBX1_",",.08)
.I PSBXORX]"" S PSBXORX="ORD#: "_PSBXORX,$E(PSBTOTX,PSBTAB4+2,PSBTAB4+2+($L(PSBXORX)-1))=PSBXORX
.K PSBDATA M PSBDATA=@($P(PSBMRG,",",1,PSBSRTNM+4)_")")
.D BUILDLN
.S ^TMP("PSBSF",$J,$$PGTOT,PSBLNTOT)="W """_PSBTOTX_""""
.F I=1:1:10 Q:'$D(PSBRPLN(I)) D
..F J=1:1:7 S $E(PSBRPLN(I),@("PSBTAB"_J))="|"
..S ^TMP("PSBSF",$J,$$PGTOT,PSBLNTOT)="W !,"""_PSBRPLN(I)_""""
.S $E(PSBCMNT1,PSBTAB7)="|"
.I $D(PSBCMNT2) S $E(PSBCMNT2,PSBTAB7)="|"
.I $D(PSBCMNT3) S $E(PSBCMNT3,PSBTAB7)="|"
.S ^TMP("PSBSF",$J,$$PGTOT,PSBLNTOT)="W !,"""_PSBCMNT0_""""
.S ^TMP("PSBSF",$J,$$PGTOT,PSBLNTOT)="W !,"""_PSBCMNT1_""""
.I $D(PSBCMNT2) S ^TMP("PSBSF",$J,$$PGTOT,PSBLNTOT)="W !,"""_PSBCMNT2_""""
.I $D(PSBCMNT3) S ^TMP("PSBSF",$J,$$PGTOT,PSBLNTOT)="W !,"""_PSBCMNT3_""""
.S ^TMP("PSBSF",$J,$$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBTAB7),"" "",""-""),!"
.;
.; Force a skip to the next record's zero node.
.S $P(PSBMRG,",",PSBSRTNM+5)="999999)"
;
K PSBRPLN,PSBCMNT1,PSBCMNT2,PSBCMNT3
Q
;
BUILDLN ; Construct records
K LN,J F PSBFLD=1:1:7 D FORMDAT(PSBFLD) S LN(J)="" K J
Q
;
FORMDAT(FLD) ; Format the data.
S J=3,PSBVAL=PSBDATA(FLD),PSBVAL(0)="" I $D(PSBDATA(FLD,0)) S PSBVAL(0)=PSBDATA(FLD,0)
I IOM'>90 S XX=@("PSBTAB"_(FLD-1))+1,YY=(@("PSBTAB"_FLD)-1)-XX,ZZ=PSBVAL_" "_PSBVAL(0) D Q
.S O=$$WRAPPER(XX,YY,ZZ)
I ($L(PSBVAL)+(@("PSBTAB"_(FLD-1))))<(@("PSBTAB"_FLD)-1) D Q
.F PSBI=$L(PSBVAL)+(@("PSBTAB"_(FLD-1))):1:(@("PSBTAB"_FLD)-3) S PSBVAL=PSBVAL_" "
.S $E(PSBRPLN(1),@("PSBTAB"_(FLD-1))+2,(@("PSBTAB"_FLD)-1))=PSBVAL
.F PSBI=$L(PSBVAL(0))+(@("PSBTAB"_(FLD-1))):1:(@("PSBTAB"_FLD)-3) S PSBVAL(0)=PSBVAL(0)_" "
.S $E(PSBRPLN(2),@("PSBTAB"_(FLD-1))+2,(@("PSBTAB"_FLD)-1))=PSBVAL(0)
I ($L(PSBVAL)+(@("PSBTAB"_(FLD-1))))'<(@("PSBTAB"_FLD)-1) D Q
.I $F(PSBVAL,",")>1 S PSBVAL1=$E(PSBVAL,1,$F(PSBVAL,",")-1),PSBVAL2=$E(PSBVAL,$F(PSBVAL,","),999)
.E S PSBVAL1=$E(PSBVAL,1,$F(PSBVAL," ")-1),PSBVAL2=$E(PSBVAL,$F(PSBVAL," "),999)
.F PSBI=$L(PSBVAL1)+(@("PSBTAB"_(FLD-1))):1:(@("PSBTAB"_FLD)-3) S PSBVAL1=PSBVAL1_" "
.I $D(PSBVAL2) I ($L(PSBVAL2)+(@("PSBTAB"_(FLD-1))))'<(@("PSBTAB"_FLD)-1) D
..S PSBVAL3=$E(PSBVAL2,$F(PSBVAL2," "),999),PSBVAL2=$E(PSBVAL2,1,$F(PSBVAL2," ")-1)
..F PSBI=$L(PSBVAL3)+(@("PSBTAB"_(FLD-1))):1:(@("PSBTAB"_FLD)-3) S PSBVAL3=PSBVAL3_" "
..S $E(PSBRPLN(3),@("PSBTAB"_(FLD-1))+2,(@("PSBTAB"_FLD)-1))=PSBVAL3
.I ($L(PSBVAL1)+(@("PSBTAB"_(FLD-1))))>(@("PSBTAB"_FLD)-2) D
..S PSBVAL2=($E(PSBVAL1,(@("PSBTAB"_FLD)-1)-(@("PSBTAB"_(FLD-1))),999))_PSBVAL2
..S PSBVAL1=$E(PSBVAL1,1,(((@("PSBTAB"_FLD)-1))-(@("PSBTAB"_(FLD-1))+1)))
.S $E(PSBRPLN(1),@("PSBTAB"_(FLD-1))+2,(@("PSBTAB"_FLD)-1))=PSBVAL1
.F PSBI=$L(PSBVAL2)+(@("PSBTAB"_(FLD-1))):1:(@("PSBTAB"_FLD)-3) S PSBVAL2=PSBVAL2_" "
.S $E(PSBRPLN(2),@("PSBTAB"_(FLD-1))+2,(@("PSBTAB"_FLD)-1))=$E(PSBVAL2,1,((@("PSBTAB"_FLD)-1))-(@("PSBTAB"_(FLD-1))+1))
.I $E(PSBVAL(0),1)'="" D
..F PSBI=$L(PSBVAL(0))+(@("PSBTAB"_(FLD-1))):1:(@("PSBTAB"_FLD)-3) S PSBVAL(0)=PSBVAL(0)_" "
..S $E(PSBRPLN(3),@("PSBTAB"_(FLD-1))+2,(@("PSBTAB"_FLD)-1))=PSBVAL(0)
Q
;
WRTRPT ; Write the report.
I $O(^TMP("PSBSF",$J,""),-1)<1 D Q
.S ^TMP("PSBSF",$J,0,14)="W !!,""<<<< NO DOCUMENTED BCMA UNABLE TO SCAN EVENTS FOR THIS DATE RANGE >>>>"",!!"
.D HDR
.X ^TMP("PSBSF",$J,$O(^TMP("PSBSF",$J,""),-1),14)
.D FTR
S PSBPGNUM=1
D HDR
S PSBX1="" F S PSBX1=$O(^TMP("PSBSF",$J,PSBX1)) Q:PSBX1="" D
.I PSBPGNUM'=PSBX1 D FTR S PSBPGNUM=PSBX1 D HDR
.S PSBX2="" F S PSBX2=$O(^TMP("PSBSF",$J,PSBX1,PSBX2)) Q:PSBX2="" D
..X ^TMP("PSBSF",$J,PSBX1,PSBX2)
D FTR
K ^XTMP("PSBO",$J,"PSBLIST"),^TMP("PSBSF",$J)
Q
;
HDR ; Write the report header.
N PSBDIV,PSBARRY,PSBNPAR ;New variables for PSB*3*80
I '$D(PSBHDR) S PSBHDR=""
W:$Y>1 @IOF W:$X>1 !
S PSBPG="Page: "_PSBPGNUM_" of "_$S($O(^TMP("PSBSF",$J,""),-1)=0:1,1:$O(^TMP("PSBSF",$J,""),-1))
S PSBPGRM=PSBTAB7-($L(PSBPG))
I $P(PSBRPT(0),U,4)="" S $P(PSBRPT(0),U,4)=DUZ(2)
D CREATHDR
W !!,"BCMA UNABLE TO SCAN (Detailed)" W ?PSBPGRM,PSBPG
W !!,"Date/Time: "_PSBDTTM,!,"Report Date Range: Start Date: "_Y1_" Stop Date: "_Y2
W !,"Type of Scanning Failure: ",$S(+$P($G(PSBRPT(3)),",",1)=0:"All",+$P($G(PSBRPT(3)),",",1)=1:"Medication",1:"Wristband")
W !,"Reason: " D
.I $P($G(PSBRPT(3)),",",2)=0 W "All Reasons" Q
.I $P($G(PSBRPT(3)),",",2)=1 W "Damaged Medication Label" Q
.I $P($G(PSBRPT(3)),",",2)=2 W "Damaged Wristband" Q
.I $P($G(PSBRPT(3)),",",2)=3 W "No Bar Code" Q
.I $P($G(PSBRPT(3)),",",2)=4 W "Scanning Equipment Failure" Q
.I $P($G(PSBRPT(3)),",",2)=5 W "Unable to Determine" Q
.I $P($G(PSBRPT(3)),",",2)=6 W "Dose Discrepancy" Q
S PSBDIV=$P($G(^DIC(4,DUZ("2"),0)),U,1) I $G(PSBWLOC) S PSBNPAR="L^"_PSBWLOC D WARD^NURSUT5(PSBNPAR,.PSBARRY) S PSBDIV=$P($G(PSBARRY(PSBWLOC,.02)),U,2) ;Set Division based on ward, PSB*3*80
W !,"Division: ",PSBDIV
W " Nurse Location: " D
.I $G(PSBSTWD)]"" W $$NURLOC(PSBSTWD) Q
.W "All"
W !,"Sorted By: "_PSBHDR,?(PSBTAB7-($L("Total BCMA Unable to Scan events: "_+PSBTOT))),"Total BCMA Unable to Scan events: "_+PSBTOT
W !!,$$WRAP^PSBO(5,PSBTAB7-5,"This is a report of documented BCMA ""Unable to Scan"" events within the given date range.")
W !!,$TR($J("",PSBTAB7)," ","_")
I $D(PSBSFHD1) W !,PSBSFHD1
I $D(PSBSFHD2) W !,PSBSFHD2
W !,$TR($J("",PSBTAB7)," ","="),!
Q
;
FTR ; Write the report footer.
I IOSL<100 F Q:$Y>(IOSL-12) W !
W !,$TR($J("",PSBTAB7)," ","=")
W $$WRAP^PSBO(5,PSBTAB7-5,"Note: IV orders will display the orderable item associated with that IV Order in the Drug column."),!
W !,PSBDTTM,!,"BCMA UNABLE TO SCAN (Detailed)"
W ?PSBPGRM,PSBPG,!
Q
;
PGTOT(X) ; Track PAGE Number.
S:'$D(X) PSBLNTOT=PSBLNTOT+1 S:$D(X) PSBLNTOT=PSBLNTOT+X
I PSBPGNUM=1,(PSBLNTOT=1) S PSBLNTOT=15 S PSBMORE=PSBLNTOT+7 Q PSBPGNUM
I PSBLNTOT'<PSBMORE D
.S PSBMORE=PSBLNTOT+7
.I PSBMORE>(IOSL-9) S PSBPGNUM=PSBPGNUM+1,PSBLNTOT=15 S PSBMORE=PSBLNTOT+7
Q PSBPGNUM
;
CREATHDR ; Create report header.
K PSBSFHD1
I IOM'<122 S PSBSFHD1=$P($T(SFHD132A),";",3),PSBSFHD2=$P($T(SFHD132B),";",3),PSBBLANK=$P($T(SF132BLK),";",3)
I (IOM'>90),(IOM'<75) S PSBSFHD1=$P($T(SFHD80A),";",3),PSBSFHD2=$P($T(SFHD80B),";",3),PSBBLANK=$P($T(SF80BLK),";",3)
I '$D(PSBSFHD1) S PSBTAB7=80 Q
; reset tabs
S PSBTAB0=1 F PSBI=0:1:($L(PSBSFHD1,"|")-2) S:PSBI>0 @("PSBTAB"_PSBI)=($F(PSBSFHD1,"|",@("PSBTAB"_(PSBI-1))+1))-1
Q
;
SFHD132A ;;| PATIENT'S NAME | DATE/TIME | LOCATION | | DRUG | | REASON |
Q
SFHD132B ;;| (PID) | of UTS | WARD/RmBd | TYPE | (ID#) | USER'S NAME | UTS |
Q
SF132BLK ;; | | | | | | |
Q
SF80BLK ;; | | | | | | |
Q
SFHD80A ;;|PATIENT'S |DATE/TIME| LOCATION | | DRUG | USER'S | REASON |
Q
SFHD80B ;;|NAME (PID)| of UTS | WARD/RmBd| TYPE | (ID#) | NAME | UTS |
Q
;
WRAPPER(X,Y,Z) ; Wrap text line.
N PSB S J=1
F Q:'$L(Z) D
.I $L(Z)<Y S $E(PSBRPLN(J),X)=Z S Z="" Q
.F PSB=Y:-1:0 Q:$E(Z,PSB)=" "
.S:PSB<1 PSB=Y S $E(PSBRPLN(J),X)=$E(Z,1,PSB)
.S Z=$E(Z,PSB+1,250),J=J+1
Q ""
;
LISTWD ; List wards & nursing locations.
K PSBWARD I $G(PSBSTWD)']"" Q
N PSBLOOP S PSBLOOP=0
F S PSBLOOP=$O(^NURSF(211.4,PSBSTWD,3,PSBLOOP)) Q:PSBLOOP="" D
.S PSBWARD(PSBSTWD,$P($G(^NURSF(211.4,PSBSTWD,3,PSBLOOP,0)),U,1))=$P($G(^DIC(42,$P($G(^NURSF(211.4,PSBSTWD,3,PSBLOOP,0)),U,1),0)),U,1)_"$"
.S PSBWARD(PSBSTWD,$P($G(^DIC(42,$P($G(^NURSF(211.4,PSBSTWD,3,PSBLOOP,0)),U,1),0)),U,1)_"$")=$P($G(^NURSF(211.4,PSBSTWD,3,PSBLOOP,0)),U,1)
Q
;
NURLOC(X) ; Nursing Location Name.
N PSBNULC S PSBNULC=$G(^NURSF(211.4,X,0)) I PSBNULC="" Q PSBNULC
S PSBNULC=$P($G(^SC(PSBNULC,0)),U,1)
Q PSBNULC
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBOSF 17644 printed Nov 22, 2024@16:51:06 Page 2
PSBOSF ;BIRMINGHAM/EFC-UNABLE TO SCAN DETAIL REPORT ; 29 Aug 2008 11:33 PM
+1 ;;3.0;BAR CODE MED ADMIN;**28,52,80**;Mar 2004;Build 6
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; ^NURSF(211.4/1409
+6 ; WARD^NURSUT5/3052
+7 ;
EN ; UTS Report Entry Point - Report OPTION used by PSB UNABLE TO SCAN (UTS) key holders.
+1 NEW PSBX1,PSBX2,PSBX3,PSBIEN,PSBMRGST,PSBHDR,PSBTOT,PSBDSCN
+2 NEW PSBCMNT0,PSBCMNTX,PSBCMTLN,PSBCRLF,PSBI,PSBINDAT,PSBNDENT,PSBMRG,PSBX,I,J
+3 KILL PSBSRTBY,PSBSTWD
+4 ; Set Wards based on selection and user's Division - DUZ(2).
+5 SET PSBSTWD=$PIECE(PSBRPT(.1),U,3)
IF $GET(PSBSTWD)'=""
KILL PSBWARD
DO LISTWD
+6 KILL PSBWDDV
DO WARDDIV^PSBOST(.PSBWDDV,DUZ(2))
+7 ; Set Start and End dates/times.
+8 SET PSBDTST=+$PIECE(PSBRPT(.1),U,6)_$PIECE(PSBRPT(.1),U,7)
+9 SET PSBDTSP=+$PIECE(PSBRPT(.1),U,8)_$PIECE(PSBRPT(.1),U,9)
+10 ; Set the sort options internal values. If no sort option
+11 ; selected, default to ascending date/time.
+12 SET PSBSRTBY=$GET(PSBRPT(.52))
if $GET(PSBSRTBY)=""
SET PSBSRTBY="2,,"
+13 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET PSBDTTM=Y
+14 ; Kill the scratch sort file.
+15 ;PSB*3*52 will now store report data in ^TMP("PSBSF",$J) instead of PSBOUTP array
KILL ^XTMP("PSBO",$JOB,"PSBLIST"),^TMP("PSBSF",$JOB),PSBLIST
+16 SET (PSBLNTOT,PSBTOT,PSBX1)=""
SET PSBPGNUM=0
+17 SET PSBX1=$$FMADD^XLFDT(PSBDTST,,,,-.1)
+18 ; Get the records from the MSF UTS log by date (PSBX1) and IEN (PSBX2).
+19 FOR
SET PSBX1=$ORDER(^PSB(53.77,"ASFDT",PSBX1))
if (PSBX1>PSBDTSP)!(+PSBX1=0)
QUIT
Begin DoDot:1
+20 SET PSBX2=""
FOR
SET PSBX2=$ORDER(^PSB(53.77,"ASFDT",PSBX1,PSBX2))
if PSBX2=""
QUIT
Begin DoDot:2
+21 ; Don't report successful scans.
+22 NEW PSBSCTYP
SET PSBSCTYP=$PIECE(^PSB(53.77,PSBX2,0),U,5)
+23 ; Don't list successful scans.
+24 IF "WSCN,WKEY,MSCN,MKEY,MMME"[PSBSCTYP
QUIT
+25 IF '$DATA(^PSB(53.77,PSBX2,0))!($DATA(PSBLIST(PSBX2)))
QUIT
+26 SET PSBWRD=$PIECE($PIECE($GET(^PSB(53.77,PSBX2,0)),U,3),"$",1)_"$"
+27 ; Filter data by institution.
+28 ;Add check for report run by nursing ward, PSB*3*80
IF '$DATA(PSBWDDV(PSBWRD))
IF '$DATA(PSBWARD(+PSBSTWD,PSBWRD))
QUIT
+29 IF $GET(PSBSTWD)]""
IF '$DATA(PSBWARD(PSBSTWD))
QUIT
+30 IF $GET(PSBSTWD)]""
IF '$DATA(PSBWARD(PSBSTWD,PSBWRD))
QUIT
+31 LOCK +^PSB(53.77,PSBX2):3
IF $TEST
LOCK -^PSB(53.77,PSBX2)
SET PSBLIST(PSBX2)=""
End DoDot:2
End DoDot:1
+32 SET Y=PSBDTST
DO DD^%DT
SET Y1=Y
SET Y=PSBDTSP
DO DD^%DT
SET Y2=Y
+33 ; Create the Sort Option Header text.
+34 FOR X=1:1:3
Begin DoDot:1
+35 SET PSBHDR=$GET(PSBHDR)_$SELECT($PIECE(PSBSRTBY,",",X)=1:"PATIENT'S NAME; ",$PIECE(PSBSRTBY,",",X)=2:"DATE/TIME of UTS (ascending); ",$PIECE(PSBSRTBY,",",X)=3:"LOCATION WARD/RmBd; ",1:"")
+36 SET PSBHDR=$GET(PSBHDR)_$SELECT($PIECE(PSBSRTBY,",",X)=4:"TYPE; ",$PIECE(PSBSRTBY,",",X)=5:"DRUG; ",$PIECE(PSBSRTBY,",",X)=6:"USER'S NAME; ",1:"")
+37 SET PSBHDR=$GET(PSBHDR)_$SELECT($PIECE(PSBSRTBY,",",X)=7:"REASON UNABLE TO SCAN; ",$PIECE(PSBSRTBY,",",X)=-2:"DATE/TIME of UTS (descending); ",1:"")
+38 QUIT
End DoDot:1
+39 SET PSBHDR=$EXTRACT(PSBHDR,1,($LENGTH(PSBHDR)-2))
+40 ; Add the record to the scratch sort file.
+41 DO BLDRPT
+42 IF PSBTOT=0
SET ^TMP("PSBSF",$JOB,0,14)="W !!,""<<<< NO DOCUMENTED BCMA UNABLE TO SCAN EVENTS FOR THIS DATE RANGE >>>>"",!!"
+43 ;
+44 ; Send the report.
+45 DO WRTRPT
+46 KILL %,O,PSBBLANK,PSBDTSP,PSBDTST,PSBDTTM
+47 KILL PSBFLD,PSBLNO,PSBLNTOT,PSBMORE
+48 KILL PSBPG,PSBPGNUM,PSBPGRM,PSBRPT,PSBSFCMT,PSBSFHD2,PSBSRTBY,PSBSRTNM
+49 KILL PSBSTWD,PSBCMNT0,PSBTAB0,PSBTAB4,PSBTAB7,PSBTOT1,PSBTOTX,PSBVAL
+50 KILL PSBVAL1,PSBVAL2,PSBVAL3,PSBWARD,PSBWRD,PSBXORX,XX,Y1,Y2,YY,ZZ
+51 QUIT
+52 ;
BLDRPT ; Compile the report.
+1 SET PSBPGNUM=""
SET PSBX3=""
DO CREATHDR
+2 SET PSBPGNUM=1
SET PSBTOT1=0
+3 IF '$DATA(^XUSEC("PSB UNABLE TO SCAN",DUZ))
Begin DoDot:1
+4 SET ^TMP("PSBSF",$JOB,0,14)="W !!,""<<<< BCMA UNABLE TO SCAN REPORTS HAVE RESTRICTED ACCESS >>>>"",!!"
End DoDot:1
QUIT
+5 IF '$DATA(PSBSFHD1)
Begin DoDot:1
+6 SET ^TMP("PSBSF",$JOB,0,14)="W !!,""<<<< Print format NOT SUPPORTED. 80&132 col formats ARE supported. >>>>"",!!"
End DoDot:1
QUIT
+7 IF '$DATA(PSBLIST)
Begin DoDot:1
+8 SET ^TMP("PSBSF",$JOB,0,14)="W !!,""<<<< NO DOCUMENTED BCMA UNABLE TO SCAN EVENTS FOR THIS DATE RANGE >>>>"",!!"
End DoDot:1
QUIT
+9 ;
+10 ; Extract the data for the list of records.
+11 FOR
SET PSBX3=$ORDER(PSBLIST(PSBX3))
if +PSBX3=0
QUIT
KILL PSBDATA
Begin DoDot:1
+12 ;
+13 ; Patient's Name (VAID)
+14 IF $PIECE(^PSB(53.77,PSBX3,0),U,2)]""
Begin DoDot:2
+15 NEW DFN,VA,VADM
SET DFN=$PIECE(^PSB(53.77,PSBX3,0),U,2)
+16 DO DEM^VADPT
DO PID^VADPT
+17 ;Add code to send full HRN for IHS sites, PSB*3*80
SET PSBDATA(1)=VADM(1)
SET PSBDATA(1,0)="("_$SELECT(DUZ("AG")="I":(VA("PID")),1:$EXTRACT(VA("PID"),$LENGTH(VA("PID"))-3,999))_")"
End DoDot:2
+18 ;
+19 ; Scan Failure Date/Time
+20 SET PSBINDAT=$$GET1^DIQ(53.77,PSBX3_",",.04,"I")
SET Y=PSBINDAT
DO DD^%DT
+21 SET PSBDATA(2)=$TRANSLATE($PIECE(Y,"@")," ")
SET PSBDATA(2,0)="@"_$PIECE(Y,"@",2)
+22 ;
+23 ; UTS Location
+24 SET PSBDATA(3)=$PIECE($$GET1^DIQ(53.77,PSBX3_",",.03),"$")
SET PSBDATA(3,0)="/"_($PIECE($$GET1^DIQ(53.77,PSBX3_",",.03),"$",2))
+25 ;
+26 ; UTS Type - Get the parameter from File #53.69, compare it to the value below,and quit if not compatible.
+27 SET PSBDATA(4)=$SELECT($EXTRACT($PIECE($$GET1^DIQ(53.77,PSBX3_",",.05)," "),1)="M":"MED",$EXTRACT($PIECE($$GET1^DIQ(53.77,PSBX3_",",.05)," "),1)="W":"WRIST")
+28 IF $PIECE($GET(PSBRPT(3)),",",1)=1&(PSBDATA(4)="WRIST")
QUIT
+29 IF $PIECE($GET(PSBRPT(3)),",",1)=2&(PSBDATA(4)="MED")
QUIT
+30 ;
+31 ; Drug (IEN)
+32 SET (PSBDATA(5),PSBDATA(5,0))=""
+33 FOR PSBI=2,3,4
IF $DATA(^PSB(53.77,PSBX3,PSBI,1,0))
SET PSBDATA(5,0)="("_$PIECE(^PSB(53.77,PSBX3,PSBI,1,0),U)_")"
SET PSBDATA(5)=$PIECE(^PSB(53.77,PSBX3,PSBI,1,0),U,2)
QUIT
+34 IF $$GET1^DIQ(53.77,PSBX3_",",13)["WS"
SET PSBDATA(4,0)="(WS)"
SET PSBDATA(5,0)="("_$$GET1^DIQ(53.77,PSBX3_",",13)_")"
SET PSBDATA(5)=$PIECE(^PSB(53.77,PSBX3,5),U,2)
+35 IF $$GET1^DIQ(53.77,PSBX3_",",13)]""
IF $$GET1^DIQ(53.77,PSBX3_",",13)'["WS"
Begin DoDot:2
+36 SET PSBDATA(4,0)="(UID)"
SET PSBDATA(5,0)="("_$$GET1^DIQ(53.77,PSBX3_",",13)_")"
SET PSBDATA(5)=$$GET1^DIQ(53.77,PSBX3_",",15)
End DoDot:2
+37 if PSBDATA(5)=""
SET PSBDATA(5)=" "
if PSBDATA(5,0)=""
SET PSBDATA(5.0)=" "
+38 ;
+39 ; User Name
+40 SET PSBDATA(6)=$$GET1^DIQ(53.77,PSBX3_",",.01)
+41 ;
+42 ; UTS Reason - Get the parameter from File #53.69. Quit if defined and '= reason.
+43 SET PSBDATA(7)=$$GET1^DIQ(53.77,PSBX3_",",.06)
+44 IF $PIECE($GET(PSBRPT(3)),",",2)=1&(PSBDATA(7)'="Damaged Medication Label")
QUIT
+45 IF $PIECE($GET(PSBRPT(3)),",",2)=2&(PSBDATA(7)'="Damaged Wristband")
QUIT
+46 IF $PIECE($GET(PSBRPT(3)),",",2)=3&(PSBDATA(7)'="No Bar Code")
QUIT
+47 IF $PIECE($GET(PSBRPT(3)),",",2)=4&(PSBDATA(7)'="Scanning Equipment Failure")
QUIT
+48 IF $PIECE($GET(PSBRPT(3)),",",2)=5&(PSBDATA(7)'="Unable to Determine")
QUIT
+49 IF $PIECE($GET(PSBRPT(3)),",",2)=6&(PSBDATA(7)'="Dose Discrepancy")
QUIT
+50 ;
+51 ; Create sort subscripts.
+52 SET (PSBDATA(0),PSBIEN)=PSBX3
+53 ;
SORT ; Sort the line.
+1 ; Sort Option internal values:
+2 ; 1=PATIENT'S NAME
+3 ; 2=DATE/TIME OF SCAN FAILURE (ascending)
+4 ; 3=LOCATION WARD/RmBd
+5 ; 4=TYPE
+6 ; 5=DRUG
+7 ; 6=USER'S NAME
+8 ; 7=UNABLE TO SCAN REASON
+9 ; -2=DATE/TIME OF SCAN FAILURE (descending)
+10 ;
+11 ; Count how many sort options were selected.
+12 FOR X=0:1:2
if $PIECE(PSBSRTBY,",",X+1)=""
QUIT
SET PSBSRTNM=X+1
+13 ;
+14 ; Add current line to sort file using the sort option data as the
+15 ; record's file subscripts. Convert commas in the data to a $ in
+16 ; case the data (PSBX2) is one of the sort keys.
+17 SET (PSBX1,PSBX2)=""
SET PSBMRG="^XTMP(""PSBO"",$J,""PSBLIST"""
+18 FOR X=1:1:PSBSRTNM
SET PSBX1=$PIECE(PSBSRTBY,",",X)
if PSBX1=""
QUIT
SET PSBDSCN=""
Begin DoDot:2
+19 IF PSBX1=2!(PSBX1=-2)
if PSBX1=-2
SET PSBDSCN="-"
SET PSBX2=PSBINDAT
Begin DoDot:3
+20 IF PSBSRTNM>1
IF X=1!(X=2)
SET PSBX2=$PIECE(PSBINDAT,".")
+21 SET PSBX2=PSBDSCN_PSBX2
End DoDot:3
+22 IF PSBX1'=2&(PSBX1'=-2)
SET PSBX2=PSBDATA(PSBX1)
SET PSBX2=$TRANSLATE(PSBX2,",","$")
+23 SET PSBMRG=PSBMRG_","_""""_PSBX2_""""
End DoDot:2
+24 SET PSBMRG=PSBMRG_","_PSBIEN_")"
MERGE @PSBMRG=PSBDATA
+25 SET PSBTOT=PSBTOT+1
IF +PSBTOT=0
KILL PSBLIST,^XTMP("PSBO",$JOB,"PSBLIST")
End DoDot:1
+26 ; Retrieve the sorted records.
+27 ; Set sort file root.
+28 SET PSBMRG="^XTMP(""PSBO"",$J,""PSBLIST"")"
+29 ; Work through the sort file zero node for each scan event and load the data into
+30 ; the local array PSBDATA.
+31 FOR
SET PSBMRG=$QUERY(@PSBMRG)
if PSBMRG=""!($PIECE(PSBMRG,",")'["PSBO")!($PIECE(PSBMRG,",",2)'=$JOB)
QUIT
Begin DoDot:1
+32 KILL PSBRPLN,PSBCMNT1,PSBCMNT2,PSBCMNT3
SET PSBX1=$PIECE(PSBMRG,",",PSBSRTNM+4)
+33 ;
+34 ; Get comment. Skip the comment parsing if no comment.
+35 SET PSBSFCMT=$GET(^PSB(53.77,PSBX1,1))
SET PSBCMNTX="COMMENT: "_PSBSFCMT
SET PSBNDENT=" "
+36 SET $EXTRACT(PSBCMNT0,PSBTAB7)="|"
+37 IF PSBCMNTX="COMMENT: "
SET PSBCMNT1=PSBCMNTX
GOTO CONSTR
+38 ;
+39 ; Replace any quotes in comment.
+40 IF $FIND(PSBCMNTX,"""")>0
SET PSBCMNTX=$TRANSLATE(PSBCMNTX,"""","'")
+41 ;
+42 ; # of lines needed to parse comment.
+43 SET PSBCMTLN=$LENGTH(PSBCMNTX)\PSBTAB7+($LENGTH(PSBCMNTX)#PSBTAB7>0)
+44 ;
+45 ; Parse and wrap the comment by space character. Treat consecutive spaces
+46 ; as one space. Treat a "!~" sequence as a forced CRLF token from GUI.
+47 ; PSBTAB7 is the report width based on the user's device.
+48 ; If "!~" CRLF token sent by GUI, separate the system comment from the user comment.
+49 SET PSBX=$FIND(PSBCMNTX,"!~")
SET PSBCRLF=0
IF PSBX>0
SET PSBCRLF=1
Begin DoDot:2
+50 SET PSBCMNT1=$EXTRACT(PSBCMNTX,1,PSBX-3)
SET PSBCMNTX=$EXTRACT(PSBCMNTX,PSBX,999)
End DoDot:2
+51 ;
+52 ; Wrap the system comment if needed.
+53 IF PSBCRLF=1
IF $LENGTH(PSBCMNT1)>PSBTAB7
Begin DoDot:2
+54 SET PSBCMNT2=PSBNDENT
+55 FOR PSBI=1:1:$LENGTH(PSBCMNT1," ")
IF $LENGTH($PIECE(PSBCMNT1," ",1,PSBI))>PSBTAB7
Begin DoDot:3
+56 SET PSBCMNT2=PSBCMNT2_$PIECE(PSBCMNT1," ",PSBI,999)
+57 SET PSBCMNT1=$PIECE(PSBCMNT1," ",1,PSBI-1)
End DoDot:3
QUIT
+58 SET PSBCRLF=2
End DoDot:2
+59 ;
+60 ; If no space character in user comment, insert a space in the comment
+61 ; based on line length in PSBTAB7.
+62 IF $EXTRACT(PSBCMNTX,10,999)'[" "
SET PSBCMNTX=$EXTRACT(PSBCMNTX,1,PSBTAB7-15)_" "_$EXTRACT(PSBCMNTX,PSBTAB7-14,999)
+63 ;
+64 ; Wrap the comment into multiple lines if needed.
+65 SET PSBLNO=1+PSBCRLF
FOR PSBI=1:1:$LENGTH(PSBCMNTX," ")
Begin DoDot:2
+66 IF PSBCRLF
IF PSBLNO>1
IF $GET(@("PSBCMNT"_PSBLNO))=""
SET @("PSBCMNT"_PSBLNO)=PSBNDENT
+67 ; Don't wrap for contiguous spaces.
SET PSBX=$PIECE(PSBCMNTX," ",PSBI)
if PSBX=""
QUIT
+68 Begin DoDot:3
+69 IF $LENGTH($GET(@("PSBCMNT"_PSBLNO)))+$LENGTH(PSBX)'>PSBTAB7
SET @("PSBCMNT"_PSBLNO)=$GET(@("PSBCMNT"_PSBLNO))_PSBX_" "
QUIT
+70 SET PSBLNO=PSBLNO+1
SET @("PSBCMNT"_PSBLNO)=PSBNDENT_PSBX_" "
End DoDot:3
End DoDot:2
+71 ;
CONSTR ; Construct output from UTS event record.
+1 SET PSBTOT1=PSBTOT1+1
SET PSBTOTX=PSBBLANK
SET $EXTRACT(PSBTOTX,0,$LENGTH(PSBTOT1_".")-1)=PSBTOT1_"."
+2 SET PSBXORX=$$GET1^DIQ(53.77,PSBX1_",",.08)
+3 IF PSBXORX]""
SET PSBXORX="ORD#: "_PSBXORX
SET $EXTRACT(PSBTOTX,PSBTAB4+2,PSBTAB4+2+($LENGTH(PSBXORX)-1))=PSBXORX
+4 KILL PSBDATA
MERGE PSBDATA=@($PIECE(PSBMRG,",",1,PSBSRTNM+4)_")")
+5 DO BUILDLN
+6 SET ^TMP("PSBSF",$JOB,$$PGTOT,PSBLNTOT)="W """_PSBTOTX_""""
+7 FOR I=1:1:10
if '$DATA(PSBRPLN(I))
QUIT
Begin DoDot:2
+8 FOR J=1:1:7
SET $EXTRACT(PSBRPLN(I),@("PSBTAB"_J))="|"
+9 SET ^TMP("PSBSF",$JOB,$$PGTOT,PSBLNTOT)="W !,"""_PSBRPLN(I)_""""
End DoDot:2
+10 SET $EXTRACT(PSBCMNT1,PSBTAB7)="|"
+11 IF $DATA(PSBCMNT2)
SET $EXTRACT(PSBCMNT2,PSBTAB7)="|"
+12 IF $DATA(PSBCMNT3)
SET $EXTRACT(PSBCMNT3,PSBTAB7)="|"
+13 SET ^TMP("PSBSF",$JOB,$$PGTOT,PSBLNTOT)="W !,"""_PSBCMNT0_""""
+14 SET ^TMP("PSBSF",$JOB,$$PGTOT,PSBLNTOT)="W !,"""_PSBCMNT1_""""
+15 IF $DATA(PSBCMNT2)
SET ^TMP("PSBSF",$JOB,$$PGTOT,PSBLNTOT)="W !,"""_PSBCMNT2_""""
+16 IF $DATA(PSBCMNT3)
SET ^TMP("PSBSF",$JOB,$$PGTOT,PSBLNTOT)="W !,"""_PSBCMNT3_""""
+17 SET ^TMP("PSBSF",$JOB,$$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBTAB7),"" "",""-""),!"
+18 ;
+19 ; Force a skip to the next record's zero node.
+20 SET $PIECE(PSBMRG,",",PSBSRTNM+5)="999999)"
End DoDot:1
+21 ;
+22 KILL PSBRPLN,PSBCMNT1,PSBCMNT2,PSBCMNT3
+23 QUIT
+24 ;
BUILDLN ; Construct records
+1 KILL LN,J
FOR PSBFLD=1:1:7
DO FORMDAT(PSBFLD)
SET LN(J)=""
KILL J
+2 QUIT
+3 ;
FORMDAT(FLD) ; Format the data.
+1 SET J=3
SET PSBVAL=PSBDATA(FLD)
SET PSBVAL(0)=""
IF $DATA(PSBDATA(FLD,0))
SET PSBVAL(0)=PSBDATA(FLD,0)
+2 IF IOM'>90
SET XX=@("PSBTAB"_(FLD-1))+1
SET YY=(@("PSBTAB"_FLD)-1)-XX
SET ZZ=PSBVAL_" "_PSBVAL(0)
Begin DoDot:1
+3 SET O=$$WRAPPER(XX,YY,ZZ)
End DoDot:1
QUIT
+4 IF ($LENGTH(PSBVAL)+(@("PSBTAB"_(FLD-1))))<(@("PSBTAB"_FLD)-1)
Begin DoDot:1
+5 FOR PSBI=$LENGTH(PSBVAL)+(@("PSBTAB"_(FLD-1))):1:(@("PSBTAB"_FLD)-3)
SET PSBVAL=PSBVAL_" "
+6 SET $EXTRACT(PSBRPLN(1),@("PSBTAB"_(FLD-1))+2,(@("PSBTAB"_FLD)-1))=PSBVAL
+7 FOR PSBI=$LENGTH(PSBVAL(0))+(@("PSBTAB"_(FLD-1))):1:(@("PSBTAB"_FLD)-3)
SET PSBVAL(0)=PSBVAL(0)_" "
+8 SET $EXTRACT(PSBRPLN(2),@("PSBTAB"_(FLD-1))+2,(@("PSBTAB"_FLD)-1))=PSBVAL(0)
End DoDot:1
QUIT
+9 IF ($LENGTH(PSBVAL)+(@("PSBTAB"_(FLD-1))))'<(@("PSBTAB"_FLD)-1)
Begin DoDot:1
+10 IF $FIND(PSBVAL,",")>1
SET PSBVAL1=$EXTRACT(PSBVAL,1,$FIND(PSBVAL,",")-1)
SET PSBVAL2=$EXTRACT(PSBVAL,$FIND(PSBVAL,","),999)
+11 IF '$TEST
SET PSBVAL1=$EXTRACT(PSBVAL,1,$FIND(PSBVAL," ")-1)
SET PSBVAL2=$EXTRACT(PSBVAL,$FIND(PSBVAL," "),999)
+12 FOR PSBI=$LENGTH(PSBVAL1)+(@("PSBTAB"_(FLD-1))):1:(@("PSBTAB"_FLD)-3)
SET PSBVAL1=PSBVAL1_" "
+13 IF $DATA(PSBVAL2)
IF ($LENGTH(PSBVAL2)+(@("PSBTAB"_(FLD-1))))'<(@("PSBTAB"_FLD)-1)
Begin DoDot:2
+14 SET PSBVAL3=$EXTRACT(PSBVAL2,$FIND(PSBVAL2," "),999)
SET PSBVAL2=$EXTRACT(PSBVAL2,1,$FIND(PSBVAL2," ")-1)
+15 FOR PSBI=$LENGTH(PSBVAL3)+(@("PSBTAB"_(FLD-1))):1:(@("PSBTAB"_FLD)-3)
SET PSBVAL3=PSBVAL3_" "
+16 SET $EXTRACT(PSBRPLN(3),@("PSBTAB"_(FLD-1))+2,(@("PSBTAB"_FLD)-1))=PSBVAL3
End DoDot:2
+17 IF ($LENGTH(PSBVAL1)+(@("PSBTAB"_(FLD-1))))>(@("PSBTAB"_FLD)-2)
Begin DoDot:2
+18 SET PSBVAL2=($EXTRACT(PSBVAL1,(@("PSBTAB"_FLD)-1)-(@("PSBTAB"_(FLD-1))),999))_PSBVAL2
+19 SET PSBVAL1=$EXTRACT(PSBVAL1,1,(((@("PSBTAB"_FLD)-1))-(@("PSBTAB"_(FLD-1))+1)))
End DoDot:2
+20 SET $EXTRACT(PSBRPLN(1),@("PSBTAB"_(FLD-1))+2,(@("PSBTAB"_FLD)-1))=PSBVAL1
+21 FOR PSBI=$LENGTH(PSBVAL2)+(@("PSBTAB"_(FLD-1))):1:(@("PSBTAB"_FLD)-3)
SET PSBVAL2=PSBVAL2_" "
+22 SET $EXTRACT(PSBRPLN(2),@("PSBTAB"_(FLD-1))+2,(@("PSBTAB"_FLD)-1))=$EXTRACT(PSBVAL2,1,((@("PSBTAB"_FLD)-1))-(@("PSBTAB"_(FLD-1))+1))
+23 IF $EXTRACT(PSBVAL(0),1)'=""
Begin DoDot:2
+24 FOR PSBI=$LENGTH(PSBVAL(0))+(@("PSBTAB"_(FLD-1))):1:(@("PSBTAB"_FLD)-3)
SET PSBVAL(0)=PSBVAL(0)_" "
+25 SET $EXTRACT(PSBRPLN(3),@("PSBTAB"_(FLD-1))+2,(@("PSBTAB"_FLD)-1))=PSBVAL(0)
End DoDot:2
End DoDot:1
QUIT
+26 QUIT
+27 ;
WRTRPT ; Write the report.
+1 IF $ORDER(^TMP("PSBSF",$JOB,""),-1)<1
Begin DoDot:1
+2 SET ^TMP("PSBSF",$JOB,0,14)="W !!,""<<<< NO DOCUMENTED BCMA UNABLE TO SCAN EVENTS FOR THIS DATE RANGE >>>>"",!!"
+3 DO HDR
+4 XECUTE ^TMP("PSBSF",$JOB,$ORDER(^TMP("PSBSF",$JOB,""),-1),14)
+5 DO FTR
End DoDot:1
QUIT
+6 SET PSBPGNUM=1
+7 DO HDR
+8 SET PSBX1=""
FOR
SET PSBX1=$ORDER(^TMP("PSBSF",$JOB,PSBX1))
if PSBX1=""
QUIT
Begin DoDot:1
+9 IF PSBPGNUM'=PSBX1
DO FTR
SET PSBPGNUM=PSBX1
DO HDR
+10 SET PSBX2=""
FOR
SET PSBX2=$ORDER(^TMP("PSBSF",$JOB,PSBX1,PSBX2))
if PSBX2=""
QUIT
Begin DoDot:2
+11 XECUTE ^TMP("PSBSF",$JOB,PSBX1,PSBX2)
End DoDot:2
End DoDot:1
+12 DO FTR
+13 KILL ^XTMP("PSBO",$JOB,"PSBLIST"),^TMP("PSBSF",$JOB)
+14 QUIT
+15 ;
HDR ; Write the report header.
+1 ;New variables for PSB*3*80
NEW PSBDIV,PSBARRY,PSBNPAR
+2 IF '$DATA(PSBHDR)
SET PSBHDR=""
+3 if $Y>1
WRITE @IOF
if $X>1
WRITE !
+4 SET PSBPG="Page: "_PSBPGNUM_" of "_$SELECT($ORDER(^TMP("PSBSF",$JOB,""),-1)=0:1,1:$ORDER(^TMP("PSBSF",$JOB,""),-1))
+5 SET PSBPGRM=PSBTAB7-($LENGTH(PSBPG))
+6 IF $PIECE(PSBRPT(0),U,4)=""
SET $PIECE(PSBRPT(0),U,4)=DUZ(2)
+7 DO CREATHDR
+8 WRITE !!,"BCMA UNABLE TO SCAN (Detailed)"
WRITE ?PSBPGRM,PSBPG
+9 WRITE !!,"Date/Time: "_PSBDTTM,!,"Report Date Range: Start Date: "_Y1_" Stop Date: "_Y2
+10 WRITE !,"Type of Scanning Failure: ",$SELECT(+$PIECE($GET(PSBRPT(3)),",",1)=0:"All",+$PIECE($GET(PSBRPT(3)),",",1)=1:"Medication",1:"Wristband")
+11 WRITE !,"Reason: "
Begin DoDot:1
+12 IF $PIECE($GET(PSBRPT(3)),",",2)=0
WRITE "All Reasons"
QUIT
+13 IF $PIECE($GET(PSBRPT(3)),",",2)=1
WRITE "Damaged Medication Label"
QUIT
+14 IF $PIECE($GET(PSBRPT(3)),",",2)=2
WRITE "Damaged Wristband"
QUIT
+15 IF $PIECE($GET(PSBRPT(3)),",",2)=3
WRITE "No Bar Code"
QUIT
+16 IF $PIECE($GET(PSBRPT(3)),",",2)=4
WRITE "Scanning Equipment Failure"
QUIT
+17 IF $PIECE($GET(PSBRPT(3)),",",2)=5
WRITE "Unable to Determine"
QUIT
+18 IF $PIECE($GET(PSBRPT(3)),",",2)=6
WRITE "Dose Discrepancy"
QUIT
End DoDot:1
+19 ;Set Division based on ward, PSB*3*80
SET PSBDIV=$PIECE($GET(^DIC(4,DUZ("2"),0)),U,1)
IF $GET(PSBWLOC)
SET PSBNPAR="L^"_PSBWLOC
DO WARD^NURSUT5(PSBNPAR,.PSBARRY)
SET PSBDIV=$PIECE($GET(PSBARRY(PSBWLOC,.02)),U,2)
+20 WRITE !,"Division: ",PSBDIV
+21 WRITE " Nurse Location: "
Begin DoDot:1
+22 IF $GET(PSBSTWD)]""
WRITE $$NURLOC(PSBSTWD)
QUIT
+23 WRITE "All"
End DoDot:1
+24 WRITE !,"Sorted By: "_PSBHDR,?(PSBTAB7-($LENGTH("Total BCMA Unable to Scan events: "_+PSBTOT))),"Total BCMA Unable to Scan events: "_+PSBTOT
+25 WRITE !!,$$WRAP^PSBO(5,PSBTAB7-5,"This is a report of documented BCMA ""Unable to Scan"" events within the given date range.")
+26 WRITE !!,$TRANSLATE($JUSTIFY("",PSBTAB7)," ","_")
+27 IF $DATA(PSBSFHD1)
WRITE !,PSBSFHD1
+28 IF $DATA(PSBSFHD2)
WRITE !,PSBSFHD2
+29 WRITE !,$TRANSLATE($JUSTIFY("",PSBTAB7)," ","="),!
+30 QUIT
+31 ;
FTR ; Write the report footer.
+1 IF IOSL<100
FOR
if $Y>(IOSL-12)
QUIT
WRITE !
+2 WRITE !,$TRANSLATE($JUSTIFY("",PSBTAB7)," ","=")
+3 WRITE $$WRAP^PSBO(5,PSBTAB7-5,"Note: IV orders will display the orderable item associated with that IV Order in the Drug column."),!
+4 WRITE !,PSBDTTM,!,"BCMA UNABLE TO SCAN (Detailed)"
+5 WRITE ?PSBPGRM,PSBPG,!
+6 QUIT
+7 ;
PGTOT(X) ; Track PAGE Number.
+1 if '$DATA(X)
SET PSBLNTOT=PSBLNTOT+1
if $DATA(X)
SET PSBLNTOT=PSBLNTOT+X
+2 IF PSBPGNUM=1
IF (PSBLNTOT=1)
SET PSBLNTOT=15
SET PSBMORE=PSBLNTOT+7
QUIT PSBPGNUM
+3 IF PSBLNTOT'<PSBMORE
Begin DoDot:1
+4 SET PSBMORE=PSBLNTOT+7
+5 IF PSBMORE>(IOSL-9)
SET PSBPGNUM=PSBPGNUM+1
SET PSBLNTOT=15
SET PSBMORE=PSBLNTOT+7
End DoDot:1
+6 QUIT PSBPGNUM
+7 ;
CREATHDR ; Create report header.
+1 KILL PSBSFHD1
+2 IF IOM'<122
SET PSBSFHD1=$PIECE($TEXT(SFHD132A),";",3)
SET PSBSFHD2=$PIECE($TEXT(SFHD132B),";",3)
SET PSBBLANK=$PIECE($TEXT(SF132BLK),";",3)
+3 IF (IOM'>90)
IF (IOM'<75)
SET PSBSFHD1=$PIECE($TEXT(SFHD80A),";",3)
SET PSBSFHD2=$PIECE($TEXT(SFHD80B),";",3)
SET PSBBLANK=$PIECE($TEXT(SF80BLK),";",3)
+4 IF '$DATA(PSBSFHD1)
SET PSBTAB7=80
QUIT
+5 ; reset tabs
+6 SET PSBTAB0=1
FOR PSBI=0:1:($LENGTH(PSBSFHD1,"|")-2)
if PSBI>0
SET @("PSBTAB"_PSBI)=($FIND(PSBSFHD1,"|",@("PSBTAB"_(PSBI-1))+1))-1
+7 QUIT
+8 ;
SFHD132A ;;| PATIENT'S NAME | DATE/TIME | LOCATION | | DRUG | | REASON |
+1 QUIT
SFHD132B ;;| (PID) | of UTS | WARD/RmBd | TYPE | (ID#) | USER'S NAME | UTS |
+1 QUIT
SF132BLK ;; | | | | | | |
+1 QUIT
SF80BLK ;; | | | | | | |
+1 QUIT
SFHD80A ;;|PATIENT'S |DATE/TIME| LOCATION | | DRUG | USER'S | REASON |
+1 QUIT
SFHD80B ;;|NAME (PID)| of UTS | WARD/RmBd| TYPE | (ID#) | NAME | UTS |
+1 QUIT
+2 ;
WRAPPER(X,Y,Z) ; Wrap text line.
+1 NEW PSB
SET J=1
+2 FOR
if '$LENGTH(Z)
QUIT
Begin DoDot:1
+3 IF $LENGTH(Z)<Y
SET $EXTRACT(PSBRPLN(J),X)=Z
SET Z=""
QUIT
+4 FOR PSB=Y:-1:0
if $EXTRACT(Z,PSB)=" "
QUIT
+5 if PSB<1
SET PSB=Y
SET $EXTRACT(PSBRPLN(J),X)=$EXTRACT(Z,1,PSB)
+6 SET Z=$EXTRACT(Z,PSB+1,250)
SET J=J+1
End DoDot:1
+7 QUIT ""
+8 ;
LISTWD ; List wards & nursing locations.
+1 KILL PSBWARD
IF $GET(PSBSTWD)']""
QUIT
+2 NEW PSBLOOP
SET PSBLOOP=0
+3 FOR
SET PSBLOOP=$ORDER(^NURSF(211.4,PSBSTWD,3,PSBLOOP))
if PSBLOOP=""
QUIT
Begin DoDot:1
+4 SET PSBWARD(PSBSTWD,$PIECE($GET(^NURSF(211.4,PSBSTWD,3,PSBLOOP,0)),U,1))=$PIECE($GET(^DIC(42,$PIECE($GET(^NURSF(211.4,PSBSTWD,3,PSBLOOP,0)),U,1),0)),U,1)_"$"
+5 SET PSBWARD(PSBSTWD,$PIECE($GET(^DIC(42,$PIECE($GET(^NURSF(211.4,PSBSTWD,3,PSBLOOP,0)),U,1),0)),U,1)_"$")=$PIECE($GET(^NURSF(211.4,PSBSTWD,3,PSBLOOP,0)),U,1)
End DoDot:1
+6 QUIT
+7 ;
NURLOC(X) ; Nursing Location Name.
+1 NEW PSBNULC
SET PSBNULC=$GET(^NURSF(211.4,X,0))
IF PSBNULC=""
QUIT PSBNULC
+2 SET PSBNULC=$PIECE($GET(^SC(PSBNULC,0)),U,1)
+3 QUIT PSBNULC
