PSBMLEN1 ;BIRMINGHAM/EFC-BCMA MEDICATION LOG FUNCTIONS ;Mar 2004
;;3.0;BAR CODE MED ADMIN;**3,4,9,11,13,28,50**;Mar 2004;Build 78
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; Reference/IA
; ENE^PSJBCMA4/3416
;
NEW(Y) ; Create the new entry
N PSBREC,PSB,PSBADST,PSBFREQ
S PSBMMEN=1
W @IOF D CLEAN^PSBVT,PSJ1^PSBVT(DFN,Y)
D NOW^%DTC
I PSBOSP<% D Q:%'=1
.W @IOF,$C(7)
.W !,"NOTICE: This order is NOT currently active."
.W !," Are You Sure You Want To Continue"
.S %=2 D YN^DICN
I PSBADST="" S PSBFREQ=$$GETFREQ^PSBVDLU1(DFN,PSBONX),PSBADST=$$GETADMIN^PSBVDLU1(DFN,PSBONX,PSBOST,PSBFREQ,PSBDT)
E K ^TMP("PSB",$J,"GETADMIN") S ^TMP("PSB",$J,"GETADMIN",0)=PSBADST
S PSBODSCH=0 I (PSBFREQ#1440'=0),(1440#PSBFREQ'=0) S PSBODSCH=1
W !,"Order: ",PSBONX
W !,"Medication: ",PSBOITX
W !,"Dosage: ",PSBDOSE
W !,"Schedule: ",PSBSCH
W !,"Admin Times: ",$S(PSBODSCH:"(Odd Sched.)",1:PSBADST)
I $D(^XUSEC("PSB READ ONLY",DUZ)) D Q
.W !!,"Medications CANNOT be administered while in PSB READ ONLY mode.",!! R "Press ENTER KEY to continue. ",PSBCNTNU:5
W !!,"Is this the correct Order" S %=1 D YN^DICN Q:%'=1
;
; PRN, One-Time, On Call orders
;
I PSBSCHT'="C" D
.D VAL^PSBMLVAL(.PSB,DFN,+PSBONX,$E(PSBONX,$L(PSBONX)))
.I PSBSCHT="P",($D(PSB(1))) W !!,"Brief Administration History: ",! S X=$O(PSB(" "),-1),X=$S(X>4:4,1:X) F I=1:1:X W !,?5,PSB(I)
.I $D(^XUSEC("PSB READ ONLY",DUZ)) W !,"This operation is NOT AVAILABLE in PSB READ ONLY mode.",! Q
.I ($D(^XUSEC("PSB STUDENT",DUZ))),('$D(^XUSEC("PSB INSTRUCTOR"))) W !,"This operation is NOT AVAILABLE in PSB READ ONLY mode.",! Q
.W !!,"Create an administration for this order" S %=1 D YN^DICN Q:%'=1
.I PSBSCHT="P" D Q:Y=""!(Y["^")
..K DIR S DIR(0)="FB^1:30",DIR("A")="PRN Reason (1-30 characters)"
..W !!,"NOTICE: PRN Reason is Required for ALL PRN Entries",!
..D ^DIR
..I Y=""!(Y["^") W !!,"Sorry, Reason is required, No Entry Made!" Q
..S PSBREC(6)=$P(Y,"|")
.; Build the form of dosage to CAP or TAB or null
.S:(PSBDOSEF'?1"CAP".E)&(PSBDOSEF'?1"TAB".E)&(PSBDOSEF'?1"PATCH".E) PSBDOSEF=""
.; Build the variable dose check #####-#####MG
.S PSBVARD=$S(PSBDOSE?1.5N1"-"1.5N.E:1,1:0)
.S PSBREC(0)=DFN
.S PSBREC(1)=PSBONX
.S PSBREC(2)=PSBSCHT
.S PSBREC(3)="G"
.S PSBREC(4)=PSBOIT
.S PSBREC(5)=""
.S PSBREC(7)="Entry created with 'Manual Medication Entry' option."
.S PSBREC(8)=""
.S PSBREC(9)=$S(PSBONX["U":"UDTAB",1:"PBTAB")
.S PSBINDX=10
.S X="" F S X=$O(PSBDDA(X)) Q:X="" S PSBREC(PSBINDX)=$P(PSBDDA(X),U,1,2)_U_$P(PSBDDA(X),U,4)_U_$P(PSBDDA(X),U,4)_U_PSBDOSEF,PSBINDX=PSBINDX+1
.S X="" F S X=$O(PSBADA(X)) Q:X="" S PSBREC(PSBINDX)=PSBADA(X),PSBINDX=PSBINDX+1
.S X="" F S X=$O(PSBSOLA(X)) Q:X="" S PSBREC(PSBINDX)=PSBSOLA(X),PSBINDX=PSBINDX+1
.D FILE
.I $G(DA),PSBREC(2)="O",$D(^PSB(53.79,DA)) I $P(^PSB(53.79,DA,0),U,9)="G" D ENE^PSJBCMA4(PSBREC(0),PSBREC(1))
;
; Continuous Meds
;
I PSBSCHT="C" D
.W ! S %DT="AEQ",%DT("A")="Enter the DATE the medication was administered: "
.D NOW^%DTC S %DT(0)=(-1)*X,%DT("B")="" D ^%DT K %DT(0) Q:Y<1 S PSBDTX=Y D D^DIQ
.S:PSBODSCH PSBSCTMX=$$GETADMIN^PSBVDLU1(DFN,PSBONX,PSBOST,PSBFREQ,PSBDTX)
.F PSBXX=0:1 Q:$G(^TMP("PSB",$J,"GETADMIN",PSBXX))="" D
..S X="",Y=$G(^TMP("PSB",$J,"GETADMIN",PSBXX))
..F Z=1:1:$L(Y,"-") S X=X_$S(X]"":";",1:"")_Z_":"_$P(Y,"-",Z)
.I PSBODSCH,PSBSCTMX="" D Q
..W !!,"Order "_PSBONX_" is NOT SCHEDULED for administration on that entered date."
..K DIR S DIR(0)="E^" D ^DIR
.K DIR S DIR(0)="S^"_X,DIR("A")="Select Administration Time"
.D ^DIR Q:Y<1
.S PSBDTX=+(PSBDTX_"."_Y(0))
.S Y=PSBDTX D D^DIQ
.W !!,"Create an administration for ",Y S %=1 D YN^DICN Q:%'=1
FORUM .; Build the form of dosage to CAP or TAB or null
.S PSBDOSEF=PSBDOSEF
.S:(PSBDOSEF'?1"CAP".E)&(PSBDOSEF'?1"TAB".E)&(PSBDOSEF'?1"PATCH".E) PSBDOSEF=""
.; Build the variable dose check #####-#####MG
.S PSBVARD=$S(PSBDOSE?1.5N1"-"1.5N.E:1,1:0)
.S PSBREC(0)=DFN
.S PSBREC(1)=PSBONX
.S PSBREC(2)=PSBSCHT
.S PSBREC(3)="G"
.S PSBREC(4)=PSBOIT
.S PSBREC(5)=PSBDTX
.S PSBREC(6)=""
.S PSBREC(7)="Entry created with 'Manual Medication Entry' option."
.S PSBREC(8)=""
.S PSBREC(9)=$S(PSBONX["U":"UDTAB",1:"PBTAB")
.S PSBINDX=10
.S X="" F S X=$O(PSBDDA(X)) Q:X="" S PSBREC(PSBINDX)=$P(PSBDDA(X),U,1,2)_U_$P(PSBDDA(X),U,4)_U_$P(PSBDDA(X),U,4)_U_PSBDOSEF,PSBINDX=PSBINDX+1
.S X="" F S X=$O(PSBADA(X)) Q:X="" S PSBREC(PSBINDX)=PSBADA(X),PSBINDX=PSBINDX+1
.S X="" F S X=$O(PSBSOLA(X)) Q:X="" S PSBREC(PSBINDX)=PSBSOLA(X),PSBINDX=PSBINDX+1
.D FILE
K ^TMP("PSB",$J)
Q
;
FILE ; Call the med log RPC to file it and DDS to edit it
N PSB,PSBSAVE,PSBAUDIT
D RPC^PSBML(.PSB,"+1^MEDPASS",.PSBREC)
I '$D(PSB) S PSB(0)=1,PSB(1)="-1^INCOMPLETE ENTRY^"_PSBINCX
I +PSB(1)<1 D Q
.W @IOF,!,"Error(s) Creating Med Log Entry",!
.S X=$S(PSB(0)=1:0,1:1) F S X=$O(PSB(X)) Q:X="" W !,$J($S(X=1:X,1:X-1),2),". ",$S(X=1:$P(PSB(X),"^",2),1:PSB(X))
.W !!,"No Med Log Entry Created.",!!
.K DIR S DIR(0)="E" D ^DIR
S PSBSAVE=0 S:'$G(PSBMMEN) PSBAUDIT=1
S DA=$P(PSB(1),U,3),DDSFILE=53.79,DDSPARM="C"
I $P(^PSB(53.79,DA,.1),U,1)?.N1"U" S DR="[PSB NEW UD ENTRY]"
I $P(^PSB(53.79,DA,.1),U,1)?.N1"V" S DR="[PSB NEW IV ENTRY]"
D ^DDS
L +^PSB(53.79,DA):DILOCKTM I L -^PSB(53.79,DA) I PSBSAVE'=1 D
.W !,"Incomplete Med Log Entry, Deleting...#",DA S A=^PSB(53.79,DA,0),DFN=$P(A,U,1),AADT=$P(A,U,6)
.K ^PSB(53.79,"AADT",DFN,AADT,DA) S DIK="^PSB(53.79," D ^DIK
I PSBSAVE=1 D
.I $D(DA) D:($P(^PSB(53.79,DA,0),U,9)="G")
..I $D(^PSB(53.79,DA,.5)) S PSBY=0 F S PSBY=$O(^PSB(53.79,DA,.5,PSBY)) Q:+PSBY<1 D
...I $P(^PSB(53.79,DA,.5,PSBY,0),U,4)="PATCH" D
....S (PSBYX,PSBXUIT)="" F S PSBYX=$O(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBYX),-1) Q:PSBYX="" D Q:PSBXUIT
.....S PSBYZ="" S PSBYZ=$O(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBYX,PSBYZ)) I (PSBYZ'=DA),$P(^PSB(53.79,PSBYZ,0),U,9)="G" D
......W !!,"PATCH has been GIVEN before this admin completed; Deleting Med Log Entry...#",DA,!! S A=^PSB(53.79,DA,0),DFN=$P(A,U,1),AADT=$P(A,U,6)
......K ^PSB(53.79,"AADT",DFN,AADT,DA) S DIK="^PSB(53.79," D ^DIK
......S PSBXUIT=1
....Q:PSBXUIT
....S ^PSB(53.79,"APATCH",$P(^PSB(53.79,DA,0),U),$P(^PSB(53.79,DA,0),U,6),DA)=""
.Q:(PSBIEN="+1")&('$D(PSBIEN(1)))
.Q:$G(PSBXUIT)
.S X=$S($P(PSBIEN,",",2)]"":$P(PSBIEN,",",2),PSBIEN="+1":PSBIEN(1),1:"")
.I X]"" I ($F("HR",$P(^PSB(53.79,X,0),U,9))>1) F Y=.5,.6,.7 S Z=0 F S Z=$O(^PSB(53.79,X,Y,Z)) Q:+Z=0 S $P(^PSB(53.79,X,Y,Z,0),U,3)=0
.I X]"",$G(PSBMMEN)=1 D SCANFAIL ;If Manual Med Entry was used, document "scanning failure"
Q
;
FDATE ;Check Admin Time for future date/time.
N PSBTIMX
S PSBTIMX=X D NOW^%DTC
I PSBTIMX>% W $C(7) S (DDSERROR,DDSBR)=1 D HLP^DDSUTL("Future date/time is not allowed")
Q
;
SCANFAIL ;File an MSF record
N PSBPRM,PSBRSLT,PSBX,PSBX1,PSBX2
S PSBX=^PSB(53.79,DA,0)
S PSBX1=^PSB(53.79,DA,.1)
S PSBPRM(0)=$P(PSBX,U,1)_U_$P(PSBX1,U,1)_U_"Manual Medication Entry"_U_""_U_"M"_U_1
I $P(PSBX1,U,1)["U",$P($G(^PSB(53.79,DA,.5,1,0)),U,1)]"" D
.S PSBX2="DD"_U_$P($G(^PSB(53.79,DA,.5,1,0)),U,1)
I $P(PSBX1,U,1)["V",$P($G(^PSB(53.79,DA,.6,1,0)),U,1)]"" D
.S PSBX2="ADD"_U_$P($G(^PSB(53.79,DA,.6,1,0)),U,1)
I $G(PSBX2)="",$P(PSBX1,U,1)["V",$P($G(^PSB(53.79,DA,.7,1,0)),U,1)]"" D
.S PSBX2="SOL"_U_$P($G(^PSB(53.79,DA,.7,1,0)),U,1)
I $G(PSBX2)]"" S PSBPRM(1)=PSBX2
D SCANFAIL^PSBVDLU3(.PSBRSLT,.PSBPRM)
Q
PSBMLEN1 ;BIRMINGHAM/EFC-BCMA MEDICATION LOG FUNCTIONS ;Mar 2004
+1 ;;3.0;BAR CODE MED ADMIN;**3,4,9,11,13,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 ; Reference/IA
+5 ; ENE^PSJBCMA4/3416
+6 ;
NEW(Y) ; Create the new entry
+1 NEW PSBREC,PSB,PSBADST,PSBFREQ
+2 SET PSBMMEN=1
+3 WRITE @IOF
DO CLEAN^PSBVT
DO PSJ1^PSBVT(DFN,Y)
+4 DO NOW^%DTC
+5 IF PSBOSP<%
Begin DoDot:1
+6 WRITE @IOF,$CHAR(7)
+7 WRITE !,"NOTICE: This order is NOT currently active."
+8 WRITE !," Are You Sure You Want To Continue"
+9 SET %=2
DO YN^DICN
End DoDot:1
IF %'=1
QUIT
+10 IF PSBADST=""
SET PSBFREQ=$$GETFREQ^PSBVDLU1(DFN,PSBONX)
SET PSBADST=$$GETADMIN^PSBVDLU1(DFN,PSBONX,PSBOST,PSBFREQ,PSBDT)
+11 IF '$TEST
KILL ^TMP("PSB",$JOB,"GETADMIN")
SET ^TMP("PSB",$JOB,"GETADMIN",0)=PSBADST
+12 SET PSBODSCH=0
IF (PSBFREQ#1440'=0)
IF (1440#PSBFREQ'=0)
SET PSBODSCH=1
+13 WRITE !,"Order: ",PSBONX
+14 WRITE !,"Medication: ",PSBOITX
+15 WRITE !,"Dosage: ",PSBDOSE
+16 WRITE !,"Schedule: ",PSBSCH
+17 WRITE !,"Admin Times: ",$SELECT(PSBODSCH:"(Odd Sched.)",1:PSBADST)
+18 IF $DATA(^XUSEC("PSB READ ONLY",DUZ))
Begin DoDot:1
+19 WRITE !!,"Medications CANNOT be administered while in PSB READ ONLY mode.",!!
READ "Press ENTER KEY to continue. ",PSBCNTNU:5
End DoDot:1
QUIT
+20 WRITE !!,"Is this the correct Order"
SET %=1
DO YN^DICN
IF %'=1
QUIT
+21 ;
+22 ; PRN, One-Time, On Call orders
+23 ;
+24 IF PSBSCHT'="C"
Begin DoDot:1
+25 DO VAL^PSBMLVAL(.PSB,DFN,+PSBONX,$EXTRACT(PSBONX,$LENGTH(PSBONX)))
+26 IF PSBSCHT="P"
IF ($DATA(PSB(1)))
WRITE !!,"Brief Administration History: ",!
SET X=$ORDER(PSB(" "),-1)
SET X=$SELECT(X>4:4,1:X)
FOR I=1:1:X
WRITE !,?5,PSB(I)
+27 IF $DATA(^XUSEC("PSB READ ONLY",DUZ))
WRITE !,"This operation is NOT AVAILABLE in PSB READ ONLY mode.",!
QUIT
+28 IF ($DATA(^XUSEC("PSB STUDENT",DUZ)))
IF ('$DATA(^XUSEC("PSB INSTRUCTOR")))
WRITE !,"This operation is NOT AVAILABLE in PSB READ ONLY mode.",!
QUIT
+29 WRITE !!,"Create an administration for this order"
SET %=1
DO YN^DICN
IF %'=1
QUIT
+30 IF PSBSCHT="P"
Begin DoDot:2
+31 KILL DIR
SET DIR(0)="FB^1:30"
SET DIR("A")="PRN Reason (1-30 characters)"
+32 WRITE !!,"NOTICE: PRN Reason is Required for ALL PRN Entries",!
+33 DO ^DIR
+34 IF Y=""!(Y["^")
WRITE !!,"Sorry, Reason is required, No Entry Made!"
QUIT
+35 SET PSBREC(6)=$PIECE(Y,"|")
End DoDot:2
IF Y=""!(Y["^")
QUIT
+36 ; Build the form of dosage to CAP or TAB or null
+37 IF (PSBDOSEF'?1"CAP".E)&(PSBDOSEF'?1"TAB".E)&(PSBDOSEF'?1"PATCH".E)
SET PSBDOSEF=""
+38 ; Build the variable dose check #####-#####MG
+39 SET PSBVARD=$SELECT(PSBDOSE?1.5N1"-"1.5N.E:1,1:0)
+40 SET PSBREC(0)=DFN
+41 SET PSBREC(1)=PSBONX
+42 SET PSBREC(2)=PSBSCHT
+43 SET PSBREC(3)="G"
+44 SET PSBREC(4)=PSBOIT
+45 SET PSBREC(5)=""
+46 SET PSBREC(7)="Entry created with 'Manual Medication Entry' option."
+47 SET PSBREC(8)=""
+48 SET PSBREC(9)=$SELECT(PSBONX["U":"UDTAB",1:"PBTAB")
+49 SET PSBINDX=10
+50 SET X=""
FOR
SET X=$ORDER(PSBDDA(X))
IF X=""
QUIT
SET PSBREC(PSBINDX)=$PIECE(PSBDDA(X),U,1,2)_U_$PIECE(PSBDDA(X),U,4)_U_$PIECE(PSBDDA(X),U,4)_U_PSBDOSEF
SET PSBINDX=PSBINDX+1
+51 SET X=""
FOR
SET X=$ORDER(PSBADA(X))
IF X=""
QUIT
SET PSBREC(PSBINDX)=PSBADA(X)
SET PSBINDX=PSBINDX+1
+52 SET X=""
FOR
SET X=$ORDER(PSBSOLA(X))
IF X=""
QUIT
SET PSBREC(PSBINDX)=PSBSOLA(X)
SET PSBINDX=PSBINDX+1
+53 DO FILE
+54 IF $GET(DA)
IF PSBREC(2)="O"
IF $DATA(^PSB(53.79,DA))
IF $PIECE(^PSB(53.79,DA,0),U,9)="G"
DO ENE^PSJBCMA4(PSBREC(0),PSBREC(1))
End DoDot:1
+55 ;
+56 ; Continuous Meds
+57 ;
+58 IF PSBSCHT="C"
Begin DoDot:1
+59 WRITE !
SET %DT="AEQ"
SET %DT("A")="Enter the DATE the medication was administered: "
+60 DO NOW^%DTC
SET %DT(0)=(-1)*X
SET %DT("B")=""
DO ^%DT
KILL %DT(0)
IF Y<1
QUIT
SET PSBDTX=Y
DO D^DIQ
+61 IF PSBODSCH
SET PSBSCTMX=$$GETADMIN^PSBVDLU1(DFN,PSBONX,PSBOST,PSBFREQ,PSBDTX)
+62 FOR PSBXX=0:1
IF $GET(^TMP("PSB",$JOB,"GETADMIN",PSBXX))=""
QUIT
Begin DoDot:2
+63 SET X=""
SET Y=$GET(^TMP("PSB",$JOB,"GETADMIN",PSBXX))
+64 FOR Z=1:1:$LENGTH(Y,"-")
SET X=X_$SELECT(X]"":";",1:"")_Z_":"_$PIECE(Y,"-",Z)
End DoDot:2
+65 IF PSBODSCH
IF PSBSCTMX=""
Begin DoDot:2
+66 WRITE !!,"Order "_PSBONX_" is NOT SCHEDULED for administration on that entered date."
+67 KILL DIR
SET DIR(0)="E^"
DO ^DIR
End DoDot:2
QUIT
+68 KILL DIR
SET DIR(0)="S^"_X
SET DIR("A")="Select Administration Time"
+69 DO ^DIR
IF Y<1
QUIT
+70 SET PSBDTX=+(PSBDTX_"."_Y(0))
+71 SET Y=PSBDTX
DO D^DIQ
+72 WRITE !!,"Create an administration for ",Y
SET %=1
DO YN^DICN
IF %'=1
QUIT
FORUM ; Build the form of dosage to CAP or TAB or null
+1 SET PSBDOSEF=PSBDOSEF
+2 IF (PSBDOSEF'?1"CAP".E)&(PSBDOSEF'?1"TAB".E)&(PSBDOSEF'?1"PATCH".E)
SET PSBDOSEF=""
+3 ; Build the variable dose check #####-#####MG
+4 SET PSBVARD=$SELECT(PSBDOSE?1.5N1"-"1.5N.E:1,1:0)
+5 SET PSBREC(0)=DFN
+6 SET PSBREC(1)=PSBONX
+7 SET PSBREC(2)=PSBSCHT
+8 SET PSBREC(3)="G"
+9 SET PSBREC(4)=PSBOIT
+10 SET PSBREC(5)=PSBDTX
+11 SET PSBREC(6)=""
+12 SET PSBREC(7)="Entry created with 'Manual Medication Entry' option."
+13 SET PSBREC(8)=""
+14 SET PSBREC(9)=$SELECT(PSBONX["U":"UDTAB",1:"PBTAB")
+15 SET PSBINDX=10
+16 SET X=""
FOR
SET X=$ORDER(PSBDDA(X))
IF X=""
QUIT
SET PSBREC(PSBINDX)=$PIECE(PSBDDA(X),U,1,2)_U_$PIECE(PSBDDA(X),U,4)_U_$PIECE(PSBDDA(X),U,4)_U_PSBDOSEF
SET PSBINDX=PSBINDX+1
+17 SET X=""
FOR
SET X=$ORDER(PSBADA(X))
IF X=""
QUIT
SET PSBREC(PSBINDX)=PSBADA(X)
SET PSBINDX=PSBINDX+1
+18 SET X=""
FOR
SET X=$ORDER(PSBSOLA(X))
IF X=""
QUIT
SET PSBREC(PSBINDX)=PSBSOLA(X)
SET PSBINDX=PSBINDX+1
+19 DO FILE
End DoDot:1
+20 KILL ^TMP("PSB",$JOB)
+21 QUIT
+22 ;
FILE ; Call the med log RPC to file it and DDS to edit it
+1 NEW PSB,PSBSAVE,PSBAUDIT
+2 DO RPC^PSBML(.PSB,"+1^MEDPASS",.PSBREC)
+3 IF '$DATA(PSB)
SET PSB(0)=1
SET PSB(1)="-1^INCOMPLETE ENTRY^"_PSBINCX
+4 IF +PSB(1)<1
Begin DoDot:1
+5 WRITE @IOF,!,"Error(s) Creating Med Log Entry",!
+6 SET X=$SELECT(PSB(0)=1:0,1:1)
FOR
SET X=$ORDER(PSB(X))
IF X=""
QUIT
WRITE !,$JUSTIFY($SELECT(X=1:X,1:X-1),2),". ",$SELECT(X=1:$PIECE(PSB(X),"^",2),1:PSB(X))
+7 WRITE !!,"No Med Log Entry Created.",!!
+8 KILL DIR
SET DIR(0)="E"
DO ^DIR
End DoDot:1
QUIT
+9 SET PSBSAVE=0
IF '$GET(PSBMMEN)
SET PSBAUDIT=1
+10 SET DA=$PIECE(PSB(1),U,3)
SET DDSFILE=53.79
SET DDSPARM="C"
+11 IF $PIECE(^PSB(53.79,DA,.1),U,1)?.N1"U"
SET DR="[PSB NEW UD ENTRY]"
+12 IF $PIECE(^PSB(53.79,DA,.1),U,1)?.N1"V"
SET DR="[PSB NEW IV ENTRY]"
+13 DO ^DDS
+14 LOCK +^PSB(53.79,DA):DILOCKTM
IF $TEST
LOCK -^PSB(53.79,DA)
IF PSBSAVE'=1
Begin DoDot:1
+15 WRITE !,"Incomplete Med Log Entry, Deleting...#",DA
SET A=^PSB(53.79,DA,0)
SET DFN=$PIECE(A,U,1)
SET AADT=$PIECE(A,U,6)
+16 KILL ^PSB(53.79,"AADT",DFN,AADT,DA)
SET DIK="^PSB(53.79,"
DO ^DIK
End DoDot:1
+17 IF PSBSAVE=1
Begin DoDot:1
+18 IF $DATA(DA)
IF ($PIECE(^PSB(53.79,DA,0),U,9)="G")
Begin DoDot:2
+19 IF $DATA(^PSB(53.79,DA,.5))
SET PSBY=0
FOR
SET PSBY=$ORDER(^PSB(53.79,DA,.5,PSBY))
IF +PSBY<1
QUIT
Begin DoDot:3
+20 IF $PIECE(^PSB(53.79,DA,.5,PSBY,0),U,4)="PATCH"
Begin DoDot:4
+21 SET (PSBYX,PSBXUIT)=""
FOR
SET PSBYX=$ORDER(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBYX),-1)
IF PSBYX=""
QUIT
Begin DoDot:5
+22 SET PSBYZ=""
SET PSBYZ=$ORDER(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBYX,PSBYZ))
IF (PSBYZ'=DA)
IF $PIECE(^PSB(53.79,PSBYZ,0),U,9)="G"
Begin DoDot:6
+23 WRITE !!,"PATCH has been GIVEN before this admin completed; Deleting Med Log Entry...#",DA,!!
SET A=^PSB(53.79,DA,0)
SET DFN=$PIECE(A,U,1)
SET AADT=$PIECE(A,U,6)
+24 KILL ^PSB(53.79,"AADT",DFN,AADT,DA)
SET DIK="^PSB(53.79,"
DO ^DIK
+25 SET PSBXUIT=1
End DoDot:6
End DoDot:5
IF PSBXUIT
QUIT
+26 IF PSBXUIT
QUIT
+27 SET ^PSB(53.79,"APATCH",$PIECE(^PSB(53.79,DA,0),U),$PIECE(^PSB(53.79,DA,0),U,6),DA)=""
End DoDot:4
End DoDot:3
End DoDot:2
+28 IF (PSBIEN="+1")&('$DATA(PSBIEN(1)))
QUIT
+29 IF $GET(PSBXUIT)
QUIT
+30 SET X=$SELECT($PIECE(PSBIEN,",",2)]"":$PIECE(PSBIEN,",",2),PSBIEN="+1":PSBIEN(1),1:"")
+31 IF X]""
IF ($FIND("HR",$PIECE(^PSB(53.79,X,0),U,9))>1)
FOR Y=.5,.6,.7
SET Z=0
FOR
SET Z=$ORDER(^PSB(53.79,X,Y,Z))
IF +Z=0
QUIT
SET $PIECE(^PSB(53.79,X,Y,Z,0),U,3)=0
+32 ;If Manual Med Entry was used, document "scanning failure"
IF X]""
IF $GET(PSBMMEN)=1
DO SCANFAIL
End DoDot:1
+33 QUIT
+34 ;
FDATE ;Check Admin Time for future date/time.
+1 NEW PSBTIMX
+2 SET PSBTIMX=X
DO NOW^%DTC
+3 IF PSBTIMX>%
WRITE $CHAR(7)
SET (DDSERROR,DDSBR)=1
DO HLP^DDSUTL("Future date/time is not allowed")
+4 QUIT
+5 ;
SCANFAIL ;File an MSF record
+1 NEW PSBPRM,PSBRSLT,PSBX,PSBX1,PSBX2
+2 SET PSBX=^PSB(53.79,DA,0)
+3 SET PSBX1=^PSB(53.79,DA,.1)
+4 SET PSBPRM(0)=$PIECE(PSBX,U,1)_U_$PIECE(PSBX1,U,1)_U_"Manual Medication Entry"_U_""_U_"M"_U_1
+5 IF $PIECE(PSBX1,U,1)["U"
IF $PIECE($GET(^PSB(53.79,DA,.5,1,0)),U,1)]""
Begin DoDot:1
+6 SET PSBX2="DD"_U_$PIECE($GET(^PSB(53.79,DA,.5,1,0)),U,1)
End DoDot:1
+7 IF $PIECE(PSBX1,U,1)["V"
IF $PIECE($GET(^PSB(53.79,DA,.6,1,0)),U,1)]""
Begin DoDot:1
+8 SET PSBX2="ADD"_U_$PIECE($GET(^PSB(53.79,DA,.6,1,0)),U,1)
End DoDot:1
+9 IF $GET(PSBX2)=""
IF $PIECE(PSBX1,U,1)["V"
IF $PIECE($GET(^PSB(53.79,DA,.7,1,0)),U,1)]""
Begin DoDot:1
+10 SET PSBX2="SOL"_U_$PIECE($GET(^PSB(53.79,DA,.7,1,0)),U,1)
End DoDot:1
+11 IF $GET(PSBX2)]""
SET PSBPRM(1)=PSBX2
+12 DO SCANFAIL^PSBVDLU3(.PSBRSLT,.PSBPRM)
+13 QUIT
