PSBVDLU3 ;BIRMINGHAM/TEJ-BCMA VDL UTILITIES 3 ; 27 Aug 2008 9:06 PM
;;3.0;BAR CODE MED ADMIN;**13,38,28,50**;Mar 2004;Build 78
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
;This routine file has been created to serve as a container
;for Extrinsic Variables/Functions
;
; Reference/IA
; EN^PSJBCMA/2828
; EN^PSJBCMA1/2829
; File 50/221
; File 52.6/436
; File 52.7/437
;
IVPTAB(PSBORTYP,PSBIVTYP,PSBINTSY,PSBCHMTY,PSBPUSH) ;
;
; This function will return
; the value 1 (one) if the
; specified order input will cause
; the order to display on the "IVP/IVPB"
; tab of the VDL BCMA Virtual Due List (VDL)
; else return the value 0 (zero).
;
; Input Parameters:
;
; PSBORTYP - Order type (e.g. "U","V")
; PSBIVTYP - IV Type (e.g. "P","S","C")
; PSBINTSY - Intermittent Syringe value
; PSBCHMTY - Chemo type (e.g. "P","S")
; PSBPUSH - IV PUSH Flag (e.g. 0 or 1, 1=IV PUSH)
;
; Output:
; 1 - order will display on the "IVP/IVPB" Tab of BCMA VDL
; 0 - order will NOT display on the "IVP/IVPB" Tab of BCMA VDL
; -1 - error processed
;
Q:'$D(PSBORTYP) "-1^Missing Parameter"
I PSBORTYP="U"&(PSBPUSH) Q 1
I '(PSBORTYP="V") Q 0
I $G(PSBIVTYP)="P" Q 1
I $G(PSBIVTYP)="S",$G(PSBINTSY)=1 Q 1
I $G(PSBIVTYP)="C",$G(PSBCHMTY)="P" Q 1
I $G(PSBIVTYP)="C",$G(PSBCHMTY)="S",$G(PSBINTSY)=1 Q 1
Q 0
;
SHOVDL(DFN,BDATE,OTDATE,PSBTAB) ;
;
; This function will find orders such as discontinued or expired infusing IV bags
; or discontinued or expired "given" patches. Recognizing these types of orders
; will allow these orders to be displayed on the VDL and permits the user to take
; action on them. This routine determines if such orders exist for patient,
; time, and "BCMA VDL tab." This routine is an "extention" to the API EN^PSJBCMA.
;
; INPUT Parameters:
; DFN (req) Patient Internal File Number.
; BDATE (opt) Start searching for "order stop" after this date.
; OTDATE (opt) Include One-Time orders from this date.
; PSBTAB (opt) "UDTAB" or "IVTAB" - expedites process if specific tab
; is given.
;
; OUTPUT Values
; 0 absolutely no orders to display on VDL
; 1 displayable orders have been located.
;
;
D EN^PSJBCMA(DFN,$G(BDATE),$G(OTDATE))
; any active Patch orders to show on VDL?
S PSBFLG=0
I $G(^TMP("PSJ",$J,1,0))=-1 D
.;
.; Check the indexice for given patches or infusing IVs
.;
.; Check APATCH
.D:($G(PSBTAB)="UDTAB")!($G(PSBTAB)="") Q:PSBFLG
..S PSBGNODE="^PSB(53.79,"_"""APATCH"""_","_DFN_")" Q:'$D(PSBGNODE)
..F S PSBGNODE=$Q(@PSBGNODE) Q:PSBGNODE="" Q:$QS(PSBGNODE,3)'=DFN Q:PSBFLG S PSBIEN=$QS(PSBGNODE,5),PSBFLG=$S($P(^PSB(53.79,PSBIEN,0),U,9)="G":1,1:0)
.;
.; Check AUID
.;
.D:(($G(PSBTAB)="IVTAB")!($G(PSBTAB)=""))&('PSBFLG) Q:PSBFLG
..S PSBGNODE="^PSB(53.79,"_"""AUID"""_","_DFN_")" Q:'$D(PSBGNODE)
..F S PSBGNODE=$Q(@PSBGNODE) Q:PSBGNODE="" Q:$QS(PSBGNODE,3)'=DFN Q:PSBFLG S PSBIEN=$QS(PSBGNODE,6),PSBFLG=$S($P(^PSB(53.79,PSBIEN,0),U,9)="I":1,1:0)
.;
.; NOTE: Infusing bags will not display if DCed more than 3 days ago!
.;
S:$G(^TMP("PSJ",$J,1,0))'=-1 PSBFLG=1
;
Q PSBFLG
;
FNDACTV(RESULTS,PARAMS) ; Utility to check and order for the latest " ? (parameter #3) " order activities per patient (parameter #1)
; #parameter= # "^"piece
; #1 DFN - Patient's IEN e.g. 1234 (required)
; #2 Order Number_Order Type e.g. "1V" "" = all orders
; #3 Search for Activity e.g "" = *unknown* activity
; #4 Search "back"time(hours) e.g. 12 "" = search back 3 admins
; NOTE: ="FREQ" This Function will use order's frequency.
; 1. If the order is a PRN, On Call or One-Time
; the look back a default of 72 hours.
; 2. if the order is a Continuous order key off
; of the frequency as follows.
; a.) if the frequency is <24 hours use the
; default of 72 hours.
; b.) if the frequency is >= 24 hour, look back
; 3.5 times the frequency
; NOTE: ["X#" This Function will search back # of admins.
;
; Example call: D FNDACTV^PSBVDLU3(.TEJ,"1234^1U^H^12")
;
N PSBNOW,PSBDFN,PSBON,PSBCNT,PSBACT,PSBTMFRM,PSBX,PSBSET,PSBFRQ
K RESULTS
S PSBDFN=$P(PARAMS,U),PSBON=$P(PARAMS,U,2),PSBACT=$P(PARAMS,U,3),PSBTMFRM=$P(PARAMS,U,4)
S RESULTS(0)=1
I $G(PSBDFN)']"" S RESULTS(0)=1,RESULTS(1)="-1^ERROR - MISSING PARAMETER (DFN REQ.)" Q
I $G(PSBTMFRM)="" S PSBX=3
I $G(PSBTMFRM)["X" S PSBX=+($P(PSBTMFRM,"X",2)),PSBTMFRM=""
I $G(PSBTMFRM)]"",$G(PSBTMFRM)'["FREQ" D NOW^%DTC S PSBNOW=% S PSBTMFRM=$$FMADD^XLFDT(PSBNOW,"",-1*PSBTMFRM),PSBSET=1 S RESULTS(1)="0^ None found after "_PSBTMFRM
I $G(PSBX)="" S PSBX=9999999
D:$G(PSBON)'=""
.K ^TMP("PSJ",$J) D EN^PSJBCMA1(PSBDFN,PSBON)
.;Maintain Time Frame and other order information
.I $G(PSBTMFRM)["FREQ" D
..S PSBFRQ=+$P(^TMP("PSJ",$J,4),"^",11) I PSBFRQ=0 S PSBFRQ=1440
..I "P^OC^O^"[($P(^TMP("PSJ",$J,4),"^")_"^") S PSBTMFRM=72 Q
..I (PSBFRQ/60)<24 S PSBTMFRM=72 Q
..I (PSBFRQ/60)'<24 S PSBTMFRM=(PSBFRQ/60)*3.5
.I '$G(PSBSET) D NOW^%DTC S PSBNOW=% S PSBTMFRM=$$FMADD^XLFDT(PSBNOW,"",-1*PSBTMFRM) S RESULTS(1)="0^ None found after "_PSBTMFRM
.S I="",X=0 F S I=$O(^PSB(53.79,"AORDX",PSBDFN,PSBON,I),-1) Q:(I="")!(I<$S(PSBTMFRM]"":PSBTMFRM,1:-1)) D Q:X
..S Z=0,J="",PSBCNT=0 F S J=$O(^PSB(53.79,"AORDX",PSBDFN,PSBON,I,J),-1) Q:(J="") S Z=Z+1 Q:Z>PSBX D Q:X
...L +^PSB(53.79,J):DILOCKTM
...I L -^PSB(53.79,J)
...E Q
...I ($P(^PSB(53.79,J,0),U,9)=PSBACT) S X=1 D
....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.02)
....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$P(^TMP("PSJ",$J,2),U,2)_"^"_($$GET1^DIQ(53.79,J_",",.11))
....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.06,"I")
....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.13,"I")
D:$G(PSBON)=""
.S Z="",X=0 F S Z=$O(^PSB(53.79,"AORDX",PSBDFN,Z),-1) Q:(Z="") S PSBON=Z D Q:X
..;Maintain Time Frame and other order information
..K ^TMP("PSJ",$J) D EN^PSJBCMA1(PSBDFN,PSBON)
..I $G(PSBTMFRM)["FREQ" D
...S PSBFRQ=+$P(^TMP("PSJ",$J,4),"^",11) I PSBFRQ=0 S PSBFRQ=1440
...I "P^OC^O^"[($P(^TMP("PSJ",$J,4),"^")_"^") S PSBTMFRM=72 Q
...I (PSBFRQ/60)<24 S PSBTMFRM=72 Q
...I (PSBFRQ/60)'<24 S PSBTMFRM=(PSBFRQ/60)*3.5
..I '$G(PSBSET) D NOW^%DTC S PSBNOW=% S PSBTMFRM=$$FMADD^XLFDT(PSBNOW,"",-1*PSBTMFRM) S RESULTS(1)="0^ None found after "_PSBTMFRM
..S I="" F S I=$O(^PSB(53.79,"AORDX",PSBDFN,PSBON,I),-1) Q:(I="")!(I<$S(PSBTMFRM]"":PSBTMFRM,1:-1)) D Q:X
...S ZZ=0,J="",PSBCNT=0 F S J=$O(^PSB(53.79,"AORDX",PSBDFN,PSBON,I,J),-1) Q:(J="") S ZZ=ZZ+1 Q:ZZ>PSBX D Q:X
....L +^PSB(53.79,J):DILOCKTM
....I L -^PSB(53.79,J)
....E Q
....I ($P(^PSB(53.79,J,0),U,9)=PSBACT) S X=1 D
.....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.02)
.....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$P(^TMP("PSJ",$J,2),U,2)_"^"_($$GET1^DIQ(53.79,J_",",.11))
.....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.06,"I")
.....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.13,"I")
I $G(PSBCNT)>0 S RESULTS(0)=PSBCNT
K ^TMP("PSJ",$J)
Q
;
SCANFAIL(RESULTS,PSBPARAM) ; TEJ 05/12/2006 BCMA-Managing Scanning Failures (MSF)
; Document Unable to Scan Event
; Parameters:
; Input (via GUI):
;
; Per Wristband (0) - Pat IEN ^ ^ Reason Unable to Scan ^ User's Comment ^ "W" ^ 1 (keyed entry) or 2 (scanner)
; Per Medication (0) - Pat IEN ^ Order Number ^ Reason Unable to Scan ^ User's Comment ^ "M" ^ 1 (keyed entry) or 2 (scanner)
; (1) - tag^ unique identifier
; Output:
; Entry into database ^PSB(53.77)
; Electronic Mail - Message Data per Unable to Scan Event
; PSB1 - Patient IEN
; PSB2 - Ward Location/Room
; PSB3 - Reason
; PSB4 - Type of Scan Issue
; PSB5 - Event date/item
; PSB6 - User's Comment
; PSB7 - User identification
; PSB8 - Order Number
; RESULTS(0)=1
; RESULTS(1)= 1 (Success) or -1 (Nonsuccess)
;
K RESULTS,PSBSFUID,PSBMEDOI,PSBMEDNM
S RESULTS(0)=1,RESULTS(1)="-1^Unable to Scan documentation NOT successful!"
N PSBDAT,PSBDAT1,PSBXON,PSBSCHAD
S PSBDAT=PSBPARAM(0) I $D(PSBPARAM(1)) S PSBDAT1=PSBPARAM(1)
S PSBXON=$P(PSBDAT,"^",2)
S PSB8=$G(PSBXON)
S (PSB1,PSBDFN)=$P(PSBDAT,"^")
;
; Changed the ward+room delimiter from / to $.
S PSB2=" *UNIDENTIFIABLE PATIENT* " I +$G(PSB1)>0 S PSB2=$$GET1^DIQ(2,PSB1_",",.1)_"$"_$$GET1^DIQ(2,PSB1_",",.101)
S PSB3=$P(PSBDAT,"^",3) I PSB3="Manual Medication Entry" S PSBMMEN=1
S PSB4=$S($P(PSBDAT,"^",5)="W":"Wristband",$P(PSBDAT,"^",5)="M":"Medication",1:" *UNDEFINED* ")
I PSB4="Medication"&($D(PSBDAT1)) D
.; Determine DD/ADD/SOL
.S PSBMEDOI=$P(PSBDAT1,"^",2)
.S PSBFILE=$P(PSBDAT1,"^"),PSBFILE=$S(PSBFILE="DD":50,PSBFILE="ADD":52.6,PSBFILE="SOL":52.7,1:PSBFILE)
.I PSBFILE'="ID" S PSBMEDNM=$$GET1^DIQ(PSBFILE,PSBMEDOI_",",.01)
.K PSBSFUID I PSBFILE="ID",(PSBMEDOI]"") S PSBSFUID=PSBMEDOI
D NOW^%DTC S (Y,PSB5A)=% D DD^%DT S PSB5=Y
S PSB6=$P(PSBDAT,"^",4)
S PSB7=". *UNDEFINED* " I $G(DUZ)>0 S PSB7=$$GET1^DIQ(200,DUZ_",",.01),PSB7A="`"_DUZ
; Send message.
I $G(PSBMMEN)'=1,$P(PSBDAT,U,6)'=1,$P(PSBDAT,U,6)'=2 D MSFMSG^PSBMLU(PSB1,PSB2,PSB3,PSB4,PSB5,PSB6,PSB7,PSB8,.RESULTS)
I RESULTS(0)=-1 S RESULTS(0)=1,RESULTS(1)="-1^Unable to Scan MAILGROUP NOT SETUP!" Q
;File data
D CLEAN^DILF
N PSBNEW1
S PSBNEW1="+1"
D
.I $G(PSBMMEN)=1 S PSBSCTYP="MMME" Q
.I $P(PSBDAT,U,6)=2 S PSBSCTYP=$S($P(PSBPARAM(0),"^",5)="W":"WSCN",$P(PSBPARAM(0),"^",5)="M":"MSCN") Q
.I $P(PSBDAT,U,6)=1 S PSBSCTYP=$S($P(PSBPARAM(0),"^",5)="W":"WKEY",$P(PSBPARAM(0),"^",5)="M":"MKEY") Q
.I $P(PSBDAT,U,6)=0 S PSBSCTYP=$S($P(PSBPARAM(0),"^",5)="W":"WUAS",$P(PSBPARAM(0),"^",5)="M":"MUAS")
;
FILESF ; File event.
D VAL^PSBML(53.77,"+1,",.01,PSB7A)
D VAL^PSBML(53.77,"+1,",.02,"`"_PSBDFN)
D VAL^PSBML(53.77,"+1,",.03,PSB2)
D VAL^PSBML(53.77,"+1,",.04,PSB5A)
D VAL^PSBML(53.77,"+1,",.05,PSBSCTYP)
D VAL^PSBML(53.77,"+1,",.06,PSB3)
D VAL^PSBML(53.77,"+1,",.07,$S($G(XMZ)]"":"`"_XMZ,1:""))
D VAL^PSBML(53.77,"+1,",.08,PSBXON)
D VAL^PSBML(53.77,"+1,",.09,PSB6)
D:$G(PSBFILE)=50
.D VAL^PSBML(53.771,"+2,+1,",.01,"`"_PSBMEDOI)
.D VAL^PSBML(53.771,"+2,+1,",1,PSBMEDNM)
D:$G(PSBFILE)=52.6
.D VAL^PSBML(53.7711,"+2,+1,",.01,"`"_PSBMEDOI)
.D VAL^PSBML(53.7711,"+2,+1,",1,PSBMEDNM)
D:$G(PSBFILE)=52.7
.D VAL^PSBML(53.7712,"+2,+1,",.01,"`"_PSBMEDOI)
.D VAL^PSBML(53.7712,"+2,+1,",1,PSBMEDNM)
I $G(PSBFILE)="ID" D VAL^PSBML(53.77,"+1,",14,PSBOIT),VAL^PSBML(53.77,"+1,",15,PSBOITX)
I $D(PSBSFUID) D VAL^PSBML(53.77,"+1,",13,PSBSFUID)
I $G(PSBFILE)="ID" D VAL^PSBML(53.77,"+1,",13,$S(PSBMEDOI']"":"WS",1:PSBMEDOI))
D UPDATE^DIE("","PSBFDA","PSBNEW1","PSBMSG")
I $D(PSBMSG("DIERR")) S RESULTS(0)=2,RESULTS(1)="-1^MSF Filing ERROR! "_PSBMSG("DIERR","1","TEXT",1) Q
S RESULTS(0)=1,RESULTS(1)="1^Unable to Scan documentation successful!"
Q
;
CLEANMSF ;
; Clean-up
K PSBNEW1,PSB1,PSB2,PSB3,PSB4,PSB5,PSB6,PSB7,PSB8,XMZ
Q
;
SCANCNT(PSBTYP) ;
; Routine to count total scans (NO MAIL)
; Input: PSBTYP - "WSCN"/"MSCN"/"MMME"/"MKEY"/"WKEY"
D CLEAN^DILF
N PSBNEW1
S PSBNEW1="+1"
D VAL^PSBML(53.77,"+1,",.01,"`"_".5")
D VAL^PSBML(53.77,"+1,",.05,PSBTYP)
D UPDATE^DIE("","PSBFDA","PSBNEW1","PSBMSG")
I $D(PSBNEW1(1)) S DIK="^PSB(53.77,",DA=PSBNEW1(1) D ^DIK
I $D(PSBMSG("DIERR")) S RESULTS(0)=2,RESULTS(1)="-1^MSF Filing ERROR! "_PSBMSG("DIERR","1","TEXT",1) Q
S RESULTS(0)=1,RESULTS(1)="1^Unable to Scan documentation successful!"
Q
;
PSBVDLU3 ;BIRMINGHAM/TEJ-BCMA VDL UTILITIES 3 ; 27 Aug 2008 9:06 PM
+1 ;;3.0;BAR CODE MED ADMIN;**13,38,28,50**;Mar 2004;Build 78
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ;This routine file has been created to serve as a container
+5 ;for Extrinsic Variables/Functions
+6 ;
+7 ; Reference/IA
+8 ; EN^PSJBCMA/2828
+9 ; EN^PSJBCMA1/2829
+10 ; File 50/221
+11 ; File 52.6/436
+12 ; File 52.7/437
+13 ;
IVPTAB(PSBORTYP,PSBIVTYP,PSBINTSY,PSBCHMTY,PSBPUSH) ;
+1 ;
+2 ; This function will return
+3 ; the value 1 (one) if the
+4 ; specified order input will cause
+5 ; the order to display on the "IVP/IVPB"
+6 ; tab of the VDL BCMA Virtual Due List (VDL)
+7 ; else return the value 0 (zero).
+8 ;
+9 ; Input Parameters:
+10 ;
+11 ; PSBORTYP - Order type (e.g. "U","V")
+12 ; PSBIVTYP - IV Type (e.g. "P","S","C")
+13 ; PSBINTSY - Intermittent Syringe value
+14 ; PSBCHMTY - Chemo type (e.g. "P","S")
+15 ; PSBPUSH - IV PUSH Flag (e.g. 0 or 1, 1=IV PUSH)
+16 ;
+17 ; Output:
+18 ; 1 - order will display on the "IVP/IVPB" Tab of BCMA VDL
+19 ; 0 - order will NOT display on the "IVP/IVPB" Tab of BCMA VDL
+20 ; -1 - error processed
+21 ;
+22 IF '$DATA(PSBORTYP)
QUIT "-1^Missing Parameter"
+23 IF PSBORTYP="U"&(PSBPUSH)
QUIT 1
+24 IF '(PSBORTYP="V")
QUIT 0
+25 IF $GET(PSBIVTYP)="P"
QUIT 1
+26 IF $GET(PSBIVTYP)="S"
IF $GET(PSBINTSY)=1
QUIT 1
+27 IF $GET(PSBIVTYP)="C"
IF $GET(PSBCHMTY)="P"
QUIT 1
+28 IF $GET(PSBIVTYP)="C"
IF $GET(PSBCHMTY)="S"
IF $GET(PSBINTSY)=1
QUIT 1
+29 QUIT 0
+30 ;
SHOVDL(DFN,BDATE,OTDATE,PSBTAB) ;
+1 ;
+2 ; This function will find orders such as discontinued or expired infusing IV bags
+3 ; or discontinued or expired "given" patches. Recognizing these types of orders
+4 ; will allow these orders to be displayed on the VDL and permits the user to take
+5 ; action on them. This routine determines if such orders exist for patient,
+6 ; time, and "BCMA VDL tab." This routine is an "extention" to the API EN^PSJBCMA.
+7 ;
+8 ; INPUT Parameters:
+9 ; DFN (req) Patient Internal File Number.
+10 ; BDATE (opt) Start searching for "order stop" after this date.
+11 ; OTDATE (opt) Include One-Time orders from this date.
+12 ; PSBTAB (opt) "UDTAB" or "IVTAB" - expedites process if specific tab
+13 ; is given.
+14 ;
+15 ; OUTPUT Values
+16 ; 0 absolutely no orders to display on VDL
+17 ; 1 displayable orders have been located.
+18 ;
+19 ;
+20 DO EN^PSJBCMA(DFN,$GET(BDATE),$GET(OTDATE))
+21 ; any active Patch orders to show on VDL?
+22 SET PSBFLG=0
+23 IF $GET(^TMP("PSJ",$JOB,1,0))=-1
Begin DoDot:1
+24 ;
+25 ; Check the indexice for given patches or infusing IVs
+26 ;
+27 ; Check APATCH
+28 IF ($GET(PSBTAB)="UDTAB")!($GET(PSBTAB)="")
Begin DoDot:2
+29 SET PSBGNODE="^PSB(53.79,"_"""APATCH"""_","_DFN_")"
IF '$DATA(PSBGNODE)
QUIT
+30 FOR
SET PSBGNODE=$QUERY(@PSBGNODE)
IF PSBGNODE=""
QUIT
IF $QSUBSCRIPT(PSBGNODE,3)'=DFN
QUIT
IF PSBFLG
QUIT
SET PSBIEN=$QSUBSCRIPT(PSBGNODE,5)
SET PSBFLG=$SELECT($PIECE(^PSB(53.79,PSBIEN,0),U,9)="G":1,1:0)
End DoDot:2
IF PSBFLG
QUIT
+31 ;
+32 ; Check AUID
+33 ;
+34 IF (($GET(PSBTAB)="IVTAB")!($GET(PSBTAB)=""))&('PSBFLG)
Begin DoDot:2
+35 SET PSBGNODE="^PSB(53.79,"_"""AUID"""_","_DFN_")"
IF '$DATA(PSBGNODE)
QUIT
+36 FOR
SET PSBGNODE=$QUERY(@PSBGNODE)
IF PSBGNODE=""
QUIT
IF $QSUBSCRIPT(PSBGNODE,3)'=DFN
QUIT
IF PSBFLG
QUIT
SET PSBIEN=$QSUBSCRIPT(PSBGNODE,6)
SET PSBFLG=$SELECT($PIECE(^PSB(53.79,PSBIEN,0),U,9)="I":1,1:0)
End DoDot:2
IF PSBFLG
QUIT
+37 ;
+38 ; NOTE: Infusing bags will not display if DCed more than 3 days ago!
+39 ;
End DoDot:1
+40 IF $GET(^TMP("PSJ",$JOB,1,0))'=-1
SET PSBFLG=1
+41 ;
+42 QUIT PSBFLG
+43 ;
FNDACTV(RESULTS,PARAMS) ; Utility to check and order for the latest " ? (parameter #3) " order activities per patient (parameter #1)
+1 ; #parameter= # "^"piece
+2 ; #1 DFN - Patient's IEN e.g. 1234 (required)
+3 ; #2 Order Number_Order Type e.g. "1V" "" = all orders
+4 ; #3 Search for Activity e.g "" = *unknown* activity
+5 ; #4 Search "back"time(hours) e.g. 12 "" = search back 3 admins
+6 ; NOTE: ="FREQ" This Function will use order's frequency.
+7 ; 1. If the order is a PRN, On Call or One-Time
+8 ; the look back a default of 72 hours.
+9 ; 2. if the order is a Continuous order key off
+10 ; of the frequency as follows.
+11 ; a.) if the frequency is <24 hours use the
+12 ; default of 72 hours.
+13 ; b.) if the frequency is >= 24 hour, look back
+14 ; 3.5 times the frequency
+15 ; NOTE: ["X#" This Function will search back # of admins.
+16 ;
+17 ; Example call: D FNDACTV^PSBVDLU3(.TEJ,"1234^1U^H^12")
+18 ;
+19 NEW PSBNOW,PSBDFN,PSBON,PSBCNT,PSBACT,PSBTMFRM,PSBX,PSBSET,PSBFRQ
+20 KILL RESULTS
+21 SET PSBDFN=$PIECE(PARAMS,U)
SET PSBON=$PIECE(PARAMS,U,2)
SET PSBACT=$PIECE(PARAMS,U,3)
SET PSBTMFRM=$PIECE(PARAMS,U,4)
+22 SET RESULTS(0)=1
+23 IF $GET(PSBDFN)']""
SET RESULTS(0)=1
SET RESULTS(1)="-1^ERROR - MISSING PARAMETER (DFN REQ.)"
QUIT
+24 IF $GET(PSBTMFRM)=""
SET PSBX=3
+25 IF $GET(PSBTMFRM)["X"
SET PSBX=+($PIECE(PSBTMFRM,"X",2))
SET PSBTMFRM=""
+26 IF $GET(PSBTMFRM)]""
IF $GET(PSBTMFRM)'["FREQ"
DO NOW^%DTC
SET PSBNOW=%
SET PSBTMFRM=$$FMADD^XLFDT(PSBNOW,"",-1*PSBTMFRM)
SET PSBSET=1
SET RESULTS(1)="0^ None found after "_PSBTMFRM
+27 IF $GET(PSBX)=""
SET PSBX=9999999
+28 IF $GET(PSBON)'=""
Begin DoDot:1
+29 KILL ^TMP("PSJ",$JOB)
DO EN^PSJBCMA1(PSBDFN,PSBON)
+30 ;Maintain Time Frame and other order information
+31 IF $GET(PSBTMFRM)["FREQ"
Begin DoDot:2
+32 SET PSBFRQ=+$PIECE(^TMP("PSJ",$JOB,4),"^",11)
IF PSBFRQ=0
SET PSBFRQ=1440
+33 IF "P^OC^O^"[($PIECE(^TMP("PSJ",$JOB,4),"^")_"^")
SET PSBTMFRM=72
QUIT
+34 IF (PSBFRQ/60)<24
SET PSBTMFRM=72
QUIT
+35 IF (PSBFRQ/60)'<24
SET PSBTMFRM=(PSBFRQ/60)*3.5
End DoDot:2
+36 IF '$GET(PSBSET)
DO NOW^%DTC
SET PSBNOW=%
SET PSBTMFRM=$$FMADD^XLFDT(PSBNOW,"",-1*PSBTMFRM)
SET RESULTS(1)="0^ None found after "_PSBTMFRM
+37 SET I=""
SET X=0
FOR
SET I=$ORDER(^PSB(53.79,"AORDX",PSBDFN,PSBON,I),-1)
IF (I="")!(I<$SELECT(PSBTMFRM]""
QUIT
Begin DoDot:2
+38 SET Z=0
SET J=""
SET PSBCNT=0
FOR
SET J=$ORDER(^PSB(53.79,"AORDX",PSBDFN,PSBON,I,J),-1)
IF (J="")
QUIT
SET Z=Z+1
IF Z>PSBX
QUIT
Begin DoDot:3
+39 LOCK +^PSB(53.79,J):DILOCKTM
+40 IF $TEST
LOCK -^PSB(53.79,J)
+41 IF '$TEST
QUIT
+42 IF ($PIECE(^PSB(53.79,J,0),U,9)=PSBACT)
SET X=1
Begin DoDot:4
+43 SET PSBCNT=PSBCNT+1
SET RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.02)
+44 SET PSBCNT=PSBCNT+1
SET RESULTS(PSBCNT)=$PIECE(^TMP("PSJ",$JOB,2),U,2)_"^"_($$GET1^DIQ(53.79,J_",",.11))
+45 SET PSBCNT=PSBCNT+1
SET RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.06,"I")
+46 SET PSBCNT=PSBCNT+1
SET RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.13,"I")
End DoDot:4
End DoDot:3
IF X
QUIT
End DoDot:2
IF X
QUIT
End DoDot:1
+47 IF $GET(PSBON)=""
Begin DoDot:1
+48 SET Z=""
SET X=0
FOR
SET Z=$ORDER(^PSB(53.79,"AORDX",PSBDFN,Z),-1)
IF (Z="")
QUIT
SET PSBON=Z
Begin DoDot:2
+49 ;Maintain Time Frame and other order information
+50 KILL ^TMP("PSJ",$JOB)
DO EN^PSJBCMA1(PSBDFN,PSBON)
+51 IF $GET(PSBTMFRM)["FREQ"
Begin DoDot:3
+52 SET PSBFRQ=+$PIECE(^TMP("PSJ",$JOB,4),"^",11)
IF PSBFRQ=0
SET PSBFRQ=1440
+53 IF "P^OC^O^"[($PIECE(^TMP("PSJ",$JOB,4),"^")_"^")
SET PSBTMFRM=72
QUIT
+54 IF (PSBFRQ/60)<24
SET PSBTMFRM=72
QUIT
+55 IF (PSBFRQ/60)'<24
SET PSBTMFRM=(PSBFRQ/60)*3.5
End DoDot:3
+56 IF '$GET(PSBSET)
DO NOW^%DTC
SET PSBNOW=%
SET PSBTMFRM=$$FMADD^XLFDT(PSBNOW,"",-1*PSBTMFRM)
SET RESULTS(1)="0^ None found after "_PSBTMFRM
+57 SET I=""
FOR
SET I=$ORDER(^PSB(53.79,"AORDX",PSBDFN,PSBON,I),-1)
IF (I="")!(I<$SELECT(PSBTMFRM]""
QUIT
Begin DoDot:3
+58 SET ZZ=0
SET J=""
SET PSBCNT=0
FOR
SET J=$ORDER(^PSB(53.79,"AORDX",PSBDFN,PSBON,I,J),-1)
IF (J="")
QUIT
SET ZZ=ZZ+1
IF ZZ>PSBX
QUIT
Begin DoDot:4
+59 LOCK +^PSB(53.79,J):DILOCKTM
+60 IF $TEST
LOCK -^PSB(53.79,J)
+61 IF '$TEST
QUIT
+62 IF ($PIECE(^PSB(53.79,J,0),U,9)=PSBACT)
SET X=1
Begin DoDot:5
+63 SET PSBCNT=PSBCNT+1
SET RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.02)
+64 SET PSBCNT=PSBCNT+1
SET RESULTS(PSBCNT)=$PIECE(^TMP("PSJ",$JOB,2),U,2)_"^"_($$GET1^DIQ(53.79,J_",",.11))
+65 SET PSBCNT=PSBCNT+1
SET RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.06,"I")
+66 SET PSBCNT=PSBCNT+1
SET RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.13,"I")
End DoDot:5
End DoDot:4
IF X
QUIT
End DoDot:3
IF X
QUIT
End DoDot:2
IF X
QUIT
End DoDot:1
+67 IF $GET(PSBCNT)>0
SET RESULTS(0)=PSBCNT
+68 KILL ^TMP("PSJ",$JOB)
+69 QUIT
+70 ;
SCANFAIL(RESULTS,PSBPARAM) ; TEJ 05/12/2006 BCMA-Managing Scanning Failures (MSF)
+1 ; Document Unable to Scan Event
+2 ; Parameters:
+3 ; Input (via GUI):
+4 ;
+5 ; Per Wristband (0) - Pat IEN ^ ^ Reason Unable to Scan ^ User's Comment ^ "W" ^ 1 (keyed entry) or 2 (scanner)
+6 ; Per Medication (0) - Pat IEN ^ Order Number ^ Reason Unable to Scan ^ User's Comment ^ "M" ^ 1 (keyed entry) or 2 (scanner)
+7 ; (1) - tag^ unique identifier
+8 ; Output:
+9 ; Entry into database ^PSB(53.77)
+10 ; Electronic Mail - Message Data per Unable to Scan Event
+11 ; PSB1 - Patient IEN
+12 ; PSB2 - Ward Location/Room
+13 ; PSB3 - Reason
+14 ; PSB4 - Type of Scan Issue
+15 ; PSB5 - Event date/item
+16 ; PSB6 - User's Comment
+17 ; PSB7 - User identification
+18 ; PSB8 - Order Number
+19 ; RESULTS(0)=1
+20 ; RESULTS(1)= 1 (Success) or -1 (Nonsuccess)
+21 ;
+22 KILL RESULTS,PSBSFUID,PSBMEDOI,PSBMEDNM
+23 SET RESULTS(0)=1
SET RESULTS(1)="-1^Unable to Scan documentation NOT successful!"
+24 NEW PSBDAT,PSBDAT1,PSBXON,PSBSCHAD
+25 SET PSBDAT=PSBPARAM(0)
IF $DATA(PSBPARAM(1))
SET PSBDAT1=PSBPARAM(1)
+26 SET PSBXON=$PIECE(PSBDAT,"^",2)
+27 SET PSB8=$GET(PSBXON)
+28 SET (PSB1,PSBDFN)=$PIECE(PSBDAT,"^")
+29 ;
+30 ; Changed the ward+room delimiter from / to $.
+31 SET PSB2=" *UNIDENTIFIABLE PATIENT* "
IF +$GET(PSB1)>0
SET PSB2=$$GET1^DIQ(2,PSB1_",",.1)_"$"_$$GET1^DIQ(2,PSB1_",",.101)
+32 SET PSB3=$PIECE(PSBDAT,"^",3)
IF PSB3="Manual Medication Entry"
SET PSBMMEN=1
+33 SET PSB4=$SELECT($PIECE(PSBDAT,"^",5)="W":"Wristband",$PIECE(PSBDAT,"^",5)="M":"Medication",1:" *UNDEFINED* ")
+34 IF PSB4="Medication"&($DATA(PSBDAT1))
Begin DoDot:1
+35 ; Determine DD/ADD/SOL
+36 SET PSBMEDOI=$PIECE(PSBDAT1,"^",2)
+37 SET PSBFILE=$PIECE(PSBDAT1,"^")
SET PSBFILE=$SELECT(PSBFILE="DD":50,PSBFILE="ADD":52.6,PSBFILE="SOL":52.7,1:PSBFILE)
+38 IF PSBFILE'="ID"
SET PSBMEDNM=$$GET1^DIQ(PSBFILE,PSBMEDOI_",",.01)
+39 KILL PSBSFUID
IF PSBFILE="ID"
IF (PSBMEDOI]"")
SET PSBSFUID=PSBMEDOI
End DoDot:1
+40 DO NOW^%DTC
SET (Y,PSB5A)=%
DO DD^%DT
SET PSB5=Y
+41 SET PSB6=$PIECE(PSBDAT,"^",4)
+42 SET PSB7=". *UNDEFINED* "
IF $GET(DUZ)>0
SET PSB7=$$GET1^DIQ(200,DUZ_",",.01)
SET PSB7A="`"_DUZ
+43 ; Send message.
+44 IF $GET(PSBMMEN)'=1
IF $PIECE(PSBDAT,U,6)'=1
IF $PIECE(PSBDAT,U,6)'=2
DO MSFMSG^PSBMLU(PSB1,PSB2,PSB3,PSB4,PSB5,PSB6,PSB7,PSB8,.RESULTS)
+45 IF RESULTS(0)=-1
SET RESULTS(0)=1
SET RESULTS(1)="-1^Unable to Scan MAILGROUP NOT SETUP!"
QUIT
+46 ;File data
+47 DO CLEAN^DILF
+48 NEW PSBNEW1
+49 SET PSBNEW1="+1"
+50 Begin DoDot:1
+51 IF $GET(PSBMMEN)=1
SET PSBSCTYP="MMME"
QUIT
+52 IF $PIECE(PSBDAT,U,6)=2
SET PSBSCTYP=$SELECT($PIECE(PSBPARAM(0),"^",5)="W":"WSCN",$PIECE(PSBPARAM(0),"^",5)="M":"MSCN")
QUIT
+53 IF $PIECE(PSBDAT,U,6)=1
SET PSBSCTYP=$SELECT($PIECE(PSBPARAM(0),"^",5)="W":"WKEY",$PIECE(PSBPARAM(0),"^",5)="M":"MKEY")
QUIT
+54 IF $PIECE(PSBDAT,U,6)=0
SET PSBSCTYP=$SELECT($PIECE(PSBPARAM(0),"^",5)="W":"WUAS",$PIECE(PSBPARAM(0),"^",5)="M":"MUAS")
End DoDot:1
+55 ;
FILESF ; File event.
+1 DO VAL^PSBML(53.77,"+1,",.01,PSB7A)
+2 DO VAL^PSBML(53.77,"+1,",.02,"`"_PSBDFN)
+3 DO VAL^PSBML(53.77,"+1,",.03,PSB2)
+4 DO VAL^PSBML(53.77,"+1,",.04,PSB5A)
+5 DO VAL^PSBML(53.77,"+1,",.05,PSBSCTYP)
+6 DO VAL^PSBML(53.77,"+1,",.06,PSB3)
+7 DO VAL^PSBML(53.77,"+1,",.07,$SELECT($GET(XMZ)]"":"`"_XMZ,1:""))
+8 DO VAL^PSBML(53.77,"+1,",.08,PSBXON)
+9 DO VAL^PSBML(53.77,"+1,",.09,PSB6)
+10 IF $GET(PSBFILE)=50
Begin DoDot:1
+11 DO VAL^PSBML(53.771,"+2,+1,",.01,"`"_PSBMEDOI)
+12 DO VAL^PSBML(53.771,"+2,+1,",1,PSBMEDNM)
End DoDot:1
+13 IF $GET(PSBFILE)=52.6
Begin DoDot:1
+14 DO VAL^PSBML(53.7711,"+2,+1,",.01,"`"_PSBMEDOI)
+15 DO VAL^PSBML(53.7711,"+2,+1,",1,PSBMEDNM)
End DoDot:1
+16 IF $GET(PSBFILE)=52.7
Begin DoDot:1
+17 DO VAL^PSBML(53.7712,"+2,+1,",.01,"`"_PSBMEDOI)
+18 DO VAL^PSBML(53.7712,"+2,+1,",1,PSBMEDNM)
End DoDot:1
+19 IF $GET(PSBFILE)="ID"
DO VAL^PSBML(53.77,"+1,",14,PSBOIT)
DO VAL^PSBML(53.77,"+1,",15,PSBOITX)
+20 IF $DATA(PSBSFUID)
DO VAL^PSBML(53.77,"+1,",13,PSBSFUID)
+21 IF $GET(PSBFILE)="ID"
DO VAL^PSBML(53.77,"+1,",13,$SELECT(PSBMEDOI']"":"WS",1:PSBMEDOI))
+22 DO UPDATE^DIE("","PSBFDA","PSBNEW1","PSBMSG")
+23 IF $DATA(PSBMSG("DIERR"))
SET RESULTS(0)=2
SET RESULTS(1)="-1^MSF Filing ERROR! "_PSBMSG("DIERR","1","TEXT",1)
QUIT
+24 SET RESULTS(0)=1
SET RESULTS(1)="1^Unable to Scan documentation successful!"
+25 QUIT
+26 ;
CLEANMSF ;
+1 ; Clean-up
+2 KILL PSBNEW1,PSB1,PSB2,PSB3,PSB4,PSB5,PSB6,PSB7,PSB8,XMZ
+3 QUIT
+4 ;
SCANCNT(PSBTYP) ;
+1 ; Routine to count total scans (NO MAIL)
+2 ; Input: PSBTYP - "WSCN"/"MSCN"/"MMME"/"MKEY"/"WKEY"
+3 DO CLEAN^DILF
+4 NEW PSBNEW1
+5 SET PSBNEW1="+1"
+6 DO VAL^PSBML(53.77,"+1,",.01,"`"_".5")
+7 DO VAL^PSBML(53.77,"+1,",.05,PSBTYP)
+8 DO UPDATE^DIE("","PSBFDA","PSBNEW1","PSBMSG")
+9 IF $DATA(PSBNEW1(1))
SET DIK="^PSB(53.77,"
SET DA=PSBNEW1(1)
DO ^DIK
+10 IF $DATA(PSBMSG("DIERR"))
SET RESULTS(0)=2
SET RESULTS(1)="-1^MSF Filing ERROR! "_PSBMSG("DIERR","1","TEXT",1)
QUIT
+11 SET RESULTS(0)=1
SET RESULTS(1)="1^Unable to Scan documentation successful!"
+12 QUIT
+13 ;
