PSBMLEN1 ;BIRMINGHAM/EFC-BCMA MEDICATION LOG FUNCTIONS ;03/06/16 3:06pm
;;3.0;BAR CODE MED ADMIN;**3,4,9,11,13,28,50,83,114**;Mar 2004;Build 3
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; Reference/IA
; ENE^PSJBCMA4/3416
;
;*83 - move Disp Drug data to param 11 from 10 previously. Param 10
; now in use for Remove time not used in this manual entry
; - add Rem time string to display
; - validation checks for proper use of Inj & derm site text
;
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)
D:PSBMRRFL>0 ;add Removal times if MRR *83
.W !,"Removal Times: "
.W $S(PSBMRRFL=1:$$REMSTR^PSBUTL(PSBADST,PSBDOA,PSBSCHT,PSBOSP,PSBOPRSP),1:PSBRMST)
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 PSBREC(10)="" ;init Rmv dt/tim for One Times *83
.S PSBINDX=11 ;Disp Drug moved to param 11 *83
.S X="" F S X=$O(PSBDDA(X)) Q:X="" D
..S PSBREC(PSBINDX)=$P(PSBDDA(X),U,1,2)_U_$P(PSBDDA(X),U,4)_U_$P(PSBDDA(X),U,4)_U_PSBDOSEF_U_U_U_PSBMRRFL ;add MRR flag 8th piece *83
..S 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=$G(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")
.;init Rmv dt/time for continuous meds *83
.S:PSBMRRFL PSBREC(10)=$S((PSBMRRFL&PSBDOA):$$FMADD^XLFDT(PSBDTX,,,PSBDOA),1:"")
.S PSBINDX=11 ;Disp Drug moved to param 11 *83
.S X="" F S X=$O(PSBDDA(X)) Q:X="" D
..S PSBREC(PSBINDX)=$P(PSBDDA(X),U,1,2)_U_$P(PSBDDA(X),U,4)_U_$P(PSBDDA(X),U,4)_U_PSBDOSEF_U_U_U_PSBMRRFL ;add MRR flag 8th piece *83
..S 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,3),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
;
;*83 convert Kills to tag so can be used by existing patch & new body site logic
S PSBXUIT="" ;init field error/kill flag *83
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"
......S PSBXUIT=1 D KILL
....Q:PSBXUIT
....S ^PSB(53.79,"APATCH",$P(^PSB(53.79,DA,0),U),$P(^PSB(53.79,DA,0),U,6),DA)=""
.Q:PSBXUIT
.; new body site validation checks *83
.I $D(DA) D SITECHK D:PSBXUIT KILL
.;
.Q:(PSBIEN="+1")&('$D(PSBIEN(1)))
.Q: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"
G:PSBXUIT FILE ;for field errors refile and run form again *83
Q
;
SITECHK ;Inj or Derm site field validate
S PSBXUIT=""
I $P(^PSB(53.79,DA,.1),U,6)]"",$P(^PSB(53.79,DA,.1),U,8)]"" D
.W !!,"Entry of both Injection and Dermal site fields are not allowed."
.S PSBXUIT=1
I 'PSBXUIT,PSBNJECT,$P(^PSB(53.79,DA,.1),U,6)="" D
.W !!,"Injection site required for this medication set to prompt for Injection Site."
.S PSBXUIT=1
I 'PSBXUIT,PSBMRRFL,$P(^PSB(53.79,DA,.1),U,8)="" D
.W !!,"Dermal site required for this medication requiring removal (MRR)."
.S PSBXUIT=1
I 'PSBXUIT,'PSBNJECT,$P(^PSB(53.79,DA,.1),U,6)]"" D
.W !!,"Not flagged as Injection Site medication, Injection Site field must be blank."
.S PSBXUIT=1
I 'PSBXUIT,'PSBMRRFL,$P(^PSB(53.79,DA,.1),U,8)]"" D
.W !!,"Not flagged as medication requiring removal (MRR), Dermal Site field must be blank."
.S PSBXUIT=1
Q
KILL ;Kill and write msg
W !!,"Incomplete Med Log Entry, Deleting...#",DA,!,$C(7)
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
K DIR S DIR(0)="E" D ^DIR
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,DSPDRG
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
S DSPDRG=+$O(^PSB(53.79,DA,.5,0))
I $P(PSBX1,U,1)["U",$P($G(^PSB(53.79,DA,.5,DSPDRG,0)),U,1)]"" D
.S PSBX2="DD"_U_$P($G(^PSB(53.79,DA,.5,DSPDRG,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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBMLEN1 9739 printed Dec 13, 2024@01:40:10 Page 2
PSBMLEN1 ;BIRMINGHAM/EFC-BCMA MEDICATION LOG FUNCTIONS ;03/06/16 3:06pm
+1 ;;3.0;BAR CODE MED ADMIN;**3,4,9,11,13,28,50,83,114**;Mar 2004;Build 3
+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 ;
+7 ;*83 - move Disp Drug data to param 11 from 10 previously. Param 10
+8 ; now in use for Remove time not used in this manual entry
+9 ; - add Rem time string to display
+10 ; - validation checks for proper use of Inj & derm site text
+11 ;
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 ;add Removal times if MRR *83
if PSBMRRFL>0
Begin DoDot:1
+19 WRITE !,"Removal Times: "
+20 WRITE $SELECT(PSBMRRFL=1:$$REMSTR^PSBUTL(PSBADST,PSBDOA,PSBSCHT,PSBOSP,PSBOPRSP),1:PSBRMST)
End DoDot:1
+21 IF $DATA(^XUSEC("PSB READ ONLY",DUZ))
Begin DoDot:1
+22 WRITE !!,"Medications CANNOT be administered while in PSB READ ONLY mode.",!!
READ "Press ENTER KEY to continue. ",PSBCNTNU:5
End DoDot:1
QUIT
+23 WRITE !!,"Is this the correct Order"
SET %=1
DO YN^DICN
if %'=1
QUIT
+24 ;
+25 ; PRN, One-Time, On Call orders
+26 ;
+27 IF PSBSCHT'="C"
Begin DoDot:1
+28 DO VAL^PSBMLVAL(.PSB,DFN,+PSBONX,$EXTRACT(PSBONX,$LENGTH(PSBONX)))
+29 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)
+30 IF $DATA(^XUSEC("PSB READ ONLY",DUZ))
WRITE !,"This operation is NOT AVAILABLE in PSB READ ONLY mode.",!
QUIT
+31 IF ($DATA(^XUSEC("PSB STUDENT",DUZ)))
IF ('$DATA(^XUSEC("PSB INSTRUCTOR")))
WRITE !,"This operation is NOT AVAILABLE in PSB READ ONLY mode.",!
QUIT
+32 WRITE !!,"Create an administration for this order"
SET %=1
DO YN^DICN
if %'=1
QUIT
+33 IF PSBSCHT="P"
Begin DoDot:2
+34 KILL DIR
SET DIR(0)="FB^1:30"
SET DIR("A")="PRN Reason (1-30 characters)"
+35 WRITE !!,"NOTICE: PRN Reason is Required for ALL PRN Entries",!
+36 DO ^DIR
+37 IF Y=""!(Y["^")
WRITE !!,"Sorry, Reason is required, No Entry Made!"
QUIT
+38 SET PSBREC(6)=$PIECE(Y,"|")
End DoDot:2
if Y=""!(Y["^")
QUIT
+39 ; Build the form of dosage to CAP or TAB or null
+40 if (PSBDOSEF'?1"CAP".E)&(PSBDOSEF'?1"TAB".E)&(PSBDOSEF'?1"PATCH".E)
SET PSBDOSEF=""
+41 ; Build the variable dose check #####-#####MG
+42 SET PSBVARD=$SELECT(PSBDOSE?1.5N1"-"1.5N.E:1,1:0)
+43 SET PSBREC(0)=DFN
+44 SET PSBREC(1)=PSBONX
+45 SET PSBREC(2)=PSBSCHT
+46 SET PSBREC(3)="G"
+47 SET PSBREC(4)=PSBOIT
+48 SET PSBREC(5)=""
+49 SET PSBREC(7)="Entry created with 'Manual Medication Entry' option."
+50 SET PSBREC(8)=""
+51 SET PSBREC(9)=$SELECT(PSBONX["U":"UDTAB",1:"PBTAB")
+52 ;init Rmv dt/tim for One Times *83
SET PSBREC(10)=""
+53 ;Disp Drug moved to param 11 *83
SET PSBINDX=11
+54 SET X=""
FOR
SET X=$ORDER(PSBDDA(X))
if X=""
QUIT
Begin DoDot:2
+55 ;add MRR flag 8th piece *83
SET PSBREC(PSBINDX)=$PIECE(PSBDDA(X),U,1,2)_U_$PIECE(PSBDDA(X),U,4)_U_$PIECE(PSBDDA(X),U,4)_U_PSBDOSEF_U_U_U_PSBMRRFL
+56 SET PSBINDX=PSBINDX+1
End DoDot:2
+57 SET X=""
FOR
SET X=$ORDER(PSBADA(X))
if X=""
QUIT
SET PSBREC(PSBINDX)=PSBADA(X)
SET PSBINDX=PSBINDX+1
+58 SET X=""
FOR
SET X=$ORDER(PSBSOLA(X))
if X=""
QUIT
SET PSBREC(PSBINDX)=PSBSOLA(X)
SET PSBINDX=PSBINDX+1
+59 DO FILE
+60 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
+61 ;
+62 ; Continuous Meds
+63 ;
+64 IF PSBSCHT="C"
Begin DoDot:1
+65 WRITE !
SET %DT="AEQ"
SET %DT("A")="Enter the DATE the medication was administered: "
+66 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
+67 if PSBODSCH
SET PSBSCTMX=$$GETADMIN^PSBVDLU1(DFN,PSBONX,PSBOST,PSBFREQ,PSBDTX)
+68 FOR PSBXX=0:1
if $GET(^TMP("PSB",$JOB,"GETADMIN",PSBXX))=""
QUIT
Begin DoDot:2
+69 SET X=""
SET Y=$GET(^TMP("PSB",$JOB,"GETADMIN",PSBXX))
+70 FOR Z=1:1:$LENGTH(Y,"-")
SET X=X_$SELECT(X]"":";",1:"")_Z_":"_$PIECE(Y,"-",Z)
End DoDot:2
+71 IF PSBODSCH
IF PSBSCTMX=""
Begin DoDot:2
+72 WRITE !!,"Order "_PSBONX_" is NOT SCHEDULED for administration on that entered date."
+73 KILL DIR
SET DIR(0)="E^"
DO ^DIR
End DoDot:2
QUIT
+74 KILL DIR
SET DIR(0)="S^"_X
SET DIR("A")="Select Administration Time"
+75 DO ^DIR
if Y<1
QUIT
+76 SET PSBDTX=+(PSBDTX_"."_Y(0))
+77 SET Y=PSBDTX
DO D^DIQ
+78 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=$GET(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 ;init Rmv dt/time for continuous meds *83
+16 if PSBMRRFL
SET PSBREC(10)=$SELECT((PSBMRRFL&PSBDOA):$$FMADD^XLFDT(PSBDTX,,,PSBDOA),1:"")
+17 ;Disp Drug moved to param 11 *83
SET PSBINDX=11
+18 SET X=""
FOR
SET X=$ORDER(PSBDDA(X))
if X=""
QUIT
Begin DoDot:2
+19 ;add MRR flag 8th piece *83
SET PSBREC(PSBINDX)=$PIECE(PSBDDA(X),U,1,2)_U_$PIECE(PSBDDA(X),U,4)_U_$PIECE(PSBDDA(X),U,4)_U_PSBDOSEF_U_U_U_PSBMRRFL
+20 SET PSBINDX=PSBINDX+1
End DoDot:2
+21 SET X=""
FOR
SET X=$ORDER(PSBADA(X))
if X=""
QUIT
SET PSBREC(PSBINDX)=PSBADA(X)
SET PSBINDX=PSBINDX+1
+22 SET X=""
FOR
SET X=$ORDER(PSBSOLA(X))
if X=""
QUIT
SET PSBREC(PSBINDX)=PSBSOLA(X)
SET PSBINDX=PSBINDX+1
+23 DO FILE
End DoDot:1
+24 KILL ^TMP("PSB",$JOB)
+25 QUIT
+26 ;
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,3),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 ;
+18 ;*83 convert Kills to tag so can be used by existing patch & new body site logic
+19 ;init field error/kill flag *83
SET PSBXUIT=""
+20 IF PSBSAVE=1
Begin DoDot:1
+21 IF $DATA(DA)
if ($PIECE(^PSB(53.79,DA,0),U,9)="G")
Begin DoDot:2
+22 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
+23 IF $PIECE(^PSB(53.79,DA,.5,PSBY,0),U,4)="PATCH"
Begin DoDot:4
+24 SET (PSBYX,PSBXUIT)=""
FOR
SET PSBYX=$ORDER(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBYX),-1)
if PSBYX=""
QUIT
Begin DoDot:5
+25 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
+26 WRITE !!,"PATCH has been GIVEN before this admin completed"
+27 SET PSBXUIT=1
DO KILL
End DoDot:6
End DoDot:5
if PSBXUIT
QUIT
+28 if PSBXUIT
QUIT
+29 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
+30 if PSBXUIT
QUIT
+31 ; new body site validation checks *83
+32 IF $DATA(DA)
DO SITECHK
if PSBXUIT
DO KILL
+33 ;
+34 if (PSBIEN="+1")&('$DATA(PSBIEN(1)))
QUIT
+35 if PSBXUIT
QUIT
+36 SET X=$SELECT($PIECE(PSBIEN,",",2)]"":$PIECE(PSBIEN,",",2),PSBIEN="+1":PSBIEN(1),1:"")
+37 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
+38 ;If Manual Med Entry was used, document "scanning failure"
IF X]""
IF $GET(PSBMMEN)=1
DO SCANFAIL
End DoDot:1
+39 ;for field errors refile and run form again *83
if PSBXUIT
GOTO FILE
+40 QUIT
+41 ;
SITECHK ;Inj or Derm site field validate
+1 SET PSBXUIT=""
+2 IF $PIECE(^PSB(53.79,DA,.1),U,6)]""
IF $PIECE(^PSB(53.79,DA,.1),U,8)]""
Begin DoDot:1
+3 WRITE !!,"Entry of both Injection and Dermal site fields are not allowed."
+4 SET PSBXUIT=1
End DoDot:1
+5 IF 'PSBXUIT
IF PSBNJECT
IF $PIECE(^PSB(53.79,DA,.1),U,6)=""
Begin DoDot:1
+6 WRITE !!,"Injection site required for this medication set to prompt for Injection Site."
+7 SET PSBXUIT=1
End DoDot:1
+8 IF 'PSBXUIT
IF PSBMRRFL
IF $PIECE(^PSB(53.79,DA,.1),U,8)=""
Begin DoDot:1
+9 WRITE !!,"Dermal site required for this medication requiring removal (MRR)."
+10 SET PSBXUIT=1
End DoDot:1
+11 IF 'PSBXUIT
IF 'PSBNJECT
IF $PIECE(^PSB(53.79,DA,.1),U,6)]""
Begin DoDot:1
+12 WRITE !!,"Not flagged as Injection Site medication, Injection Site field must be blank."
+13 SET PSBXUIT=1
End DoDot:1
+14 IF 'PSBXUIT
IF 'PSBMRRFL
IF $PIECE(^PSB(53.79,DA,.1),U,8)]""
Begin DoDot:1
+15 WRITE !!,"Not flagged as medication requiring removal (MRR), Dermal Site field must be blank."
+16 SET PSBXUIT=1
End DoDot:1
+17 QUIT
KILL ;Kill and write msg
+1 WRITE !!,"Incomplete Med Log Entry, Deleting...#",DA,!,$CHAR(7)
+2 SET A=^PSB(53.79,DA,0)
SET DFN=$PIECE(A,U,1)
SET AADT=$PIECE(A,U,6)
+3 KILL ^PSB(53.79,"AADT",DFN,AADT,DA)
SET DIK="^PSB(53.79,"
DO ^DIK
+4 KILL DIR
SET DIR(0)="E"
DO ^DIR
+5 QUIT
+6 ;
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,DSPDRG
+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 SET DSPDRG=+$ORDER(^PSB(53.79,DA,.5,0))
+6 IF $PIECE(PSBX1,U,1)["U"
IF $PIECE($GET(^PSB(53.79,DA,.5,DSPDRG,0)),U,1)]""
Begin DoDot:1
+7 SET PSBX2="DD"_U_$PIECE($GET(^PSB(53.79,DA,.5,DSPDRG,0)),U,1)
End DoDot:1
+8 IF $PIECE(PSBX1,U,1)["V"
IF $PIECE($GET(^PSB(53.79,DA,.6,1,0)),U,1)]""
Begin DoDot:1
+9 SET PSBX2="ADD"_U_$PIECE($GET(^PSB(53.79,DA,.6,1,0)),U,1)
End DoDot:1
+10 IF $GET(PSBX2)=""
IF $PIECE(PSBX1,U,1)["V"
IF $PIECE($GET(^PSB(53.79,DA,.7,1,0)),U,1)]""
Begin DoDot:1
+11 SET PSBX2="SOL"_U_$PIECE($GET(^PSB(53.79,DA,.7,1,0)),U,1)
End DoDot:1
+12 IF $GET(PSBX2)]""
SET PSBPRM(1)=PSBX2
+13 DO SCANFAIL^PSBVDLU3(.PSBRSLT,.PSBPRM)
+14 QUIT
