Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSBMLEN1

PSBMLEN1.m

Go to the documentation of this file.
  1. 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
  1. ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
  1. ;
  1. ; Reference/IA
  1. ; ENE^PSJBCMA4/3416
  1. ;
  1. ;*83 - move Disp Drug data to param 11 from 10 previously. Param 10
  1. ; now in use for Remove time not used in this manual entry
  1. ; - add Rem time string to display
  1. ; - validation checks for proper use of Inj & derm site text
  1. ;
  1. NEW(Y) ; Create the new entry
  1. N PSBREC,PSB,PSBADST,PSBFREQ
  1. S PSBMMEN=1
  1. W @IOF D CLEAN^PSBVT,PSJ1^PSBVT(DFN,Y)
  1. D NOW^%DTC
  1. I PSBOSP<% D Q:%'=1
  1. .W @IOF,$C(7)
  1. .W !,"NOTICE: This order is NOT currently active."
  1. .W !," Are You Sure You Want To Continue"
  1. .S %=2 D YN^DICN
  1. I PSBADST="" S PSBFREQ=$$GETFREQ^PSBVDLU1(DFN,PSBONX),PSBADST=$$GETADMIN^PSBVDLU1(DFN,PSBONX,PSBOST,PSBFREQ,PSBDT)
  1. E K ^TMP("PSB",$J,"GETADMIN") S ^TMP("PSB",$J,"GETADMIN",0)=PSBADST
  1. S PSBODSCH=0 I (PSBFREQ#1440'=0),(1440#PSBFREQ'=0) S PSBODSCH=1
  1. W !,"Order: ",PSBONX
  1. W !,"Medication: ",PSBOITX
  1. W !,"Dosage: ",PSBDOSE
  1. W !,"Schedule: ",PSBSCH
  1. W !,"Admin Times: ",$S(PSBODSCH:"(Odd Sched.)",1:PSBADST)
  1. D:PSBMRRFL>0 ;add Removal times if MRR *83
  1. .W !,"Removal Times: "
  1. .W $S(PSBMRRFL=1:$$REMSTR^PSBUTL(PSBADST,PSBDOA,PSBSCHT,PSBOSP,PSBOPRSP),1:PSBRMST)
  1. I $D(^XUSEC("PSB READ ONLY",DUZ)) D Q
  1. .W !!,"Medications CANNOT be administered while in PSB READ ONLY mode.",!! R "Press ENTER KEY to continue. ",PSBCNTNU:5
  1. W !!,"Is this the correct Order" S %=1 D YN^DICN Q:%'=1
  1. ;
  1. ; PRN, One-Time, On Call orders
  1. ;
  1. I PSBSCHT'="C" D
  1. .D VAL^PSBMLVAL(.PSB,DFN,+PSBONX,$E(PSBONX,$L(PSBONX)))
  1. .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)
  1. .I $D(^XUSEC("PSB READ ONLY",DUZ)) W !,"This operation is NOT AVAILABLE in PSB READ ONLY mode.",! Q
  1. .I ($D(^XUSEC("PSB STUDENT",DUZ))),('$D(^XUSEC("PSB INSTRUCTOR"))) W !,"This operation is NOT AVAILABLE in PSB READ ONLY mode.",! Q
  1. .W !!,"Create an administration for this order" S %=1 D YN^DICN Q:%'=1
  1. .I PSBSCHT="P" D Q:Y=""!(Y["^")
  1. ..K DIR S DIR(0)="FB^1:30",DIR("A")="PRN Reason (1-30 characters)"
  1. ..W !!,"NOTICE: PRN Reason is Required for ALL PRN Entries",!
  1. ..D ^DIR
  1. ..I Y=""!(Y["^") W !!,"Sorry, Reason is required, No Entry Made!" Q
  1. ..S PSBREC(6)=$P(Y,"|")
  1. .; Build the form of dosage to CAP or TAB or null
  1. .S:(PSBDOSEF'?1"CAP".E)&(PSBDOSEF'?1"TAB".E)&(PSBDOSEF'?1"PATCH".E) PSBDOSEF=""
  1. .; Build the variable dose check #####-#####MG
  1. .S PSBVARD=$S(PSBDOSE?1.5N1"-"1.5N.E:1,1:0)
  1. .S PSBREC(0)=DFN
  1. .S PSBREC(1)=PSBONX
  1. .S PSBREC(2)=PSBSCHT
  1. .S PSBREC(3)="G"
  1. .S PSBREC(4)=PSBOIT
  1. .S PSBREC(5)=""
  1. .S PSBREC(7)="Entry created with 'Manual Medication Entry' option."
  1. .S PSBREC(8)=""
  1. .S PSBREC(9)=$S(PSBONX["U":"UDTAB",1:"PBTAB")
  1. .S PSBREC(10)="" ;init Rmv dt/tim for One Times *83
  1. .S PSBINDX=11 ;Disp Drug moved to param 11 *83
  1. .S X="" F S X=$O(PSBDDA(X)) Q:X="" D
  1. ..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
  1. ..S PSBINDX=PSBINDX+1
  1. .S X="" F S X=$O(PSBADA(X)) Q:X="" S PSBREC(PSBINDX)=PSBADA(X),PSBINDX=PSBINDX+1
  1. .S X="" F S X=$O(PSBSOLA(X)) Q:X="" S PSBREC(PSBINDX)=PSBSOLA(X),PSBINDX=PSBINDX+1
  1. .D FILE
  1. .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))
  1. ;
  1. ; Continuous Meds
  1. ;
  1. I PSBSCHT="C" D
  1. .W ! S %DT="AEQ",%DT("A")="Enter the DATE the medication was administered: "
  1. .D NOW^%DTC S %DT(0)=(-1)*X,%DT("B")="" D ^%DT K %DT(0) Q:Y<1 S PSBDTX=Y D D^DIQ
  1. .S:PSBODSCH PSBSCTMX=$$GETADMIN^PSBVDLU1(DFN,PSBONX,PSBOST,PSBFREQ,PSBDTX)
  1. .F PSBXX=0:1 Q:$G(^TMP("PSB",$J,"GETADMIN",PSBXX))="" D
  1. ..S X="",Y=$G(^TMP("PSB",$J,"GETADMIN",PSBXX))
  1. ..F Z=1:1:$L(Y,"-") S X=X_$S(X]"":";",1:"")_Z_":"_$P(Y,"-",Z)
  1. .I PSBODSCH,PSBSCTMX="" D Q
  1. ..W !!,"Order "_PSBONX_" is NOT SCHEDULED for administration on that entered date."
  1. ..K DIR S DIR(0)="E^" D ^DIR
  1. .K DIR S DIR(0)="S^"_X,DIR("A")="Select Administration Time"
  1. .D ^DIR Q:Y<1
  1. .S PSBDTX=+(PSBDTX_"."_Y(0))
  1. .S Y=PSBDTX D D^DIQ
  1. .W !!,"Create an administration for ",Y S %=1 D YN^DICN Q:%'=1
  1. FORUM .; Build the form of dosage to CAP or TAB or null
  1. .S PSBDOSEF=$G(PSBDOSEF)
  1. .S:(PSBDOSEF'?1"CAP".E)&(PSBDOSEF'?1"TAB".E)&(PSBDOSEF'?1"PATCH".E) PSBDOSEF=""
  1. .; Build the variable dose check #####-#####MG
  1. .S PSBVARD=$S(PSBDOSE?1.5N1"-"1.5N.E:1,1:0)
  1. .S PSBREC(0)=DFN
  1. .S PSBREC(1)=PSBONX
  1. .S PSBREC(2)=PSBSCHT
  1. .S PSBREC(3)="G"
  1. .S PSBREC(4)=PSBOIT
  1. .S PSBREC(5)=PSBDTX
  1. .S PSBREC(6)=""
  1. .S PSBREC(7)="Entry created with 'Manual Medication Entry' option."
  1. .S PSBREC(8)=""
  1. .S PSBREC(9)=$S(PSBONX["U":"UDTAB",1:"PBTAB")
  1. .;init Rmv dt/time for continuous meds *83
  1. .S:PSBMRRFL PSBREC(10)=$S((PSBMRRFL&PSBDOA):$$FMADD^XLFDT(PSBDTX,,,PSBDOA),1:"")
  1. .S PSBINDX=11 ;Disp Drug moved to param 11 *83
  1. .S X="" F S X=$O(PSBDDA(X)) Q:X="" D
  1. ..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
  1. ..S PSBINDX=PSBINDX+1
  1. .S X="" F S X=$O(PSBADA(X)) Q:X="" S PSBREC(PSBINDX)=PSBADA(X),PSBINDX=PSBINDX+1
  1. .S X="" F S X=$O(PSBSOLA(X)) Q:X="" S PSBREC(PSBINDX)=PSBSOLA(X),PSBINDX=PSBINDX+1
  1. .D FILE
  1. K ^TMP("PSB",$J)
  1. Q
  1. ;
  1. FILE ; Call the med log RPC to file it and DDS to edit it
  1. N PSB,PSBSAVE,PSBAUDIT
  1. D RPC^PSBML(.PSB,"+1^MEDPASS",.PSBREC)
  1. I '$D(PSB) S PSB(0)=1,PSB(1)="-1^INCOMPLETE ENTRY^"_PSBINCX
  1. I +PSB(1)<1 D Q
  1. .W @IOF,!,"Error(s) Creating Med Log Entry",!
  1. .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))
  1. .W !!,"No Med Log Entry Created.",!!
  1. .K DIR S DIR(0)="E" D ^DIR
  1. S PSBSAVE=0 S:'$G(PSBMMEN) PSBAUDIT=1
  1. S DA=$P(PSB(1),U,3),DDSFILE=53.79,DDSPARM="C"
  1. I $P(^PSB(53.79,DA,.1),U,1)?.N1"U" S DR="[PSB NEW UD ENTRY]"
  1. I $P(^PSB(53.79,DA,.1),U,1)?.N1"V" S DR="[PSB NEW IV ENTRY]"
  1. D ^DDS
  1. L +^PSB(53.79,DA):DILOCKTM I L -^PSB(53.79,DA) I PSBSAVE'=1 D
  1. .W !,"Incomplete Med Log Entry, Deleting...#",DA S A=^PSB(53.79,DA,0),DFN=$P(A,U,1),AADT=$P(A,U,6)
  1. .K ^PSB(53.79,"AADT",DFN,AADT,DA) S DIK="^PSB(53.79," D ^DIK
  1. ;
  1. ;*83 convert Kills to tag so can be used by existing patch & new body site logic
  1. S PSBXUIT="" ;init field error/kill flag *83
  1. I PSBSAVE=1 D
  1. .I $D(DA) D:($P(^PSB(53.79,DA,0),U,9)="G")
  1. ..I $D(^PSB(53.79,DA,.5)) S PSBY=0 F S PSBY=$O(^PSB(53.79,DA,.5,PSBY)) Q:+PSBY<1 D
  1. ...I $P(^PSB(53.79,DA,.5,PSBY,0),U,4)="PATCH" D
  1. ....S (PSBYX,PSBXUIT)="" F S PSBYX=$O(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBYX),-1) Q:PSBYX="" D Q:PSBXUIT
  1. .....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
  1. ......W !!,"PATCH has been GIVEN before this admin completed"
  1. ......S PSBXUIT=1 D KILL
  1. ....Q:PSBXUIT
  1. ....S ^PSB(53.79,"APATCH",$P(^PSB(53.79,DA,0),U),$P(^PSB(53.79,DA,0),U,6),DA)=""
  1. .Q:PSBXUIT
  1. .; new body site validation checks *83
  1. .I $D(DA) D SITECHK D:PSBXUIT KILL
  1. .;
  1. .Q:(PSBIEN="+1")&('$D(PSBIEN(1)))
  1. .Q:PSBXUIT
  1. .S X=$S($P(PSBIEN,",",2)]"":$P(PSBIEN,",",2),PSBIEN="+1":PSBIEN(1),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
  1. .I X]"",$G(PSBMMEN)=1 D SCANFAIL ;If Manual Med Entry was used, document "scanning failure"
  1. G:PSBXUIT FILE ;for field errors refile and run form again *83
  1. Q
  1. ;
  1. SITECHK ;Inj or Derm site field validate
  1. S PSBXUIT=""
  1. I $P(^PSB(53.79,DA,.1),U,6)]"",$P(^PSB(53.79,DA,.1),U,8)]"" D
  1. .W !!,"Entry of both Injection and Dermal site fields are not allowed."
  1. .S PSBXUIT=1
  1. I 'PSBXUIT,PSBNJECT,$P(^PSB(53.79,DA,.1),U,6)="" D
  1. .W !!,"Injection site required for this medication set to prompt for Injection Site."
  1. .S PSBXUIT=1
  1. I 'PSBXUIT,PSBMRRFL,$P(^PSB(53.79,DA,.1),U,8)="" D
  1. .W !!,"Dermal site required for this medication requiring removal (MRR)."
  1. .S PSBXUIT=1
  1. I 'PSBXUIT,'PSBNJECT,$P(^PSB(53.79,DA,.1),U,6)]"" D
  1. .W !!,"Not flagged as Injection Site medication, Injection Site field must be blank."
  1. .S PSBXUIT=1
  1. I 'PSBXUIT,'PSBMRRFL,$P(^PSB(53.79,DA,.1),U,8)]"" D
  1. .W !!,"Not flagged as medication requiring removal (MRR), Dermal Site field must be blank."
  1. .S PSBXUIT=1
  1. Q
  1. KILL ;Kill and write msg
  1. W !!,"Incomplete Med Log Entry, Deleting...#",DA,!,$C(7)
  1. S A=^PSB(53.79,DA,0),DFN=$P(A,U,1),AADT=$P(A,U,6)
  1. K ^PSB(53.79,"AADT",DFN,AADT,DA) S DIK="^PSB(53.79," D ^DIK
  1. K DIR S DIR(0)="E" D ^DIR
  1. Q
  1. ;
  1. FDATE ;Check Admin Time for future date/time.
  1. N PSBTIMX
  1. S PSBTIMX=X D NOW^%DTC
  1. I PSBTIMX>% W $C(7) S (DDSERROR,DDSBR)=1 D HLP^DDSUTL("Future date/time is not allowed")
  1. Q
  1. ;
  1. SCANFAIL ;File an MSF record
  1. N PSBPRM,PSBRSLT,PSBX,PSBX1,PSBX2,DSPDRG
  1. S PSBX=^PSB(53.79,DA,0)
  1. S PSBX1=^PSB(53.79,DA,.1)
  1. S PSBPRM(0)=$P(PSBX,U,1)_U_$P(PSBX1,U,1)_U_"Manual Medication Entry"_U_""_U_"M"_U_1
  1. S DSPDRG=+$O(^PSB(53.79,DA,.5,0))
  1. I $P(PSBX1,U,1)["U",$P($G(^PSB(53.79,DA,.5,DSPDRG,0)),U,1)]"" D
  1. .S PSBX2="DD"_U_$P($G(^PSB(53.79,DA,.5,DSPDRG,0)),U,1)
  1. I $P(PSBX1,U,1)["V",$P($G(^PSB(53.79,DA,.6,1,0)),U,1)]"" D
  1. .S PSBX2="ADD"_U_$P($G(^PSB(53.79,DA,.6,1,0)),U,1)
  1. I $G(PSBX2)="",$P(PSBX1,U,1)["V",$P($G(^PSB(53.79,DA,.7,1,0)),U,1)]"" D
  1. .S PSBX2="SOL"_U_$P($G(^PSB(53.79,DA,.7,1,0)),U,1)
  1. I $G(PSBX2)]"" S PSBPRM(1)=PSBX2
  1. D SCANFAIL^PSBVDLU3(.PSBRSLT,.PSBPRM)
  1. Q