PSBUTL ;BIRMINGHAM/EFC-BCMA UTILITIES ;29-May-2012 14:23;PLS
;;3.0;BAR CODE MED ADMIN;**3,9,13,38,45,46,1010,1015**;Mar 2004;Build 62
;Per VHA Directive 2004-038, this routine should not be modified.
;
; Reference/IA
; $$PATCH & $$VERSION^XPDUTL/10141
; File 50/221
; File 200/10060
;Modified - IHS/MSC/PLS - 08/24/10 - Line HFSOPEN+2
;
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
S %DT="RS" D ^%DT S PSBCLNT=Y
D NOW^%DTC S PSBSRVR=%
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("") ;IHS/MSC/PLS - 08/24/2010
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.
;
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
PSBUTL ;BIRMINGHAM/EFC-BCMA UTILITIES ;29-May-2012 14:23;PLS
+1 ;;3.0;BAR CODE MED ADMIN;**3,9,13,38,45,46,1010,1015**;Mar 2004;Build 62
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; $$PATCH & $$VERSION^XPDUTL/10141
+6 ; File 50/221
+7 ; File 200/10060
+8 ;Modified - IHS/MSC/PLS - 08/24/10 - Line HFSOPEN+2
+9 ;
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
+8 SET %DT="RS"
DO ^%DT
SET PSBCLNT=Y
+9 DO NOW^%DTC
SET PSBSRVR=%
+10 SET PSBDIFF=$$DIFF(PSBSRVR,PSBCLNT)
+11 SET X=$$GET^XPAR("DIV","PSB SERVER CLOCK VARIANCE")
+12 IF PSBDIFF>X!(PSBDIFF<(X*-1))
SET RESULTS(0)="-1^"_PSBDIFF
+13 IF '$TEST
SET RESULTS(0)="1^"_PSBDIFF
+14 QUIT
+15 ;
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 ;IHS/MSC/PLS - 08/24/2010
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 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
+8 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
+9 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)
+10 IF $GET(PSBMMEN)
IF ($DATA(PSBWSID))&($GET(Y(0))="SAVE")
Begin DoDot:1
+11 IF (PSBREC(3)="G")
SET PSBFDAX(53.79,X,.26)=PSBWSID
+12 IF $FIND("HR",PSBREC(3))>1
SET PSBFDAX(53.79,X,.26)=""
+13 SET X=$PIECE(PSBIEN,"+1,",2)
+14 DO UPDATE^DIE("","PSBFDAX","X","PSBMSG")
End DoDot:1
+15 QUIT
+16 ;
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
