- 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 Jan 18, 2025@02:41:24 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