PSBUTL ;BIRMINGHAM/EFC-BCMA UTILITIES ;03/06/16 3:06pm
;;3.0;BAR CODE MED ADMIN;**3,9,13,38,45,46,63,83,97,99,104,114**;Mar 2004;Build 3
;Per VA Directive 6402, this routine should not be modified.
;
; Reference/IA
; $$PATCH & $$VERSION^XPDUTL/10141
; File 50/221
; File 200/10060
; EN^PSJBCMA1/2829
;
;*83 - Add tags called by DD trigger xrefs
; - Add FIXADM to add to coversheet Results the G give action.
;
DIWP(X,Y,PSB,PSBARGN) ;
K ^UTILITY($J,"W")
S DIWL=0,DIWR=Y,DIWF="C"_Y D ^DIWP
F X=0:0 S X=$O(^UTILITY($J,"W",0,X)) Q:'X D
.S Y=$O(@PSB@(""),-1)+1
.; Naked Ref ^UTILITY($J,"W",0,X)
.S @PSB@(Y)=$J("",+$G(PSBARGN))_^(X,0)
S @PSB@(0)=+$O(@PSB@(""),-1)
K ^UTILITY($J,"W"),DIWL,DIWR,DIWF
Q
;
SATURDAY(X,PSBDISP) ;
S X=X\1 D H^%DTC ; Convert to $H
S %H=%H+(6-%Y) ; Set it forward to Saturday
D YMD^%DTC ; Back to FM Format
I $G(PSBDISP) S PSBDISP=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)) D EN^DDIOL("Actual date is Saturday "_PSBDISP)
Q X
;
SUNDAY(X,PSBDISP) ;
S X=X\1 D H^%DTC ; Convert to $H
S %H=%H-%Y ; Set it back to Sunday
D YMD^%DTC ; Back to FM Format
I $G(PSBDISP) S PSBDISP=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)) D EN^DDIOL("Actual date is Sunday "_PSBDISP)
Q X
;
CLOCK(RESULTS,X) ; Verify Client/Server Date/Times are close enough
;
; RPC: PSB SERVER CLOCK VARIANCE
;
; Description:
; Returns variance from server to client in minutes
;
N PSBCLNT,PSBSRVR,PSBDIFF,PSBMDNT
S PSBMDNT=0
I $P(X,"@",2)="0000" S $P(X,"@",2)="2400",PSBMDNT=1 ;Change Delphi time for midnight from 0000 to 2400 in PSB*3.0*63
S %DT="RS" D ^%DT S PSBCLNT=Y
D NOW^%DTC S PSBSRVR=%
S:$G(PSBMDNT) PSBCLNT=$$FMADD^XLFDT(PSBCLNT,-1,0,0,0) ;Change Delphi date for midnight from day following midnight to day previous to midnight in PSB*3.0*63
S PSBDIFF=$$DIFF(PSBSRVR,PSBCLNT)
S X=$$GET^XPAR("DIV","PSB SERVER CLOCK VARIANCE")
I PSBDIFF>X!(PSBDIFF<(X*-1)) S RESULTS(0)="-1^"_PSBDIFF
E S RESULTS(0)="1^"_PSBDIFF
Q
;
DIFF(X,X1) ; Difference in minutes between 2 FM dates
; Code copied from Fileman Function MINUTES
S Y=$E(X1_"000",9,10)-$E(X_"000",9,10)*60+$E(X1_"00000",11,12)-$E(X_"00000",11,12),X2=X,X=$P(X,".",1)'=$P(X1,".",1) D ^%DTC:X S X=X*1440+Y
Q X
;
DRUGINQ ; Drug File Inquiry
N PSBRET,PSBIEN,DIC,DIR,IOINORM,IOINHI
S X="IOINHI;IOINORM" D ENDR^%ZISS
S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
S DIC="^PSDRUG(",DIC(0)="AEQMVTN",DIC("T")="",D="B^C^VAPN^VAC^NDC^XATC",DIC("A")="Select DRUG: "
; Display active drugs and those for appl packages IV and Unit Dose
S DIC("S")="I '$G(^PSDRUG(+Y,""I""))!($G(^(""I""))>DT),$P($G(^PSDRUG(+Y,2)),U,3)[""I""!($P($G(^PSDRUG(+Y,2)),U,3)[""U"")"
F W @IOF,!,"DRUG FILE INQUIRY",! D ^DIC Q:+Y<1 D
.K PSBRET
.S PSBIEN=+Y_","
.D GETS^DIQ(50,PSBIEN,".01;16;25;51;215;213;101;9*","","PSBRET")
.W @IOF,!,"DRUG NAME: ",IOINHI,PSBRET(50,PSBIEN,.01)
.W " (IEN: ",+PSBIEN,")",IOINORM,!,$TR($J("",IOM)," ","-"),!
.F X=16,25,51,215,213,101 D
..D FIELD^DID(50,X,"","LABEL","PSBRET")
..W !,PSBRET("LABEL"),":",?30,IOINHI
..D:$L(PSBRET(50,PSBIEN,X))>49
...F Y=1:1 Q:$L($P(PSBRET(50,PSBIEN,X)," ",1,Y))>49
...W $P(PSBRET(50,PSBIEN,X)," ",1,Y-1),!?30
...S PSBRET(50,PSBIEN,X)=$P(PSBRET(50,PSBIEN,X)," ",Y,250)
..W ?30,PSBRET(50,PSBIEN,X),IOINORM
.W !!,"SYNONYMS:",IOINHI,!?15
.S X="" F S X=$O(PSBRET(50.1,X)) Q:X="" W:$X>40 !?15 W:$X>15 ?40 W PSBRET(50.1,X,.01)
.W IOINORM
.F Q:$Y>(IOSL-3) W !
.S DIR(0)="E" D ^DIR
Q
;
DPTSET ; Set Logic for pt-merge x-ref on patient field in file 53.79
;
; Entered Date/Time
I $P(^PSB(53.79,DA,0),U,4) S ^PSB(53.79,"AEDT",X,$P(^PSB(53.79,DA,0),U,4),DA)=""
;
; Administration Date/Time
D:$P(^PSB(53.79,DA,0),U,6)
.S ^PSB(53.79,"AADT",X,$P(^PSB(53.79,DA,0),U,6),DA)=""
.;
.; Orderable Item + Administration Date/Time
.I $P(^PSB(53.79,DA,0),U,8) S ^PSB(53.79,"AOIP",X,$P(^PSB(53.79,DA,0),U,8),$P(^PSB(53.79,DA,0),U,6),DA)=""
;
; PRN's by entered date/time
I $P($G(^PSB(53.79,DA,.1)),U,2)="P"&($P(^(0),U,4)) S ^PSB(53.79,"APRN",X,$P(^PSB(53.79,DA,0),U,4),DA)=""
;
; Order+Administration Date and Time
I $P($G(^PSB(53.79,DA,.1)),U)]""&($P($G(^PSB(53.79,DA,.1)),U,3)) S ^PSB(53.79,"AORD",X,$P(^PSB(53.79,DA,.1),U),$P(^PSB(53.79,DA,.1),U,3),DA)=""
Q
;
DPTKILL ; Kill Logic for pt-merge x-ref on patient field in file 53.79
;
; Entered Date/Time
I $P(^PSB(53.79,DA,0),U,4) K ^PSB(53.79,"AEDT",X,$P(^PSB(53.79,DA,0),U,4),DA)
;
; Administration Date/Time
D:$P(^PSB(53.79,DA,0),U,6)
.K ^PSB(53.79,"AADT",X,$P(^PSB(53.79,DA,0),U,6),DA)
.;
.; Orderable Item + Administration Date/Time
.I $P(^PSB(53.79,DA,0),U,8) K ^PSB(53.79,"AOIP",X,$P(^PSB(53.79,DA,0),U,8),$P(^PSB(53.79,DA,0),U,6),DA)
;
; PRN's by entered date/time
I $P($G(^PSB(53.79,DA,.1)),U,2)="P"&($P(^(0),U,4)) K ^PSB(53.79,"APRN",X,$P(^PSB(53.79,DA,0),U,4),DA)
;
; Order+Administration Date and Time
I $P($G(^PSB(53.79,DA,.1)),U)]""&($P($G(^PSB(53.79,DA,.1)),U,3)) K ^PSB(53.79,"AORD",X,$P(^PSB(53.79,DA,.1),U),$P(^PSB(53.79,DA,.1),U,3),DA)
Q
;
TIMEIN ;
X ^%ZOSF("UPPERCASE") S X=Y
I X="NOON" S X=.12 Q
I X="MID" S X=.24 Q
I (X="NOW")!(X="N") D NOW^%DTC S X=$E($P(%,".",2)_"0000",1,4)
S X="T@"_X,%DT="R" D ^%DT
I Y<1 K X Q
S X=Y-DT
Q
;
TIMEOUT(X) ;
N HOUR,MIN,AMPM
S X=$E($P(X,".",2)_"0000",1,4)
I X="2400" Q "12:00m"
I X="1200" Q "12:00n"
S HOUR=+$E(X,1,2),MIN=$E(X,3,4)
S AMPM="a"
S AMPM=$S(HOUR<12:"a",HOUR>11:"p",1:"**")
S:HOUR>12 HOUR=HOUR-12
Q HOUR_":"_MIN_AMPM
;
HFSOPEN(HANDLE) ;
N PSBDIR,PSBFILE
S PSBDIR=$$DEFDIR^%ZISH()
S PSBFILE="PSB"_DUZ_".DAT"
D OPEN^%ZISH(HANDLE,PSBDIR,PSBFILE,"W") Q:POP
S IOM=132,IOSL=99999,IOST="P-DUMMY",IOF=""""""
Q
;
HFSCLOSE(HANDLE) ;
N PSBDIR,PSBFILE,PSBDEL
D CLOSE^%ZISH(HANDLE)
K ^TMP("PSBO",$J)
S PSBDIR=$$DEFDIR^%ZISH()
S PSBFILE="PSB"_DUZ_".DAT",PSBDEL(PSBFILE)=""
S X=$$FTG^%ZISH(PSBDIR,PSBFILE,$NAME(^TMP("PSBO",$J,2)),3)
S X=$$DEL^%ZISH(PSBDIR,$NA(PSBDEL))
Q
;
AUDIT(PSBREC,PSBDD,PSBFLD,PSBDATA,PSBSK) ; Med Log Audit
; used by cross references to 53.79 to track changes to fields in Med Log file
; xref AU05, AU06, AU09, AU16, AU21, AU22 pass the value 53.79 as PSBDD
; xref AU303, AU304 pass the value 53.795 as PSBDD
; xref AU603, AU604 pass the value 53.796 as PSBDD
; xref AU703, AU704 pass the value 53.797 as PSBDD
;
N PSBDT,PSBTMP
I '$D(PSBOLSTS) S PSBOLSTS=$P(^PSB(53.79,PSBREC,0),U,9)
I '$D(PSBOLDUZ) S PSBOLDUZ=$P(^PSB(53.79,PSBREC,0),U,5)
Q:$G(PSBDATA)=""!('$G(PSBAUDIT))
D NOW^%DTC S PSBDT=%
S PSBDATA=$$EXTERNAL^DILFD(PSBDD,PSBFLD,"",PSBDATA) ; PSBDD=53.79, 53.795, 53.796, or 53.797 see comment AUDIT
D FIELD^DID(PSBDD,PSBFLD,"","LABEL","PSBTMP") ; PSBDD=53.79, 53.795, 53.796, or 53.797 see comment AUDIT
S:'$D(^PSB(53.79,PSBREC,.9,0)) ^(0)="^53.799^^"
S Y=$O(^PSB(53.79,PSBREC,.9,""),-1)+1,X=""
I PSBTMP("LABEL")["ACTION STATUS" D Q
.I PSBSK["K" S XY=Y F S XY=$O(^PSB(53.79,PSBREC,.9,XY),-1) Q:($D(PSBGOON))!(+XY'>0) D
..I ^PSB(53.79,PSBREC,.9,XY,0)["ACTION STATUS Set to '" D Q
...S PSBGOON=1,PSBOLDUZ=$P(^PSB(53.79,PSBREC,.9,XY,0),U,2),X=$P(^PSB(53.79,PSBREC,.9,XY,0),"'",2)
.S:$L(X)'>2 X=PSBOLSTS,X=$S(X="G":"GIVEN",X="H":"HELD",X="R":"REFUSED",X="I":"INFUSING",X="C":"COMPLETED",X="S":"STOPPED",X="N":"NOT GIVEN",X="RM":"REMOVED",X="M":"MISSING DOSE",X="":PSBOLSTS)
.I PSBSK["K" S ^PSB(53.79,PSBREC,.9,Y,0)=PSBDT_U_DUZ_U_"Field: "_PSBTMP("LABEL")_" '"_PSBDATA_"' by '"_$$GET1^DIQ(200,PSBOLDUZ,"INITIAL")_"' deleted."
.;PSB*3*45 Store Action status and last given fields.
.E S ^PSB(53.79,PSBREC,.9,Y,0)=PSBDT_U_DUZ_U_"Field: "_PSBTMP("LABEL")_" Set to '"_PSBDATA_"' by '"_$$GET1^DIQ(200,DUZ,"INITIAL")_"'."_U_PSBDATA_U_$P(^PSB(53.79,PSBREC,0),"^",7)
I PSBSK["K" S ^PSB(53.79,PSBREC,.9,Y,0)=PSBDT_U_DUZ_U_"Field: "_PSBTMP("LABEL")_" '"_PSBDATA_"' deleted."
E S ^PSB(53.79,PSBREC,.9,Y,0)=PSBDT_U_DUZ_U_"Field: "_PSBTMP("LABEL")_$S(PSBTMP("LABEL")["DISPENSE DRUG":" Added '",1:" Set to '")_PSBDATA_"'."
K XY,PSBGOON
Q
;
CHECK(RESULTS,PSBWHAT,PSBDATA) ; Checks for KIDS Patch or Build
; Module added in Patch PSB*1.0*3 DP/TOPEKA 22-DEC-1999 11:51:22
; PSBWHAT: B = Returns Build Version for packages by Namespace
; P = Returns if Patch is installed
; PSBDATA: Build/Package namespace (i.e. PSB) or Patch Number
; (i.e. PSB*1.0*1)
;
S RESULTS(0)="-1^Unknown Parameter "_$G(PSBWHAT,"<PSBWHAT Undefined>")
S PSBWHAT=$G(PSBWHAT),PSBDATA=$G(PSBDATA)
D:PSBWHAT="B"
.S X=$$VERSION^XPDUTL(PSBDATA)
.S RESULTS(0)=$S(X="":"-1^Unknown Package/Build",1:"1^"_X)
D:PSBWHAT="P"
.S X=$$PATCH^XPDUTL(PSBDATA)
.S RESULTS(0)=$S(X:"1^Patch Is Installed",1:"-1^Patch Is Not Installed")
Q
;
VERSION() ; [Extrinsic]
; Returns V#.# for display purposes
Q "V"_$J(2,0,1)
;
RESETADM ;
;
; This Subroutine will reset a medication order's resources
; based on Med Log New Entry or Edit Med Log activity.
;
; No input is necessary. Environment should be setup at call.
;
Q:'$O(^PSB(53.79,0)) ;Quit if there are no BCMA entries, PSB*3*99
I '$G(PSBMMEN) S X=$S($P(PSBIEN,",",2)]"":$P(PSBIEN,",",2),1:+PSBIEN) D CLEAN^PSBVT,PSJ1^PSBVT($P(^PSB(53.79,X,0),U),$P(^PSB(53.79,X,.1),U)) D:($$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,+$G(PSBIVPSH))) D CLEAN^PSBVT
.S X=PSBIEN,X2=X_$S(X="+1":",",1:"") Q:'$D(PSBFDA(53.79,X2,.09)) I $F("HR",PSBFDA(53.79,X2,.09))>1 S PSBFDA(53.79,X2,.26)=""
I $G(PSBMMEN),PSBIEN="+1",$G(PSBONX)["V" S PSBWSID=PSBFDA(53.79,"+1,",.26) K PSBFDA(53.79,"+1,",.26),PSBFDA(53.79,"+1,",.09)
I $G(PSBMMEN) I ($D(PSBWSID))&($G(Y(0))="SAVE") D
.S:(PSBREC(3)="G") PSBFDAX(53.79,X,.26)=PSBWSID
.S:$F("HR",PSBREC(3))>1 PSBFDAX(53.79,X,.26)=""
.S X=$P(PSBIEN,"+1,",2)
.D UPDATE^DIE("","PSBFDAX","X","PSBMSG")
Q
;
SCRNPTCH ;
;
; Maintain the "APATCH" index from SCREENMAN and Manual Med Entry.
;
I Y(0)'="GIVEN" S PSBGPTCH=0 Q
S PSBX=0 F S PSBX=$O(^PSB(53.79,DA,.5,PSBX)) Q:+PSBX=0 Q:$P(^PSB(53.79,DA,.5,+PSBX,0),U,4)="PATCH"
Q:+PSBX=0
S PSBGPTCH=1
Q
;
GIVEPTCH ;
I $D(^PSB(53.79,"AORD",DFN,PSBONX)) N PSBX S PSBX="" F S PSBX=$O(^PSB(53.79,"AORD",DFN,PSBONX,PSBX)) Q:+PSBX=0 D:$D(^PSB(53.79,"AORD",DFN,PSBONX,PSBX,DA)) Q:'$D(PSBX)
.I $D(^PSB(53.79,"AORD",DFN,PSBONX,PSBX,DA)) D
..S PSBX=$P(^PSB(53.79,DA,0),U,6)
..I PSBGPTCH S ^PSB(53.79,"APATCH",DFN,PSBX,DA)="" K PSBX,PSBGPTCH Q
..I 'PSBGPTCH K ^PSB(53.79,"APATCH",DFN,PSBX,DA),PSBX,PSBGPTCH
Q
;
VALGIV() ;Validate Give, variance time set during a Trigger call *83
Q:'$P($G(^PSB(53.79,DA,0)),U,6) 0
Q ($P($G(^PSB(53.79,DA,.1)),U,2)="C"&($P($G(^(.1)),U,3)]"")&($G(PSBACTN)="G"))
;
VALREM() ;Validate Remove, variance time set during a Trigger call *83
Q:'$P($G(^PSB(53.79,DA,0)),U,6) 0
Q ($P($G(^PSB(53.79,DA,.1)),U,2)="C"&($P($G(^(.1)),U,7)]"")&($G(PSBACTN)="RM"))
;
REMSTR(A,D,TY,SP,PRSP) ;build remove time string from admin time string via DOA value *83
; A = admin time strg e.g. "0900-2100"
; D = Duration of Admin (DOA)
; TY = sched type
; SP = order stop date
; PRSP = previous stop date
;
N RMTM,RMSTR,Q
S RMSTR="",TY=$G(TY),SP=$G(SP),PRSP=$G(PRSP)
;
;no admin time, return null RMSTR
Q:(TY'="O")&('A) RMSTR
;
;sched typ is One Time, return Ord stop time as RMSTR
I TY="O" D Q RMSTR
.S RMSTR=$S(PRSP:PRSP,1:SP),RMSTR=$E($P(RMSTR,".",2)_"0000",1,4)
;
;continuous schedules with valid admin times
F Q=1:1:$L(A,"-") D
.S RMTM=DT_"."_$P(A,"-",Q)
.S RMTM=$$FMADD^XLFDT(RMTM,,,D)
.S RMTM=$P(RMTM,".",2),RMTM=$E(RMTM_"0000",1,4)
.S $P(RMSTR,"-",Q)=RMTM
Q RMSTR
;
CNVRT4(STR,SEP) ;Converts a time string to 4 digit for consistency *83
; STR - string of times
; SEP - separator character between times
;
N QQ
F QQ=1:1:$L(STR,SEP) S $P(STR,SEP,QQ)=$E($P(STR,SEP,QQ)_"0000",1,4)
Q STR
;
FINDGIVE(IEN) ;Finds the last Give date/time in the Audit log for a RM sts *83
; When a Remove action occurs and saved to 53.79, the Give Action
; Status & Action Date/Time are overwritten. This Function will
; retrieve that Give info.
;
; Function returns - string formatted as the MAH report uses:
;
; date/time^by initials^action code^IEN of #53.79^IEN of user #200
;
Q:$P(^PSB(53.79,IEN,0),U,9)'="RM" ""
N DA,DAT,GIVE,FOUND,STR,QQ,PRVDA,PRVDAT,SKIP
S (FOUND,STR,GIVE)=""
F DA=99999:0 S DA=$O(^PSB(53.79,IEN,.9,DA),-1) Q:'DA D Q:FOUND
.S DAT=^PSB(53.79,IEN,.9,DA,0),SKIP=0
.; check for previous audit to be an Undo RM, if so skip it
.I DAT["ACTION STATUS Set to 'GIVEN'" D Q
..S PRVDA=$O(^PSB(53.79,IEN,.9,DA),-1) ;previous audit DA
..D:PRVDA
...S PRVDAT=^PSB(53.79,IEN,.9,PRVDA,0)
...I PRVDAT["ACTION STATUS 'REMOVED'",PRVDAT["deleted" S SKIP=1
..Q:SKIP
..S $P(STR,U,1)=$P(DAT,U,1) ;init date just in case
..S $P(STR,U,2)=$P(DAT,"'",4) ;by initials
..S $P(STR,U,3)="G" ;action sts Give
..S $P(STR,U,4)=IEN ;ien of transaction
..S $P(STR,U,5)=$P(DAT,U,2) ;ien of user file 200
..S GIVE=1
.Q:SKIP
.;
.;preferred date of action is in external form, as manual med edits
.;can be back dated and show up here vs audit date/time for the Give
.D:GIVE
..Q:DAT'["DATE/TIME Set to"
..S:DAT?.E1"@".E $P(STR,U,1)=$$ETFM($P(^(0),"'",2))
..;found real date
..S FOUND=1
Q STR
;
ETFM(EX) ;convert external to FM date format
N M,MM,MTH,TM,DY,Y,Y1,Y2,YYY,YYYY,Q
S MTH=$E(EX,1,3)
S Q=0
F M="JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP","OCT","NOV","DEC" S Q=Q+.01,MM(M)=Q
S MM=$E($P(MM(MTH),".",2)_"0",1,2)
;
S DY=$P(EX," ",2),DY=$TR(DY,",","")
S Y=$P(EX," ",3),YYYY=$P(Y,"@"),Y1=$E(YYYY,1,2)-17,Y2=$E(YYYY,3,4),YYYY=Y1_Y2
S TM=$P(Y,"@",2),TM=$TR(TM,":","")
Q $E(YYYY_MM_DY_"."_TM,1,12)
;
MEDHIST(LIST,DFN,OI,MAX) ;Last nn admin actions per a patients Orderable Item
;
; Reference/IA
; #6271 for Inpatient Medications to call into BCMA *83
; ** NOTE **
; THIS API IS DIRECTLY/INDIRECTLY DEPENDANT ON 3 OTHER INTERNAL
; API's: LASTSITE^PSBINJEC, RPC^PSBVDLUD, & FINDGIVE^PSBUTL
;
; Input:
; DFN - Patient num
; OI - Inpatient Meds Orderable Item ien
; MAX - Max days back to search
; Output:
; LIST - Array of actions formatted as :
; DATE^ACTION^ORDNO^LSTSITE^LOCATION^NURSINITL
;
K LIST
N DTE,CNT,IEN,ACTN,GIVE,DATE,LSITE,ACTBY,NURINI,ORDN,LOC
;
S DTE=DT+1
F S DTE=$O(^PSB(53.79,"AOIP",DFN,OI,DTE),-1) Q:'DTE D Q:$$FMDIFF^XLFDT($$NOW^XLFDT,DTE,1)>MAX
.S IEN=0
.F S IEN=$O(^PSB(53.79,"AOIP",DFN,OI,DTE,IEN)) Q:'IEN D Q:$$FMDIFF^XLFDT($$NOW^XLFDT,DTE,1)>MAX
..S ACTN=$$GET1^DIQ(53.79,IEN,.09)
..S ORDN=$$GET1^DIQ(53.79,IEN,.11)
..S LOC=$$GET1^DIQ(53.79,IEN,.02)
..S ACTBY=$$GET1^DIQ(53.79,IEN,.07,"I")
..S NURINI=$$GET1^DIQ(200,ACTBY,1)
..Q:ACTN="NOT GIVEN"
..Q:$$FMDIFF^XLFDT($$NOW^XLFDT,DTE,1)>MAX
..S LSITE=$$LASTSITE^PSBINJEC(DFN,OI)
..S LIST(DTE)=DTE_U_ACTN_U_ORDN_U_LSITE_U_LOC_U_NURINI
..I ACTN="REMOVED" D
...S GIVE=$$FINDGIVE(IEN)
...S DATE=$P(GIVE,U)
...S NURINI=$P(GIVE,U,2)
...Q:$$FMDIFF^XLFDT($$NOW^XLFDT,DATE,1)>MAX
...S LIST(DATE)=DATE_U_"GIVEN"_U_ORDN_U_LSITE_U_LOC_U_NURINI
Q
;
FIXADM ;Update ORD seg with GIVE status based on ALL ADM Records *83
; If any ADM's contain G then remove required for this ORDER
N QQ,MRR,ADSTS,ADIEN,OIEN,RMTM
S MRR=0,ADSTS=""
F QQ=1:1:+$G(^TMP("PSB",$J,"CVRSHT",0)) D
.Q:$E(^TMP("PSB",$J,"CVRSHT",QQ),1,3)="END"
.I $E(^TMP("PSB",$J,"CVRSHT",QQ),1,3)="ORD" S OIEN=QQ,MRR=0 Q
.I $E(^TMP("PSB",$J,"CVRSHT",QQ),1,2)="DD" D
..S MRR=$P(^TMP("PSB",$J,"CVRSHT",QQ),U,8)
.;only update sts in ORD.14 if G found for any med
.I $E(^TMP("PSB",$J,"CVRSHT",QQ),1,3)="ADM" D Q:ADSTS="G"
..S ADSTS=$P(^TMP("PSB",$J,"CVRSHT",QQ),U,5)
..S ADIEN=$P(^TMP("PSB",$J,"CVRSHT",QQ),U,4)
..S:ADIEN RMTM=$P(^PSB(53.79,ADIEN,.1),U,7)
..;if a Give & MRR med, then the Remove time needs to be retrieved
..;again from 53.79. The last info found by PSBVDLUD may not be for
..;this medlog record.
..D:ADSTS="G"&MRR
...S $P(^TMP("PSB",$J,"CVRSHT",OIEN),U,14)=ADSTS
...S $P(^TMP("PSB",$J,"CVRSHT",OIEN),U,36)=RMTM
Q
;
REMOVES(DFN,TYPE) ;Searches xrefs for MRR type meds needing removal and adds *83
;
;Type = (P)atient, (W)ard, (C)linic
;
N PSBGNODE,PSBIEN,PSBZON,PSBRMDT,PSBMRRFL,PSBONX,PSBOITX,PSBOSP,PSBOSTS,DSPDRG
;
;Xref APATCH search (backwards compatible xref)
S PSBGNODE="^PSB(53.79,"_"""APATCH"""_","_DFN_")"
F S PSBGNODE=$Q(@PSBGNODE) Q:PSBGNODE']"" Q:($QS(PSBGNODE,2)'="APATCH")!($QS(PSBGNODE,3)'=DFN) D
.S PSBIEN=$QS(PSBGNODE,5),PSBONX=$P(^PSB(53.79,PSBIEN,.1),U),DSPDRG=$O(^PSB(53.79,PSBIEN,.5,0)) I 'DSPDRG Q
.Q:'$D(^PSB(53.79,PSBIEN,.5,DSPDRG)) ;no disp drug
.Q:$P(^PSB(53.79,PSBIEN,.5,DSPDRG,0),U,4)'="PATCH" ;not a Patch
.Q:$P(^PSB(53.79,PSBIEN,0),U,9)'="G" ;not Given
.S PSBRMDT=$P(^PSB(53.79,PSBIEN,.1),"^",7) Q:'PSBRMDT ;Scheduled Removal Time
.Q:(PSBRMDT<PSBSTART)!(PSBRMDT>PSBSTOP)
.D PSJ1^PSBVT(DFN,PSBONX)
.Q:(TYPE="C")&('PSBCLIEN) ;not a clinic order
.D SETMRR
;
;Xref AMRR search (new xref for transdermal meds)
S PSBGNODE="^PSB(53.79,"_"""AMRR"""_","_DFN_")"
F S PSBGNODE=$Q(@PSBGNODE) Q:PSBGNODE']"" Q:($QS(PSBGNODE,2)'="AMRR")!($QS(PSBGNODE,3)'=DFN) D
.S PSBIEN=$QS(PSBGNODE,5),PSBONX=$P(^PSB(53.79,PSBIEN,.1),U),DSPDRG=$O(^PSB(53.79,PSBIEN,.5,0)) I 'DSPDRG Q
.Q:$P(^PSB(53.79,PSBIEN,.5,DSPDRG,0),U,4)="PATCH" ;Is patch already seen
.Q:'$D(^PSB(53.79,PSBIEN,.5,DSPDRG)) ;no disp drug
.Q:'$P(^PSB(53.79,PSBIEN,.5,DSPDRG,0),U,6) ;no MRR flag
.Q:$P(^PSB(53.79,PSBIEN,0),U,9)'="G" ;not Given
.S PSBRMDT=$P(^PSB(53.79,PSBIEN,.1),"^",7) Q:'PSBRMDT ;Scheduled Removal Time
.Q:(PSBRMDT<PSBSTART)!(PSBRMDT>PSBSTOP)
.D PSJ1^PSBVT(DFN,PSBONX)
.Q:(TYPE="C")&('PSBCLIEN) ;not a clinic order
.D SETMRR
;
D CLEAN^PSBVT
Q
;
SETMRR ;Get and set MRR info for printing Removals
; If clinic order mode, skip removes for locations not on clinic list
; If No list then All clinics desired.
N CLNAM S CLNAM=$P(^PSB(53.79,PSBIEN,0),U,2)
I '$G(PSBIENS) N PSBIENS S PSBIENS=PSBRPT
I PSBCLINORD,$D(^PSB(53.69,+PSBIENS,2,"B")),CLNAM]"",'$D(^PSB(53.69,+PSBIENS,2,"B",CLNAM)) Q ;not on selection list when list is present
S PSBZON=$P(^PSB(53.79,PSBIEN,.1),"^")
K ^TMP("PSJ1",$J) D EN^PSJBCMA1(DFN,PSBZON,1)
Q:$G(^TMP("PSJ1",$J,0))=-1
S PSBONX=$P(^TMP("PSJ1",$J,0),U,3) ; ord num w/ type "U" or "V"
S PSBOSTS=$P(^TMP("PSJ1",$J,1),U,10) ; ord status
S PSBOITX=$P(^TMP("PSJ1",$J,2),U,2) ; order item (expanded)
S PSBOSP=$P(^TMP("PSJ1",$J,4),U,7) ; stop date FM
S ^TMP("PSB",$J,DFN,PSBRMDT,PSBOITX,PSBONX,"RM")=""
S PSBS(DFN,PSBONX,$S(PSBOSTS="A":"Active",PSBOSTS="H":"On Hold",PSBOSTS="D":"DC'd",PSBOSTS="DE":"DC'd (Edit)",PSBOSTS="E":"Expired",PSBOSTS="O":"On Call",PSBOSTS="R":"Renewed",1:"*Unknown*"))="" ;PSB*3*76 adds Renewed as status
S PSBSTXP(PSBONX,DFN,$$DTFMT^PSBOMM2(PSBOSP))=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBUTL 19323 printed Dec 13, 2024@01:41:14 Page 2
PSBUTL ;BIRMINGHAM/EFC-BCMA UTILITIES ;03/06/16 3:06pm
+1 ;;3.0;BAR CODE MED ADMIN;**3,9,13,38,45,46,63,83,97,99,104,114**;Mar 2004;Build 3
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; $$PATCH & $$VERSION^XPDUTL/10141
+6 ; File 50/221
+7 ; File 200/10060
+8 ; EN^PSJBCMA1/2829
+9 ;
+10 ;*83 - Add tags called by DD trigger xrefs
+11 ; - Add FIXADM to add to coversheet Results the G give action.
+12 ;
DIWP(X,Y,PSB,PSBARGN) ;
+1 KILL ^UTILITY($JOB,"W")
+2 SET DIWL=0
SET DIWR=Y
SET DIWF="C"_Y
DO ^DIWP
+3 FOR X=0:0
SET X=$ORDER(^UTILITY($JOB,"W",0,X))
if 'X
QUIT
Begin DoDot:1
+4 SET Y=$ORDER(@PSB@(""),-1)+1
+5 ; Naked Ref ^UTILITY($J,"W",0,X)
+6 SET @PSB@(Y)=$JUSTIFY("",+$GET(PSBARGN))_^(X,0)
End DoDot:1
+7 SET @PSB@(0)=+$ORDER(@PSB@(""),-1)
+8 KILL ^UTILITY($JOB,"W"),DIWL,DIWR,DIWF
+9 QUIT
+10 ;
SATURDAY(X,PSBDISP) ;
+1 ; Convert to $H
SET X=X\1
DO H^%DTC
+2 ; Set it forward to Saturday
SET %H=%H+(6-%Y)
+3 ; Back to FM Format
DO YMD^%DTC
+4 IF $GET(PSBDISP)
SET PSBDISP=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_(1700+$EXTRACT(X,1,3))
DO EN^DDIOL("Actual date is Saturday "_PSBDISP)
+5 QUIT X
+6 ;
SUNDAY(X,PSBDISP) ;
+1 ; Convert to $H
SET X=X\1
DO H^%DTC
+2 ; Set it back to Sunday
SET %H=%H-%Y
+3 ; Back to FM Format
DO YMD^%DTC
+4 IF $GET(PSBDISP)
SET PSBDISP=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_(1700+$EXTRACT(X,1,3))
DO EN^DDIOL("Actual date is Sunday "_PSBDISP)
+5 QUIT X
+6 ;
CLOCK(RESULTS,X) ; Verify Client/Server Date/Times are close enough
+1 ;
+2 ; RPC: PSB SERVER CLOCK VARIANCE
+3 ;
+4 ; Description:
+5 ; Returns variance from server to client in minutes
+6 ;
+7 NEW PSBCLNT,PSBSRVR,PSBDIFF,PSBMDNT
+8 SET PSBMDNT=0
+9 ;Change Delphi time for midnight from 0000 to 2400 in PSB*3.0*63
IF $PIECE(X,"@",2)="0000"
SET $PIECE(X,"@",2)="2400"
SET PSBMDNT=1
+10 SET %DT="RS"
DO ^%DT
SET PSBCLNT=Y
+11 DO NOW^%DTC
SET PSBSRVR=%
+12 ;Change Delphi date for midnight from day following midnight to day previous to midnight in PSB*3.0*63
if $GET(PSBMDNT)
SET PSBCLNT=$$FMADD^XLFDT(PSBCLNT,-1,0,0,0)
+13 SET PSBDIFF=$$DIFF(PSBSRVR,PSBCLNT)
+14 SET X=$$GET^XPAR("DIV","PSB SERVER CLOCK VARIANCE")
+15 IF PSBDIFF>X!(PSBDIFF<(X*-1))
SET RESULTS(0)="-1^"_PSBDIFF
+16 IF '$TEST
SET RESULTS(0)="1^"_PSBDIFF
+17 QUIT
+18 ;
DIFF(X,X1) ; Difference in minutes between 2 FM dates
+1 ; Code copied from Fileman Function MINUTES
+2 SET Y=$EXTRACT(X1_"000",9,10)-$EXTRACT(X_"000",9,10)*60+$EXTRACT(X1_"00000",11,12)-$EXTRACT(X_"00000",11,12)
SET X2=X
SET X=$PIECE(X,".",1)'=$PIECE(X1,".",1)
if X
DO ^%DTC
SET X=X*1440+Y
+3 QUIT X
+4 ;
DRUGINQ ; Drug File Inquiry
+1 NEW PSBRET,PSBIEN,DIC,DIR,IOINORM,IOINHI
+2 SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
+3 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+4 SET DIC="^PSDRUG("
SET DIC(0)="AEQMVTN"
SET DIC("T")=""
SET D="B^C^VAPN^VAC^NDC^XATC"
SET DIC("A")="Select DRUG: "
+5 ; Display active drugs and those for appl packages IV and Unit Dose
+6 SET DIC("S")="I '$G(^PSDRUG(+Y,""I""))!($G(^(""I""))>DT),$P($G(^PSDRUG(+Y,2)),U,3)[""I""!($P($G(^PSDRUG(+Y,2)),U,3)[""U"")"
+7 FOR
WRITE @IOF,!,"DRUG FILE INQUIRY",!
DO ^DIC
if +Y<1
QUIT
Begin DoDot:1
+8 KILL PSBRET
+9 SET PSBIEN=+Y_","
+10 DO GETS^DIQ(50,PSBIEN,".01;16;25;51;215;213;101;9*","","PSBRET")
+11 WRITE @IOF,!,"DRUG NAME: ",IOINHI,PSBRET(50,PSBIEN,.01)
+12 WRITE " (IEN: ",+PSBIEN,")",IOINORM,!,$TRANSLATE($JUSTIFY("",IOM)," ","-"),!
+13 FOR X=16,25,51,215,213,101
Begin DoDot:2
+14 DO FIELD^DID(50,X,"","LABEL","PSBRET")
+15 WRITE !,PSBRET("LABEL"),":",?30,IOINHI
+16 if $LENGTH(PSBRET(50,PSBIEN,X))>49
Begin DoDot:3
+17 FOR Y=1:1
if $LENGTH($PIECE(PSBRET(50,PSBIEN,X)," ",1,Y))>49
QUIT
+18 WRITE $PIECE(PSBRET(50,PSBIEN,X)," ",1,Y-1),!?30
+19 SET PSBRET(50,PSBIEN,X)=$PIECE(PSBRET(50,PSBIEN,X)," ",Y,250)
End DoDot:3
+20 WRITE ?30,PSBRET(50,PSBIEN,X),IOINORM
End DoDot:2
+21 WRITE !!,"SYNONYMS:",IOINHI,!?15
+22 SET X=""
FOR
SET X=$ORDER(PSBRET(50.1,X))
if X=""
QUIT
if $X>40
WRITE !?15
if $X>15
WRITE ?40
WRITE PSBRET(50.1,X,.01)
+23 WRITE IOINORM
+24 FOR
if $Y>(IOSL-3)
QUIT
WRITE !
+25 SET DIR(0)="E"
DO ^DIR
End DoDot:1
+26 QUIT
+27 ;
DPTSET ; Set Logic for pt-merge x-ref on patient field in file 53.79
+1 ;
+2 ; Entered Date/Time
+3 IF $PIECE(^PSB(53.79,DA,0),U,4)
SET ^PSB(53.79,"AEDT",X,$PIECE(^PSB(53.79,DA,0),U,4),DA)=""
+4 ;
+5 ; Administration Date/Time
+6 if $PIECE(^PSB(53.79,DA,0),U,6)
Begin DoDot:1
+7 SET ^PSB(53.79,"AADT",X,$PIECE(^PSB(53.79,DA,0),U,6),DA)=""
+8 ;
+9 ; Orderable Item + Administration Date/Time
+10 IF $PIECE(^PSB(53.79,DA,0),U,8)
SET ^PSB(53.79,"AOIP",X,$PIECE(^PSB(53.79,DA,0),U,8),$PIECE(^PSB(53.79,DA,0),U,6),DA)=""
End DoDot:1
+11 ;
+12 ; PRN's by entered date/time
+13 IF $PIECE($GET(^PSB(53.79,DA,.1)),U,2)="P"&($PIECE(^(0),U,4))
SET ^PSB(53.79,"APRN",X,$PIECE(^PSB(53.79,DA,0),U,4),DA)=""
+14 ;
+15 ; Order+Administration Date and Time
+16 IF $PIECE($GET(^PSB(53.79,DA,.1)),U)]""&($PIECE($GET(^PSB(53.79,DA,.1)),U,3))
SET ^PSB(53.79,"AORD",X,$PIECE(^PSB(53.79,DA,.1),U),$PIECE(^PSB(53.79,DA,.1),U,3),DA)=""
+17 QUIT
+18 ;
DPTKILL ; Kill Logic for pt-merge x-ref on patient field in file 53.79
+1 ;
+2 ; Entered Date/Time
+3 IF $PIECE(^PSB(53.79,DA,0),U,4)
KILL ^PSB(53.79,"AEDT",X,$PIECE(^PSB(53.79,DA,0),U,4),DA)
+4 ;
+5 ; Administration Date/Time
+6 if $PIECE(^PSB(53.79,DA,0),U,6)
Begin DoDot:1
+7 KILL ^PSB(53.79,"AADT",X,$PIECE(^PSB(53.79,DA,0),U,6),DA)
+8 ;
+9 ; Orderable Item + Administration Date/Time
+10 IF $PIECE(^PSB(53.79,DA,0),U,8)
KILL ^PSB(53.79,"AOIP",X,$PIECE(^PSB(53.79,DA,0),U,8),$PIECE(^PSB(53.79,DA,0),U,6),DA)
End DoDot:1
+11 ;
+12 ; PRN's by entered date/time
+13 IF $PIECE($GET(^PSB(53.79,DA,.1)),U,2)="P"&($PIECE(^(0),U,4))
KILL ^PSB(53.79,"APRN",X,$PIECE(^PSB(53.79,DA,0),U,4),DA)
+14 ;
+15 ; Order+Administration Date and Time
+16 IF $PIECE($GET(^PSB(53.79,DA,.1)),U)]""&($PIECE($GET(^PSB(53.79,DA,.1)),U,3))
KILL ^PSB(53.79,"AORD",X,$PIECE(^PSB(53.79,DA,.1),U),$PIECE(^PSB(53.79,DA,.1),U,3),DA)
+17 QUIT
+18 ;
TIMEIN ;
+1 XECUTE ^%ZOSF("UPPERCASE")
SET X=Y
+2 IF X="NOON"
SET X=.12
QUIT
+3 IF X="MID"
SET X=.24
QUIT
+4 IF (X="NOW")!(X="N")
DO NOW^%DTC
SET X=$EXTRACT($PIECE(%,".",2)_"0000",1,4)
+5 SET X="T@"_X
SET %DT="R"
DO ^%DT
+6 IF Y<1
KILL X
QUIT
+7 SET X=Y-DT
+8 QUIT
+9 ;
TIMEOUT(X) ;
+1 NEW HOUR,MIN,AMPM
+2 SET X=$EXTRACT($PIECE(X,".",2)_"0000",1,4)
+3 IF X="2400"
QUIT "12:00m"
+4 IF X="1200"
QUIT "12:00n"
+5 SET HOUR=+$EXTRACT(X,1,2)
SET MIN=$EXTRACT(X,3,4)
+6 SET AMPM="a"
+7 SET AMPM=$SELECT(HOUR<12:"a",HOUR>11:"p",1:"**")
+8 if HOUR>12
SET HOUR=HOUR-12
+9 QUIT HOUR_":"_MIN_AMPM
+10 ;
HFSOPEN(HANDLE) ;
+1 NEW PSBDIR,PSBFILE
+2 SET PSBDIR=$$DEFDIR^%ZISH()
+3 SET PSBFILE="PSB"_DUZ_".DAT"
+4 DO OPEN^%ZISH(HANDLE,PSBDIR,PSBFILE,"W")
if POP
QUIT
+5 SET IOM=132
SET IOSL=99999
SET IOST="P-DUMMY"
SET IOF=""""""
+6 QUIT
+7 ;
HFSCLOSE(HANDLE) ;
+1 NEW PSBDIR,PSBFILE,PSBDEL
+2 DO CLOSE^%ZISH(HANDLE)
+3 KILL ^TMP("PSBO",$JOB)
+4 SET PSBDIR=$$DEFDIR^%ZISH()
+5 SET PSBFILE="PSB"_DUZ_".DAT"
SET PSBDEL(PSBFILE)=""
+6 SET X=$$FTG^%ZISH(PSBDIR,PSBFILE,$NAME(^TMP("PSBO",$JOB,2)),3)
+7 SET X=$$DEL^%ZISH(PSBDIR,$NAME(PSBDEL))
+8 QUIT
+9 ;
AUDIT(PSBREC,PSBDD,PSBFLD,PSBDATA,PSBSK) ; Med Log Audit
+1 ; used by cross references to 53.79 to track changes to fields in Med Log file
+2 ; xref AU05, AU06, AU09, AU16, AU21, AU22 pass the value 53.79 as PSBDD
+3 ; xref AU303, AU304 pass the value 53.795 as PSBDD
+4 ; xref AU603, AU604 pass the value 53.796 as PSBDD
+5 ; xref AU703, AU704 pass the value 53.797 as PSBDD
+6 ;
+7 NEW PSBDT,PSBTMP
+8 IF '$DATA(PSBOLSTS)
SET PSBOLSTS=$PIECE(^PSB(53.79,PSBREC,0),U,9)
+9 IF '$DATA(PSBOLDUZ)
SET PSBOLDUZ=$PIECE(^PSB(53.79,PSBREC,0),U,5)
+10 if $GET(PSBDATA)=""!('$GET(PSBAUDIT))
QUIT
+11 DO NOW^%DTC
SET PSBDT=%
+12 ; PSBDD=53.79, 53.795, 53.796, or 53.797 see comment AUDIT
SET PSBDATA=$$EXTERNAL^DILFD(PSBDD,PSBFLD,"",PSBDATA)
+13 ; PSBDD=53.79, 53.795, 53.796, or 53.797 see comment AUDIT
DO FIELD^DID(PSBDD,PSBFLD,"","LABEL","PSBTMP")
+14 if '$DATA(^PSB(53.79,PSBREC,.9,0))
SET ^(0)="^53.799^^"
+15 SET Y=$ORDER(^PSB(53.79,PSBREC,.9,""),-1)+1
SET X=""
+16 IF PSBTMP("LABEL")["ACTION STATUS"
Begin DoDot:1
+17 IF PSBSK["K"
SET XY=Y
FOR
SET XY=$ORDER(^PSB(53.79,PSBREC,.9,XY),-1)
if ($DATA(PSBGOON))!(+XY'>0)
QUIT
Begin DoDot:2
+18 IF ^PSB(53.79,PSBREC,.9,XY,0)["ACTION STATUS Set to '"
Begin DoDot:3
+19 SET PSBGOON=1
SET PSBOLDUZ=$PIECE(^PSB(53.79,PSBREC,.9,XY,0),U,2)
SET X=$PIECE(^PSB(53.79,PSBREC,.9,XY,0),"'",2)
End DoDot:3
QUIT
End DoDot:2
+20 if $LENGTH(X)'>2
SET X=PSBOLSTS
SET X=$SELECT(X="G":"GIVEN",X="H":"HELD",X="R":"REFUSED",X="I":"INFUSING",X="C":"COMPLETED",X="S":"STOPPED",X="N":"NOT GIVEN",X="RM":"REMOVED",X="M":"MISSING DOSE",X="":PSBOLSTS)
+21 IF PSBSK["K"
SET ^PSB(53.79,PSBREC,.9,Y,0)=PSBDT_U_DUZ_U_"Field: "_PSBTMP("LABEL")_" '"_PSBDATA_"' by '"_$$GET1^DIQ(200,PSBOLDUZ,"INITIAL")_"' deleted."
+22 ;PSB*3*45 Store Action status and last given fields.
+23 IF '$TEST
SET ^PSB(53.79,PSBREC,.9,Y,0)=PSBDT_U_DUZ_U_"Field: "_PSBTMP("LABEL")_" Set to '"_PSBDATA_"' by '"_$$GET1^DIQ(200,DUZ,"INITIAL")_"'."_U_PSBDATA_U_$PIECE(^PSB(53.79,PSBREC,0),"^",7)
End DoDot:1
QUIT
+24 IF PSBSK["K"
SET ^PSB(53.79,PSBREC,.9,Y,0)=PSBDT_U_DUZ_U_"Field: "_PSBTMP("LABEL")_" '"_PSBDATA_"' deleted."
+25 IF '$TEST
SET ^PSB(53.79,PSBREC,.9,Y,0)=PSBDT_U_DUZ_U_"Field: "_PSBTMP("LABEL")_$SELECT(PSBTMP("LABEL")["DISPENSE DRUG":" Added '",1:" Set to '")_PSBDATA_"'."
+26 KILL XY,PSBGOON
+27 QUIT
+28 ;
CHECK(RESULTS,PSBWHAT,PSBDATA) ; Checks for KIDS Patch or Build
+1 ; Module added in Patch PSB*1.0*3 DP/TOPEKA 22-DEC-1999 11:51:22
+2 ; PSBWHAT: B = Returns Build Version for packages by Namespace
+3 ; P = Returns if Patch is installed
+4 ; PSBDATA: Build/Package namespace (i.e. PSB) or Patch Number
+5 ; (i.e. PSB*1.0*1)
+6 ;
+7 SET RESULTS(0)="-1^Unknown Parameter "_$GET(PSBWHAT,"<PSBWHAT Undefined>")
+8 SET PSBWHAT=$GET(PSBWHAT)
SET PSBDATA=$GET(PSBDATA)
+9 if PSBWHAT="B"
Begin DoDot:1
+10 SET X=$$VERSION^XPDUTL(PSBDATA)
+11 SET RESULTS(0)=$SELECT(X="":"-1^Unknown Package/Build",1:"1^"_X)
End DoDot:1
+12 if PSBWHAT="P"
Begin DoDot:1
+13 SET X=$$PATCH^XPDUTL(PSBDATA)
+14 SET RESULTS(0)=$SELECT(X:"1^Patch Is Installed",1:"-1^Patch Is Not Installed")
End DoDot:1
+15 QUIT
+16 ;
VERSION() ; [Extrinsic]
+1 ; Returns V#.# for display purposes
+2 QUIT "V"_$JUSTIFY(2,0,1)
+3 ;
RESETADM ;
+1 ;
+2 ; This Subroutine will reset a medication order's resources
+3 ; based on Med Log New Entry or Edit Med Log activity.
+4 ;
+5 ; No input is necessary. Environment should be setup at call.
+6 ;
+7 ;Quit if there are no BCMA entries, PSB*3*99
if '$ORDER(^PSB(53.79,0))
QUIT
+8 IF '$GET(PSBMMEN)
SET X=$SELECT($PIECE(PSBIEN,",",2)]"":$PIECE(PSBIEN,",",2),1:+PSBIEN)
DO CLEAN^PSBVT
DO PSJ1^PSBVT($PIECE(^PSB(53.79,X,0),U),$PIECE(^PSB(53.79,X,.1),U))
if ($$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,+$GET(PSBIVPSH)))
Begin DoDot:1
+9 SET X=PSBIEN
SET X2=X_$SELECT(X="+1":",",1:"")
if '$DATA(PSBFDA(53.79,X2,.09))
QUIT
IF $FIND("HR",PSBFDA(53.79,X2,.09))>1
SET PSBFDA(53.79,X2,.26)=""
End DoDot:1
DO CLEAN^PSBVT
+10 IF $GET(PSBMMEN)
IF PSBIEN="+1"
IF $GET(PSBONX)["V"
SET PSBWSID=PSBFDA(53.79,"+1,",.26)
KILL PSBFDA(53.79,"+1,",.26),PSBFDA(53.79,"+1,",.09)
+11 IF $GET(PSBMMEN)
IF ($DATA(PSBWSID))&($GET(Y(0))="SAVE")
Begin DoDot:1
+12 if (PSBREC(3)="G")
SET PSBFDAX(53.79,X,.26)=PSBWSID
+13 if $FIND("HR",PSBREC(3))>1
SET PSBFDAX(53.79,X,.26)=""
+14 SET X=$PIECE(PSBIEN,"+1,",2)
+15 DO UPDATE^DIE("","PSBFDAX","X","PSBMSG")
End DoDot:1
+16 QUIT
+17 ;
SCRNPTCH ;
+1 ;
+2 ; Maintain the "APATCH" index from SCREENMAN and Manual Med Entry.
+3 ;
+4 IF Y(0)'="GIVEN"
SET PSBGPTCH=0
QUIT
+5 SET PSBX=0
FOR
SET PSBX=$ORDER(^PSB(53.79,DA,.5,PSBX))
if +PSBX=0
QUIT
if $PIECE(^PSB(53.79,DA,.5,+PSBX,0),U,4)="PATCH"
QUIT
+6 if +PSBX=0
QUIT
+7 SET PSBGPTCH=1
+8 QUIT
+9 ;
GIVEPTCH ;
+1 IF $DATA(^PSB(53.79,"AORD",DFN,PSBONX))
NEW PSBX
SET PSBX=""
FOR
SET PSBX=$ORDER(^PSB(53.79,"AORD",DFN,PSBONX,PSBX))
if +PSBX=0
QUIT
if $DATA(^PSB(53.79,"AORD",DFN,PSBONX,PSBX,DA))
Begin DoDot:1
+2 IF $DATA(^PSB(53.79,"AORD",DFN,PSBONX,PSBX,DA))
Begin DoDot:2
+3 SET PSBX=$PIECE(^PSB(53.79,DA,0),U,6)
+4 IF PSBGPTCH
SET ^PSB(53.79,"APATCH",DFN,PSBX,DA)=""
KILL PSBX,PSBGPTCH
QUIT
+5 IF 'PSBGPTCH
KILL ^PSB(53.79,"APATCH",DFN,PSBX,DA),PSBX,PSBGPTCH
End DoDot:2
End DoDot:1
if '$DATA(PSBX)
QUIT
+6 QUIT
+7 ;
VALGIV() ;Validate Give, variance time set during a Trigger call *83
+1 if '$PIECE($GET(^PSB(53.79,DA,0)),U,6)
QUIT 0
+2 QUIT ($PIECE($GET(^PSB(53.79,DA,.1)),U,2)="C"&($PIECE($GET(^(.1)),U,3)]"")&($GET(PSBACTN)="G"))
+3 ;
VALREM() ;Validate Remove, variance time set during a Trigger call *83
+1 if '$PIECE($GET(^PSB(53.79,DA,0)),U,6)
QUIT 0
+2 QUIT ($PIECE($GET(^PSB(53.79,DA,.1)),U,2)="C"&($PIECE($GET(^(.1)),U,7)]"")&($GET(PSBACTN)="RM"))
+3 ;
REMSTR(A,D,TY,SP,PRSP) ;build remove time string from admin time string via DOA value *83
+1 ; A = admin time strg e.g. "0900-2100"
+2 ; D = Duration of Admin (DOA)
+3 ; TY = sched type
+4 ; SP = order stop date
+5 ; PRSP = previous stop date
+6 ;
+7 NEW RMTM,RMSTR,Q
+8 SET RMSTR=""
SET TY=$GET(TY)
SET SP=$GET(SP)
SET PRSP=$GET(PRSP)
+9 ;
+10 ;no admin time, return null RMSTR
+11 if (TY'="O")&('A)
QUIT RMSTR
+12 ;
+13 ;sched typ is One Time, return Ord stop time as RMSTR
+14 IF TY="O"
Begin DoDot:1
+15 SET RMSTR=$SELECT(PRSP:PRSP,1:SP)
SET RMSTR=$EXTRACT($PIECE(RMSTR,".",2)_"0000",1,4)
End DoDot:1
QUIT RMSTR
+16 ;
+17 ;continuous schedules with valid admin times
+18 FOR Q=1:1:$LENGTH(A,"-")
Begin DoDot:1
+19 SET RMTM=DT_"."_$PIECE(A,"-",Q)
+20 SET RMTM=$$FMADD^XLFDT(RMTM,,,D)
+21 SET RMTM=$PIECE(RMTM,".",2)
SET RMTM=$EXTRACT(RMTM_"0000",1,4)
+22 SET $PIECE(RMSTR,"-",Q)=RMTM
End DoDot:1
+23 QUIT RMSTR
+24 ;
CNVRT4(STR,SEP) ;Converts a time string to 4 digit for consistency *83
+1 ; STR - string of times
+2 ; SEP - separator character between times
+3 ;
+4 NEW QQ
+5 FOR QQ=1:1:$LENGTH(STR,SEP)
SET $PIECE(STR,SEP,QQ)=$EXTRACT($PIECE(STR,SEP,QQ)_"0000",1,4)
+6 QUIT STR
+7 ;
FINDGIVE(IEN) ;Finds the last Give date/time in the Audit log for a RM sts *83
+1 ; When a Remove action occurs and saved to 53.79, the Give Action
+2 ; Status & Action Date/Time are overwritten. This Function will
+3 ; retrieve that Give info.
+4 ;
+5 ; Function returns - string formatted as the MAH report uses:
+6 ;
+7 ; date/time^by initials^action code^IEN of #53.79^IEN of user #200
+8 ;
+9 if $PIECE(^PSB(53.79,IEN,0),U,9)'="RM"
QUIT ""
+10 NEW DA,DAT,GIVE,FOUND,STR,QQ,PRVDA,PRVDAT,SKIP
+11 SET (FOUND,STR,GIVE)=""
+12 FOR DA=99999:0
SET DA=$ORDER(^PSB(53.79,IEN,.9,DA),-1)
if 'DA
QUIT
Begin DoDot:1
+13 SET DAT=^PSB(53.79,IEN,.9,DA,0)
SET SKIP=0
+14 ; check for previous audit to be an Undo RM, if so skip it
+15 IF DAT["ACTION STATUS Set to 'GIVEN'"
Begin DoDot:2
+16 ;previous audit DA
SET PRVDA=$ORDER(^PSB(53.79,IEN,.9,DA),-1)
+17 if PRVDA
Begin DoDot:3
+18 SET PRVDAT=^PSB(53.79,IEN,.9,PRVDA,0)
+19 IF PRVDAT["ACTION STATUS 'REMOVED'"
IF PRVDAT["deleted"
SET SKIP=1
End DoDot:3
+20 if SKIP
QUIT
+21 ;init date just in case
SET $PIECE(STR,U,1)=$PIECE(DAT,U,1)
+22 ;by initials
SET $PIECE(STR,U,2)=$PIECE(DAT,"'",4)
+23 ;action sts Give
SET $PIECE(STR,U,3)="G"
+24 ;ien of transaction
SET $PIECE(STR,U,4)=IEN
+25 ;ien of user file 200
SET $PIECE(STR,U,5)=$PIECE(DAT,U,2)
+26 SET GIVE=1
End DoDot:2
QUIT
+27 if SKIP
QUIT
+28 ;
+29 ;preferred date of action is in external form, as manual med edits
+30 ;can be back dated and show up here vs audit date/time for the Give
+31 if GIVE
Begin DoDot:2
+32 if DAT'["DATE/TIME Set to"
QUIT
+33 if DAT?.E1"@".E
SET $PIECE(STR,U,1)=$$ETFM($PIECE(^(0),"'",2))
+34 ;found real date
+35 SET FOUND=1
End DoDot:2
End DoDot:1
if FOUND
QUIT
+36 QUIT STR
+37 ;
ETFM(EX) ;convert external to FM date format
+1 NEW M,MM,MTH,TM,DY,Y,Y1,Y2,YYY,YYYY,Q
+2 SET MTH=$EXTRACT(EX,1,3)
+3 SET Q=0
+4 FOR M="JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP","OCT","NOV","DEC"
SET Q=Q+.01
SET MM(M)=Q
+5 SET MM=$EXTRACT($PIECE(MM(MTH),".",2)_"0",1,2)
+6 ;
+7 SET DY=$PIECE(EX," ",2)
SET DY=$TRANSLATE(DY,",","")
+8 SET Y=$PIECE(EX," ",3)
SET YYYY=$PIECE(Y,"@")
SET Y1=$EXTRACT(YYYY,1,2)-17
SET Y2=$EXTRACT(YYYY,3,4)
SET YYYY=Y1_Y2
+9 SET TM=$PIECE(Y,"@",2)
SET TM=$TRANSLATE(TM,":","")
+10 QUIT $EXTRACT(YYYY_MM_DY_"."_TM,1,12)
+11 ;
MEDHIST(LIST,DFN,OI,MAX) ;Last nn admin actions per a patients Orderable Item
+1 ;
+2 ; Reference/IA
+3 ; #6271 for Inpatient Medications to call into BCMA *83
+4 ; ** NOTE **
+5 ; THIS API IS DIRECTLY/INDIRECTLY DEPENDANT ON 3 OTHER INTERNAL
+6 ; API's: LASTSITE^PSBINJEC, RPC^PSBVDLUD, & FINDGIVE^PSBUTL
+7 ;
+8 ; Input:
+9 ; DFN - Patient num
+10 ; OI - Inpatient Meds Orderable Item ien
+11 ; MAX - Max days back to search
+12 ; Output:
+13 ; LIST - Array of actions formatted as :
+14 ; DATE^ACTION^ORDNO^LSTSITE^LOCATION^NURSINITL
+15 ;
+16 KILL LIST
+17 NEW DTE,CNT,IEN,ACTN,GIVE,DATE,LSITE,ACTBY,NURINI,ORDN,LOC
+18 ;
+19 SET DTE=DT+1
+20 FOR
SET DTE=$ORDER(^PSB(53.79,"AOIP",DFN,OI,DTE),-1)
if 'DTE
QUIT
Begin DoDot:1
+21 SET IEN=0
+22 FOR
SET IEN=$ORDER(^PSB(53.79,"AOIP",DFN,OI,DTE,IEN))
if 'IEN
QUIT
Begin DoDot:2
+23 SET ACTN=$$GET1^DIQ(53.79,IEN,.09)
+24 SET ORDN=$$GET1^DIQ(53.79,IEN,.11)
+25 SET LOC=$$GET1^DIQ(53.79,IEN,.02)
+26 SET ACTBY=$$GET1^DIQ(53.79,IEN,.07,"I")
+27 SET NURINI=$$GET1^DIQ(200,ACTBY,1)
+28 if ACTN="NOT GIVEN"
QUIT
+29 if $$FMDIFF^XLFDT($$NOW^XLFDT,DTE,1)>MAX
QUIT
+30 SET LSITE=$$LASTSITE^PSBINJEC(DFN,OI)
+31 SET LIST(DTE)=DTE_U_ACTN_U_ORDN_U_LSITE_U_LOC_U_NURINI
+32 IF ACTN="REMOVED"
Begin DoDot:3
+33 SET GIVE=$$FINDGIVE(IEN)
+34 SET DATE=$PIECE(GIVE,U)
+35 SET NURINI=$PIECE(GIVE,U,2)
+36 if $$FMDIFF^XLFDT($$NOW^XLFDT,DATE,1)>MAX
QUIT
+37 SET LIST(DATE)=DATE_U_"GIVEN"_U_ORDN_U_LSITE_U_LOC_U_NURINI
End DoDot:3
End DoDot:2
if $$FMDIFF^XLFDT($$NOW^XLFDT,DTE,1)>MAX
QUIT
End DoDot:1
if $$FMDIFF^XLFDT($$NOW^XLFDT,DTE,1)>MAX
QUIT
+38 QUIT
+39 ;
FIXADM ;Update ORD seg with GIVE status based on ALL ADM Records *83
+1 ; If any ADM's contain G then remove required for this ORDER
+2 NEW QQ,MRR,ADSTS,ADIEN,OIEN,RMTM
+3 SET MRR=0
SET ADSTS=""
+4 FOR QQ=1:1:+$GET(^TMP("PSB",$JOB,"CVRSHT",0))
Begin DoDot:1
+5 if $EXTRACT(^TMP("PSB",$JOB,"CVRSHT",QQ),1,3)="END"
QUIT
+6 IF $EXTRACT(^TMP("PSB",$JOB,"CVRSHT",QQ),1,3)="ORD"
SET OIEN=QQ
SET MRR=0
QUIT
+7 IF $EXTRACT(^TMP("PSB",$JOB,"CVRSHT",QQ),1,2)="DD"
Begin DoDot:2
+8 SET MRR=$PIECE(^TMP("PSB",$JOB,"CVRSHT",QQ),U,8)
End DoDot:2
+9 ;only update sts in ORD.14 if G found for any med
+10 IF $EXTRACT(^TMP("PSB",$JOB,"CVRSHT",QQ),1,3)="ADM"
Begin DoDot:2
+11 SET ADSTS=$PIECE(^TMP("PSB",$JOB,"CVRSHT",QQ),U,5)
+12 SET ADIEN=$PIECE(^TMP("PSB",$JOB,"CVRSHT",QQ),U,4)
+13 if ADIEN
SET RMTM=$PIECE(^PSB(53.79,ADIEN,.1),U,7)
+14 ;if a Give & MRR med, then the Remove time needs to be retrieved
+15 ;again from 53.79. The last info found by PSBVDLUD may not be for
+16 ;this medlog record.
+17 if ADSTS="G"&MRR
Begin DoDot:3
+18 SET $PIECE(^TMP("PSB",$JOB,"CVRSHT",OIEN),U,14)=ADSTS
+19 SET $PIECE(^TMP("PSB",$JOB,"CVRSHT",OIEN),U,36)=RMTM
End DoDot:3
End DoDot:2
if ADSTS="G"
QUIT
End DoDot:1
+20 QUIT
+21 ;
REMOVES(DFN,TYPE) ;Searches xrefs for MRR type meds needing removal and adds *83
+1 ;
+2 ;Type = (P)atient, (W)ard, (C)linic
+3 ;
+4 NEW PSBGNODE,PSBIEN,PSBZON,PSBRMDT,PSBMRRFL,PSBONX,PSBOITX,PSBOSP,PSBOSTS,DSPDRG
+5 ;
+6 ;Xref APATCH search (backwards compatible xref)
+7 SET PSBGNODE="^PSB(53.79,"_"""APATCH"""_","_DFN_")"
+8 FOR
SET PSBGNODE=$QUERY(@PSBGNODE)
if PSBGNODE']""
QUIT
if ($QSUBSCRIPT(PSBGNODE,2)'="APATCH")!($QSUBSCRIPT(PSBGNODE,3)'=DFN)
QUIT
Begin DoDot:1
+9 SET PSBIEN=$QSUBSCRIPT(PSBGNODE,5)
SET PSBONX=$PIECE(^PSB(53.79,PSBIEN,.1),U)
SET DSPDRG=$ORDER(^PSB(53.79,PSBIEN,.5,0))
IF 'DSPDRG
QUIT
+10 ;no disp drug
if '$DATA(^PSB(53.79,PSBIEN,.5,DSPDRG))
QUIT
+11 ;not a Patch
if $PIECE(^PSB(53.79,PSBIEN,.5,DSPDRG,0),U,4)'="PATCH"
QUIT
+12 ;not Given
if $PIECE(^PSB(53.79,PSBIEN,0),U,9)'="G"
QUIT
+13 ;Scheduled Removal Time
SET PSBRMDT=$PIECE(^PSB(53.79,PSBIEN,.1),"^",7)
if 'PSBRMDT
QUIT
+14 if (PSBRMDT<PSBSTART)!(PSBRMDT>PSBSTOP)
QUIT
+15 DO PSJ1^PSBVT(DFN,PSBONX)
+16 ;not a clinic order
if (TYPE="C")&('PSBCLIEN)
QUIT
+17 DO SETMRR
End DoDot:1
+18 ;
+19 ;Xref AMRR search (new xref for transdermal meds)
+20 SET PSBGNODE="^PSB(53.79,"_"""AMRR"""_","_DFN_")"
+21 FOR
SET PSBGNODE=$QUERY(@PSBGNODE)
if PSBGNODE']""
QUIT
if ($QSUBSCRIPT(PSBGNODE,2)'="AMRR")!($QSUBSCRIPT(PSBGNODE,3)'=DFN)
QUIT
Begin DoDot:1
+22 SET PSBIEN=$QSUBSCRIPT(PSBGNODE,5)
SET PSBONX=$PIECE(^PSB(53.79,PSBIEN,.1),U)
SET DSPDRG=$ORDER(^PSB(53.79,PSBIEN,.5,0))
IF 'DSPDRG
QUIT
+23 ;Is patch already seen
if $PIECE(^PSB(53.79,PSBIEN,.5,DSPDRG,0),U,4)="PATCH"
QUIT
+24 ;no disp drug
if '$DATA(^PSB(53.79,PSBIEN,.5,DSPDRG))
QUIT
+25 ;no MRR flag
if '$PIECE(^PSB(53.79,PSBIEN,.5,DSPDRG,0),U,6)
QUIT
+26 ;not Given
if $PIECE(^PSB(53.79,PSBIEN,0),U,9)'="G"
QUIT
+27 ;Scheduled Removal Time
SET PSBRMDT=$PIECE(^PSB(53.79,PSBIEN,.1),"^",7)
if 'PSBRMDT
QUIT
+28 if (PSBRMDT<PSBSTART)!(PSBRMDT>PSBSTOP)
QUIT
+29 DO PSJ1^PSBVT(DFN,PSBONX)
+30 ;not a clinic order
if (TYPE="C")&('PSBCLIEN)
QUIT
+31 DO SETMRR
End DoDot:1
+32 ;
+33 DO CLEAN^PSBVT
+34 QUIT
+35 ;
SETMRR ;Get and set MRR info for printing Removals
+1 ; If clinic order mode, skip removes for locations not on clinic list
+2 ; If No list then All clinics desired.
+3 NEW CLNAM
SET CLNAM=$PIECE(^PSB(53.79,PSBIEN,0),U,2)
+4 IF '$GET(PSBIENS)
NEW PSBIENS
SET PSBIENS=PSBRPT
+5 ;not on selection list when list is present
IF PSBCLINORD
IF $DATA(^PSB(53.69,+PSBIENS,2,"B"))
IF CLNAM]""
IF '$DATA(^PSB(53.69,+PSBIENS,2,"B",CLNAM))
QUIT
+6 SET PSBZON=$PIECE(^PSB(53.79,PSBIEN,.1),"^")
+7 KILL ^TMP("PSJ1",$JOB)
DO EN^PSJBCMA1(DFN,PSBZON,1)
+8 if $GET(^TMP("PSJ1",$JOB,0))=-1
QUIT
+9 ; ord num w/ type "U" or "V"
SET PSBONX=$PIECE(^TMP("PSJ1",$JOB,0),U,3)
+10 ; ord status
SET PSBOSTS=$PIECE(^TMP("PSJ1",$JOB,1),U,10)
+11 ; order item (expanded)
SET PSBOITX=$PIECE(^TMP("PSJ1",$JOB,2),U,2)
+12 ; stop date FM
SET PSBOSP=$PIECE(^TMP("PSJ1",$JOB,4),U,7)
+13 SET ^TMP("PSB",$JOB,DFN,PSBRMDT,PSBOITX,PSBONX,"RM")=""
+14 ;PSB*3*76 adds Renewed as status
SET PSBS(DFN,PSBONX,$SELECT(PSBOSTS="A":"Active",PSBOSTS="H":"On Hold",PSBOSTS="D":"DC'd",PSBOSTS="DE":"DC'd (Edit)",PSBOSTS="E":"Expired",PSBOSTS="O":"On Call",PSBOSTS="R":"Renewed",1:"*Unknown*"))=""
+15 SET PSBSTXP(PSBONX,DFN,$$DTFMT^PSBOMM2(PSBOSP))=""
+16 QUIT
