PSBOMT ;BIRMINGHAM/TEJ-BCMA MEDICATION THERAPY REPORT ;03/06/16 3:06pm
;;3.0;BAR CODE MED ADMIN;**32,50,70,72,83,97,98**;Mar 2004;Build 2
;Per VA Directive 6402, this routine should not be modified.
;
; Reference/IA
; File 50.7/2880
; File 52.6/436
; File 52.7/437
; File 200/10060
; EN^PSJBCMA1/2829
; IEN^PSN50P65/4543
; DRGIEN^PSS50P7/4662
; VAC^PSS50/4533
; ^PSDRUG(/221
;
;*70 - reset PSBCLINORD = 2 to signify combined orders report
;*83 - Add MRR meds remove times to report.
;
EN ;
N PSBHDR,PSBORDS,PSBORD,PSBOIP
N TMP
K TMP("PSBOIS",$J),TMP("VA CLASS",$J),TMP("PSBADDS",$J),TMP("PSBSOLS",$J),PSBLGD,PSBOIL,PSBDDL,PSBSOLL,PSBADDL
S PSBCLSS=0,PSBCFLG=0
S PSBXDFN=$P(PSBRPT(.1),U,2)
S PSBSTRT=$P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,7),PSBSTOP=$P(PSBRPT(.1),U,8)+$P(PSBRPT(.1),U,9)
K PSBOCRIT F Y=1:1:4 I $P(PSBRPT(.2),U,Y) S PSBOCRIT=$G(PSBOCRIT,"")_$P("C^P^OC^O",U,Y)_"^"
D NOW^%DTC S (Y,PSBNOWX)=% D DD^%DT S PSBDTTM=$E(Y,1,18)
S:+PSBSTRT'>0 PSBSTRT=$$FMADD^XLFDT(X,-1)
S:+PSBSTOP'>0 PSBSTOP=$P(%,".")
I $D(PSBRPT(.2)) I $P(PSBRPT(.2),U,8) S PSBCFLG=1
I $D(PSBRPT(2)) F XD=$O(PSBRPT(2,0)):1:$O(PSBRPT(2,"B"),-1) S PSBRPT(2,XD,0)=$TR(PSBRPT(2,XD,0),"~",U) D:$P(PSBRPT(2,XD,0),U)="MT"
.I $P(PSBRPT(2,XD,0),U,2)="OIT" D Q
..S PSBSRCHL="ORDERABLE ITEM SEARCH LIST:",PSBOIL(+$P(PSBRPT(2,XD,0),U,3))=""
..S PSB=$P(PSBRPT(2,XD,0),U,3) F X=1:1:$L(PSB,",") Q:$P(PSB,",",X)="" S (TMP("PSBOIS",$J,$P(PSB,",",X)),PSBOIP("OIP",$P(PSB,",",X)))=""
.I $P(PSBRPT(2,XD,0),U,2)="ADD" D Q
..S PSBSRCHL="IV MEDICATION SEARCH LIST:"
..I $D(^PSDRUG("A526",$P(PSBRPT(2,XD,0),U,3))) S X2=$O(^PSDRUG("A526",$P(PSBRPT(2,XD,0),U,3),"")) S PSBADDL(X2)="",TMP("PSBOIS",$J,$$OFROMA(X2))=""
.I $P(PSBRPT(2,XD,0),U,2)="SOL" D Q
..S PSBSRCHL="IV MEDICATION SEARCH LIST:"
..I $D(^PSDRUG("A527",$P(PSBRPT(2,XD,0),U,3))) S X2=$O(^PSDRUG("A527",$P(PSBRPT(2,XD,0),U,3),"")) S PSBSOLL(X2)="",TMP("PSBOIS",$J,$$OFROMS(X2))=""
.I $P(PSBRPT(2,XD,0),U,2)="DD" D K PSBDRGS Q
..S PSBSRCHL="DISPENSED DRUG SEARCH LIST:",PSBDDL($P(PSBRPT(2,XD,0),U,3))=""
..K PSBDRGS S PSBDRGS="" D OILST^PSBRPCMO(.PSBDRGS,$P(PSBRPT(2,XD,0),U,3),"UD")
..F X2=PSBDRGS(0):1:$O(PSBDRGS(""),-1) I +PSBDRGS(1)'<0 S TMP("PSBOIS",$J,$P(PSBDRGS(X2),U,4))=""
.I $P(PSBRPT(2,XD,0),U,2)="VAC" D
..S PSBSRCHL="VA DRUG CLASS SEARCH LIST:"
..S PSBCLS=$P(PSBRPT(2,XD,0),U,3) D GETCLSS(PSBCLS) K PSBDDRG("VAC") M TMP("VA CLASS",$J,PSBCLS,"DDRG")=PSBDDRG K PSBDDRG
..S PSBCLSS=1
M PSBOIP("OIP")=TMP("PSBOIS",$J)
D OUT(PSBXDFN,PSBSTRT,PSBSTOP)
Q
OUT(PSBXDFN,PSBSTRT,PSBSTOP) ;
D:PSBCLSS GETOIS ; POSSBLE CLASS ITEMS VIA AVAIL ORDERS
D GETADSO^PSBOMT1 ; ALL ADDS AND SOLS
D FINDIENS^PSBOMT1 ; FIND ALL MED LOG ENTRS
D PREOUT ; WRIT TO GLOBL
D WRITEOT
D CLEANSUM^PSBOMT1
D CLEANALL^PSBOMT1
Q
GETOIS ;
K ^TMP("PSJ",$J),PSBTMP
D EN^PSJBCMA(PSBXDFN,PSBSTRT)
Q:^TMP("PSJ",$J,1,0)<0
M PSBTMP=^TMP("PSJ",$J) K ^TMP("PSJ",$J)
S X=0 F S X=$O(PSBTMP(X)) Q:+X=0 D
.Q:$G(PSBOCRIT,"")'[$P(PSBTMP(X,1),U,2)_"^"
.S PSBORDN=$P(PSBTMP(X,0),U,3) S PSBORDS(PSBORDN)=""
.I $D(PSBTMP(X,700)) D Q
..F XX=1:1:PSBTMP(X,700,0) D
...S PSBCLS="" F S PSBCLS=$O(TMP("VA CLASS",$J,PSBCLS)) Q:+PSBCLS=0 D
....I '$D(TMP("VA CLASS",$J,PSBCLS,"DDRG",$P(PSBTMP(X,700,XX,0),U))) Q
....S PSBORDS(PSBORDN,"DD",$P(PSBTMP(X,700,XX,0),U))=""
....S PSBORDS(PSBORDN,"OIP",$P(PSBTMP(X,3),U))=""
..M PSBOIP("OIP")=PSBORDS(PSBORDN,"OIP")
.I $D(PSBTMP(X,850)) M PSBORDS(PSBORDN,"ADD")=PSBTMP(X,850) D
..F XX=1:1:PSBORDS(PSBORDN,"ADD",0) S PSBORDS(PSBORDN,"OIP",$$OFROMA($P(PSBORDS(PSBORDN,"ADD",XX,0),U)))=""
..M PSBOIP("OIP")=PSBORDS(PSBORDN,"OIP")
.I $D(PSBTMP(X,950)) M PSBORDS(PSBORDN,"SOL")=PSBTMP(X,950) D
..F XX=1:1:PSBORDS(PSBORDN,"SOL",0) S PSBORDS(PSBORDN,"OIP",$$OFROMS($P(PSBORDS(PSBORDN,"SOL",XX,0),U)))=""
..M PSBOIP("OIP")=PSBORDS(PSBORDN,"OIP")
K PSBTMP
M TMP("PSBOIS",$J)=PSBOIP("OIP")
Q
OFROMA(PSBADD) ;OITEM FROM AN ADDITIVE
S X1=$$GET1^DIQ(52.6,PSBADD_",",15,"I")
I PSBCLSS D
.S X2=$$GETDRN(X1)
.S PSBCLS="" K X3 F Q:$D(X3) S PSBCLS=$O(TMP("VA CLASS",$J,PSBCLS)) Q:+PSBCLS=0 D
..I $D(TMP("VA CLASS",$J,PSBCLS,"DDRG",X2)) S X3=X1
.I '$D(X3) S X3=0
Q $G(X3,X1)
OFROMS(PSBSOL) ;OITEM FROM A SOLUTION
S X1=$$GET1^DIQ(52.7,PSBSOL_",",9,"I")
I PSBCLSS D
.S X2=$$GETDRN(X1)
.S PSBCLS="" K X3 F Q:$D(X3) S PSBCLS=$O(TMP("VA CLASS",$J,PSBCLS)) Q:+PSBCLS=0 D
..I $D(TMP("VA CLASS",$J,PSBCLS,"DDRG",X2)) S X3=X1
.I '$D(X3) S X3=0
Q $G(X3,X1)
PREOUT ;
K PSBUNK S XDT="" F S XDT=$O(TMP("PSBIENS",$J,XDT),-1) Q:XDT="" S XIEN="",XIEN=$O(TMP("PSBIENS",$J,XDT,XIEN)) D
.Q:$$NONSTS(PSBXDFN,XIEN)
.S PSBIEN=XIEN
.S PSBIENS=PSBIEN_","
.D OUTPUT
Q
OUTPUT ;
S PSBSPC=$J("",80)
S W=$E($$GET1^DIQ(53.79,PSBIENS,.02)_PSBSPC,1,20)_" "
S W=W_$S($P(^PSB(53.79,PSBIEN,0),U,9)="":"?? ",1:$E($P(^PSB(53.79,PSBIEN,0),U,9)_" ",1,2)_" ")
S:$P(^PSB(53.79,PSBIEN,0),U,9)="" PSBUNK=1
S W=W_$E($P($G(^PSB(53.79,PSBIEN,.1)),U,2)_PSBSPC,1,2)_" "
S W=W_$E($E($$GET1^DIQ(53.79,PSBIENS,.06),1,18)_PSBSPC,1,21)_" "
S W=W_$E($$GETINIT^PSBCSUTX(PSBIEN,"I")_PSBSPC,1,10)_" ",PSBLGD("INITIALS",$$GETINIT^PSBCSUTX(PSBIEN,"II"))="" ;Get IEN and initials of who took action, PSB*3*72
;Inj or Derm site info *83
S W=W_$S($P($G(^PSB(53.79,PSBIEN,.1)),U,8)]"":$P(^(.1),U,8),1:$P(^(.1),U,6))
;
D ADD(W)
S W=$J("",56)
;
;find Give associated with remove event *83
D:$P(^PSB(53.79,PSBIEN,0),U,9)="RM"
.N RMEV,INI
.S RMEV=$$FINDGIVE^PSBUTL(PSBIEN)
.S Y=$P(RMEV,U)+.0000001 ;give dt/tm
.S INI=$P(RMEV,U,2) ;give by user ini
.S X=$P(RMEV,U,3) ;give sts code
.S W=$E(PSBSPC,1,21)_$E(X_" ",1,2)_" "
.S W=W_$E($P($G(^PSB(53.79,PSBIEN,.1)),U,2)_PSBSPC,1,2)_" "
.S W=W_$$UP^XLFSTR($E($$FMTE^XLFDT(Y),1,18))_" "_$E(INI_PSBSPC,1,6)
.S PSBLGD("INITIALS",$P(RMEV,U,5))="" ;give by user in (Legend use)
;
K PSBV
F PSBNODE=.5,.6,.7 D
.S PSBDD=$S(PSBNODE=.5:53.795,PSBNODE=.6:53.796,1:53.797)
.F PSBY=0:0 S PSBY=$O(^PSB(53.79,PSBIEN,PSBNODE,PSBY)) Q:'PSBY D
..I $$GET1^DIQ(53.79,PSBIENS,.11)["V" S PSBV=1
..;add W possible remove string to wrapmeds *83
..D WRAPMEDS(W,$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.01),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.03),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.02),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.04))
D PRNEFF
I PSBCFLG=1 D COMNTS
D ADD("")
Q
PRNEFF ;Add PRN Effectiveness to Medication theropy Report - PSB*3*50
N PSBPRN,PSBEIECMT,PSBLINE1,PSBLINE2
S PSBEIECMT=""
I $P($G(PSBRPT(.2)),U,8)=0,$D(^PSB(53.79,PSBIEN,.2)) S PSBEIECMT=$$PRNEFF^PSBO(PSBEIECMT,PSBIEN)
I $D(^PSB(53.79,PSBIEN,.2)) D
.D ADD("")
.D ADD($J("",35)_"PRN Effectiveness: "_$$MAKELINE^PSBOMT1("-",78))
.I $P(^PSB(53.79,PSBIEN,.2),U,2)'="" D
..S PSBPRN=$P(^PSB(53.79,PSBIEN,.2),U,2)
.I $P(^PSB(53.79,PSBIEN,.2),U,2)="" S PSBPRN="<No PRN Effectiveness Entered>"
.S PSBLINE1=$E(PSBPRN_PSBEIECMT,1,75),PSBLINE2=$E(PSBPRN_PSBEIECMT,76,245) D WRAP(PSBLINE2,PSBLINE1,PSBIEN)
Q
COMNTS ;
N Z,CNT
S Z="",CNT=0
I $D(^PSB(53.79,PSBIEN,.3,0)) D
.D ADD("")
.D ADD($J("",45)_"Comments: "_$$MAKELINE^PSBOMT1("-",78))
.S XT="" F S XT=$O(^PSB(53.79,PSBIEN,.3,XT)) Q:XT="" I XT'=0 D
..D:CNT=1 ADD("")
..S Y=$P(^PSB(53.79,PSBIEN,.3,XT,0),"^",3) D DD^%DT S XBR=Y
..S Z=XBR_" "_$P(^VA(200,$P(^PSB(53.79,PSBIEN,.3,XT,0),"^",2),0),"^",2)
..D WRAP($P(^PSB(53.79,PSBIEN,.3,XT,0),"^",1),Z,PSBIEN)
..S CNT=1
..S PSBLGD("INITIALS",$$GET1^DIQ(53.793,XT_","_PSBIEN_",",.02,"I"))="" ;Get name for legend for those who entered comments
.D ADD($J("",55)_$$MAKELINE^PSBOMT1("-",78))
Q
WRAPMEDS(W,MED,UG,UO,UOA) ;insert parm W (possible RM string) to print on line 1 *83
;THIS WILL CREATE UPTO 3 LINES
S MED=$E(MED_$J("",40),1,40)
N UGWRAP,ORWRAP
S (CNTX,UOA1,UOA16,UOA31)=""
I +$G(UG)?1"."1.N S UG=0_+UG
I +$G(UO)?1"."1.N S UO=0_+UO
I $G(PSBV,0) S UO="NA"
F CNT=1:15:45 D
.D PARSE^PSBOMT1(UOA,CNT)
.S UGWRAP=$E(UG,CNT,(CNT+7)),UOWRAP=$E(UO,CNT,(CNT+7))
.I CNT=1 D ADD(W_MED_" "_$$PAD^PSBOMT1(UOWRAP,8)_" "_$$PAD^PSBOMT1(UGWRAP,8)_" "_$$PAD^PSBOMT1(UOA1,15)) ;*83
.I (CNT>1),($L(UGWRAP)>0!$L(@("UOA"_CNT))>0) D ADD($J("",94)_$$PAD^PSBOMT1(UOWRAP,8)_" "_$$PAD^PSBOMT1(UGWRAP,8)_" "_$$PAD^PSBOMT1(@("UOA"_CNT),15))
Q
HEADA ;
W !
W "Location",?21,"St Sch Administration Date",?50,"By",?61,"Body Site",?96,"Units",?104,"Units",?113,"Units of" ;*83
W !,?56,"Medication & Dosage",?96,"Ordered",?104,"Given",?113,"Administration"
W !
W $$MAKELINE^PSBOMT1("-",132)
Q
NONSTS(PSBX,PSBY) ;
D CLEAN^PSBVT,PSJ1^PSBVT(PSBX,$$GET1^DIQ(53.79,PSBY_",","ORDER REFERENCE NUMBER","I"))
Q $G(PSBOCRIT)'[PSBSCHT_"^" ;Protect variable if no schedule types are passed, PSB*3*98
WRITEOT ;
D HDR^PSBOMT1
D MEDS
N PSBCLINORD S PSBCLINORD=2 ;2 = both order types *70
D PT^PSBOHDR(PSBXDFN,.PSBHDR),HEADA
I '$D(TMP("PSBIENS",$J)) D ADD("<<<< NO HISTORY FOUND FOR THIS TIME FRAME >>>>")
S EX="" F S EX=$O(^TMP("PSB",$J,EX)) Q:EX="" D
.I $Y>(IOSL-5) D
..W $$PTFTR^PSBOHDR()
..D PT^PSBOHDR(PSBXDFN,.PSBHDR),HEADA
.W !,$G(^TMP("PSB",$J,EX))
D:$D(TMP("PSBIENS",$J)) LEGEND^PSBOMT1
D FTR^PSBOMT1
Q
MEDS ;
N MED,XA,XB
S MED="",XB=$O(PSBHDR(""),-1)+1
S PSBHDR(XB)=PSBSRCHL
I PSBCLSS S XA=0 K PSBGOT F S XA=$O(TMP("VA CLASS",$J,XA)) Q:+XA=0 D
.K ^TMP($J,"PSBLIST") D IEN^PSN50P65(XA,"??","PSBLIST")
.I ^TMP($J,"PSBLIST",0)>0 S MED=^TMP($J,"PSBLIST",XA,1) Q:$D(PSBGOT(MED)) K ^TMP($J,"PSBLIST")
.I $L(PSBHDR(XB)_" "_$G(MED," * NO DATA FOUND * "))+3>IOM D Q
..S XB=XB+1,PSBHDR(XB)=" / "_MED S PSBGOT(MED)=""
.S PSBHDR(XB)=PSBHDR(XB)_$S(($L(PSBHDR(XB),":")=2)&($P(PSBHDR(XB),":",2)=""):" ",1:" / ")_MED,PSBGOT(MED)=""
I $D(PSBOIL) S XA="" K PSBGOT F S XA=$O(PSBOIL(XA)) Q:XA="" D
.S MED=$$GET1^DIQ(50.7,XA,.01) Q:$D(PSBGOT(MED)) S PSBGOT(MED)=""
.I $L(PSBHDR(XB)_" / "_MED)+3>IOM D Q
..S XB=XB+1,PSBHDR(XB)=" / "_MED
.S PSBHDR(XB)=PSBHDR(XB)_$S(($L(PSBHDR(XB),":")=2)&($P(PSBHDR(XB),":",2)=""):" ",1:" / ")_MED
I $D(PSBADDL) S XA="" K PSBGOT F S XA=$O(PSBADDL(XA)) Q:XA="" D
.S MED=$$GET1^DIQ(52.6,XA,.01) Q:$D(PSBGOT(MED)) S PSBGOT(MED)=""
.I $L(PSBHDR(XB)_" / "_MED)+3>IOM D Q
..S XB=XB+1,PSBHDR(XB)=" / "_MED
.S PSBHDR(XB)=PSBHDR(XB)_$S(($L(PSBHDR(XB),":")=2)&($P(PSBHDR(XB),":",2)=""):" ",1:" / ")_MED
I $D(PSBSOLL) S XA="" K PSBGOT F S XA=$O(PSBSOLL(XA)) Q:XA="" D
.S MED=$$GET1^DIQ(52.7,XA,.01) Q:$D(PSBGOT(MED)) S PSBGOT(MED)=""
.I $L(PSBHDR(XB)_" / "_MED)+3>IOM D Q
..S XB=XB+1,PSBHDR(XB)=" / "_MED
.S PSBHDR(XB)=PSBHDR(XB)_$S(($L(PSBHDR(XB),":")=2)&($P(PSBHDR(XB),":",2)=""):" ",1:" / ")_MED
I $D(PSBDDL) S XA="" F S XA=$O(PSBDDL(XA)) Q:XA="" D
.S MED=$$GET1^DIQ(50,XA,.01)
.I $L(PSBHDR(XB)_" / "_MED)+3>IOM D Q
..S XB=XB+1,PSBHDR(XB)=" / "_MED
.S PSBHDR(XB)=PSBHDR(XB)_$S(($L(PSBHDR(XB),":")=2)&($P(PSBHDR(XB),":",2)=""):" ",1:" / ")_MED
Q
WRAP(SIZE,ZP,BRIEN) ;
D ADD($J("",56)_ZP)
D ADD($J("",56)_$E(SIZE,1,75))
I $L(SIZE)>75 D ADD($J("",56)_$E(SIZE,76,150))
Q
ADD(XE) ;
S ^TMP("PSB",$J,$O(^TMP("PSB",$J,""),-1)+1)=XE
Q
GETDRN(IEN1) ;
; Get the Drug IEN (p50) via OI IEN (p50.7)
K ^TMP($J,"PSBLIST")
D DRGIEN^PSS50P7(IEN1,,"PSBLIST")
S DN=$O(^TMP($J,"PSBLIST",0))
K ^TMP($J,"PSBLIST")
Q DN
GETCLSS(IEN1) ;
; Get the Items w/i VA Class
K ^TMP($J,"PSBLIST")
D VAC^PSS50(IEN1,,,"PSBLIST")
M PSBDDRG=^TMP($J,"PSBLIST")
K ^TMP($J,"PSBLIST")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBOMT 11612 printed Apr 09, 2024@20:44:51 Page 2
PSBOMT ;BIRMINGHAM/TEJ-BCMA MEDICATION THERAPY REPORT ;03/06/16 3:06pm
+1 ;;3.0;BAR CODE MED ADMIN;**32,50,70,72,83,97,98**;Mar 2004;Build 2
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; File 50.7/2880
+6 ; File 52.6/436
+7 ; File 52.7/437
+8 ; File 200/10060
+9 ; EN^PSJBCMA1/2829
+10 ; IEN^PSN50P65/4543
+11 ; DRGIEN^PSS50P7/4662
+12 ; VAC^PSS50/4533
+13 ; ^PSDRUG(/221
+14 ;
+15 ;*70 - reset PSBCLINORD = 2 to signify combined orders report
+16 ;*83 - Add MRR meds remove times to report.
+17 ;
EN ;
+1 NEW PSBHDR,PSBORDS,PSBORD,PSBOIP
+2 NEW TMP
+3 KILL TMP("PSBOIS",$JOB),TMP("VA CLASS",$JOB),TMP("PSBADDS",$JOB),TMP("PSBSOLS",$JOB),PSBLGD,PSBOIL,PSBDDL,PSBSOLL,PSBADDL
+4 SET PSBCLSS=0
SET PSBCFLG=0
+5 SET PSBXDFN=$PIECE(PSBRPT(.1),U,2)
+6 SET PSBSTRT=$PIECE(PSBRPT(.1),U,6)+$PIECE(PSBRPT(.1),U,7)
SET PSBSTOP=$PIECE(PSBRPT(.1),U,8)+$PIECE(PSBRPT(.1),U,9)
+7 KILL PSBOCRIT
FOR Y=1:1:4
IF $PIECE(PSBRPT(.2),U,Y)
SET PSBOCRIT=$GET(PSBOCRIT,"")_$PIECE("C^P^OC^O",U,Y)_"^"
+8 DO NOW^%DTC
SET (Y,PSBNOWX)=%
DO DD^%DT
SET PSBDTTM=$EXTRACT(Y,1,18)
+9 if +PSBSTRT'>0
SET PSBSTRT=$$FMADD^XLFDT(X,-1)
+10 if +PSBSTOP'>0
SET PSBSTOP=$PIECE(%,".")
+11 IF $DATA(PSBRPT(.2))
IF $PIECE(PSBRPT(.2),U,8)
SET PSBCFLG=1
+12 IF $DATA(PSBRPT(2))
FOR XD=$ORDER(PSBRPT(2,0)):1:$ORDER(PSBRPT(2,"B"),-1)
SET PSBRPT(2,XD,0)=$TRANSLATE(PSBRPT(2,XD,0),"~",U)
if $PIECE(PSBRPT(2,XD,0),U)="MT"
Begin DoDot:1
+13 IF $PIECE(PSBRPT(2,XD,0),U,2)="OIT"
Begin DoDot:2
+14 SET PSBSRCHL="ORDERABLE ITEM SEARCH LIST:"
SET PSBOIL(+$PIECE(PSBRPT(2,XD,0),U,3))=""
+15 SET PSB=$PIECE(PSBRPT(2,XD,0),U,3)
FOR X=1:1:$LENGTH(PSB,",")
if $PIECE(PSB,",",X)=""
QUIT
SET (TMP("PSBOIS",$JOB,$PIECE(PSB,",",X)),PSBOIP("OIP",$PIECE(PSB,",",X)))=""
End DoDot:2
QUIT
+16 IF $PIECE(PSBRPT(2,XD,0),U,2)="ADD"
Begin DoDot:2
+17 SET PSBSRCHL="IV MEDICATION SEARCH LIST:"
+18 IF $DATA(^PSDRUG("A526",$PIECE(PSBRPT(2,XD,0),U,3)))
SET X2=$ORDER(^PSDRUG("A526",$PIECE(PSBRPT(2,XD,0),U,3),""))
SET PSBADDL(X2)=""
SET TMP("PSBOIS",$JOB,$$OFROMA(X2))=""
End DoDot:2
QUIT
+19 IF $PIECE(PSBRPT(2,XD,0),U,2)="SOL"
Begin DoDot:2
+20 SET PSBSRCHL="IV MEDICATION SEARCH LIST:"
+21 IF $DATA(^PSDRUG("A527",$PIECE(PSBRPT(2,XD,0),U,3)))
SET X2=$ORDER(^PSDRUG("A527",$PIECE(PSBRPT(2,XD,0),U,3),""))
SET PSBSOLL(X2)=""
SET TMP("PSBOIS",$JOB,$$OFROMS(X2))=""
End DoDot:2
QUIT
+22 IF $PIECE(PSBRPT(2,XD,0),U,2)="DD"
Begin DoDot:2
+23 SET PSBSRCHL="DISPENSED DRUG SEARCH LIST:"
SET PSBDDL($PIECE(PSBRPT(2,XD,0),U,3))=""
+24 KILL PSBDRGS
SET PSBDRGS=""
DO OILST^PSBRPCMO(.PSBDRGS,$PIECE(PSBRPT(2,XD,0),U,3),"UD")
+25 FOR X2=PSBDRGS(0):1:$ORDER(PSBDRGS(""),-1)
IF +PSBDRGS(1)'<0
SET TMP("PSBOIS",$JOB,$PIECE(PSBDRGS(X2),U,4))=""
End DoDot:2
KILL PSBDRGS
QUIT
+26 IF $PIECE(PSBRPT(2,XD,0),U,2)="VAC"
Begin DoDot:2
+27 SET PSBSRCHL="VA DRUG CLASS SEARCH LIST:"
+28 SET PSBCLS=$PIECE(PSBRPT(2,XD,0),U,3)
DO GETCLSS(PSBCLS)
KILL PSBDDRG("VAC")
MERGE TMP("VA CLASS",$JOB,PSBCLS,"DDRG")=PSBDDRG
KILL PSBDDRG
+29 SET PSBCLSS=1
End DoDot:2
End DoDot:1
+30 MERGE PSBOIP("OIP")=TMP("PSBOIS",$JOB)
+31 DO OUT(PSBXDFN,PSBSTRT,PSBSTOP)
+32 QUIT
OUT(PSBXDFN,PSBSTRT,PSBSTOP) ;
+1 ; POSSBLE CLASS ITEMS VIA AVAIL ORDERS
if PSBCLSS
DO GETOIS
+2 ; ALL ADDS AND SOLS
DO GETADSO^PSBOMT1
+3 ; FIND ALL MED LOG ENTRS
DO FINDIENS^PSBOMT1
+4 ; WRIT TO GLOBL
DO PREOUT
+5 DO WRITEOT
+6 DO CLEANSUM^PSBOMT1
+7 DO CLEANALL^PSBOMT1
+8 QUIT
GETOIS ;
+1 KILL ^TMP("PSJ",$JOB),PSBTMP
+2 DO EN^PSJBCMA(PSBXDFN,PSBSTRT)
+3 if ^TMP("PSJ",$JOB,1,0)<0
QUIT
+4 MERGE PSBTMP=^TMP("PSJ",$JOB)
KILL ^TMP("PSJ",$JOB)
+5 SET X=0
FOR
SET X=$ORDER(PSBTMP(X))
if +X=0
QUIT
Begin DoDot:1
+6 if $GET(PSBOCRIT,"")'[$PIECE(PSBTMP(X,1),U,2)_"^"
QUIT
+7 SET PSBORDN=$PIECE(PSBTMP(X,0),U,3)
SET PSBORDS(PSBORDN)=""
+8 IF $DATA(PSBTMP(X,700))
Begin DoDot:2
+9 FOR XX=1:1:PSBTMP(X,700,0)
Begin DoDot:3
+10 SET PSBCLS=""
FOR
SET PSBCLS=$ORDER(TMP("VA CLASS",$JOB,PSBCLS))
if +PSBCLS=0
QUIT
Begin DoDot:4
+11 IF '$DATA(TMP("VA CLASS",$JOB,PSBCLS,"DDRG",$PIECE(PSBTMP(X,700,XX,0),U)))
QUIT
+12 SET PSBORDS(PSBORDN,"DD",$PIECE(PSBTMP(X,700,XX,0),U))=""
+13 SET PSBORDS(PSBORDN,"OIP",$PIECE(PSBTMP(X,3),U))=""
End DoDot:4
End DoDot:3
+14 MERGE PSBOIP("OIP")=PSBORDS(PSBORDN,"OIP")
End DoDot:2
QUIT
+15 IF $DATA(PSBTMP(X,850))
MERGE PSBORDS(PSBORDN,"ADD")=PSBTMP(X,850)
Begin DoDot:2
+16 FOR XX=1:1:PSBORDS(PSBORDN,"ADD",0)
SET PSBORDS(PSBORDN,"OIP",$$OFROMA($PIECE(PSBORDS(PSBORDN,"ADD",XX,0),U)))=""
+17 MERGE PSBOIP("OIP")=PSBORDS(PSBORDN,"OIP")
End DoDot:2
+18 IF $DATA(PSBTMP(X,950))
MERGE PSBORDS(PSBORDN,"SOL")=PSBTMP(X,950)
Begin DoDot:2
+19 FOR XX=1:1:PSBORDS(PSBORDN,"SOL",0)
SET PSBORDS(PSBORDN,"OIP",$$OFROMS($PIECE(PSBORDS(PSBORDN,"SOL",XX,0),U)))=""
+20 MERGE PSBOIP("OIP")=PSBORDS(PSBORDN,"OIP")
End DoDot:2
End DoDot:1
+21 KILL PSBTMP
+22 MERGE TMP("PSBOIS",$JOB)=PSBOIP("OIP")
+23 QUIT
OFROMA(PSBADD) ;OITEM FROM AN ADDITIVE
+1 SET X1=$$GET1^DIQ(52.6,PSBADD_",",15,"I")
+2 IF PSBCLSS
Begin DoDot:1
+3 SET X2=$$GETDRN(X1)
+4 SET PSBCLS=""
KILL X3
FOR
if $DATA(X3)
QUIT
SET PSBCLS=$ORDER(TMP("VA CLASS",$JOB,PSBCLS))
if +PSBCLS=0
QUIT
Begin DoDot:2
+5 IF $DATA(TMP("VA CLASS",$JOB,PSBCLS,"DDRG",X2))
SET X3=X1
End DoDot:2
+6 IF '$DATA(X3)
SET X3=0
End DoDot:1
+7 QUIT $GET(X3,X1)
OFROMS(PSBSOL) ;OITEM FROM A SOLUTION
+1 SET X1=$$GET1^DIQ(52.7,PSBSOL_",",9,"I")
+2 IF PSBCLSS
Begin DoDot:1
+3 SET X2=$$GETDRN(X1)
+4 SET PSBCLS=""
KILL X3
FOR
if $DATA(X3)
QUIT
SET PSBCLS=$ORDER(TMP("VA CLASS",$JOB,PSBCLS))
if +PSBCLS=0
QUIT
Begin DoDot:2
+5 IF $DATA(TMP("VA CLASS",$JOB,PSBCLS,"DDRG",X2))
SET X3=X1
End DoDot:2
+6 IF '$DATA(X3)
SET X3=0
End DoDot:1
+7 QUIT $GET(X3,X1)
PREOUT ;
+1 KILL PSBUNK
SET XDT=""
FOR
SET XDT=$ORDER(TMP("PSBIENS",$JOB,XDT),-1)
if XDT=""
QUIT
SET XIEN=""
SET XIEN=$ORDER(TMP("PSBIENS",$JOB,XDT,XIEN))
Begin DoDot:1
+2 if $$NONSTS(PSBXDFN,XIEN)
QUIT
+3 SET PSBIEN=XIEN
+4 SET PSBIENS=PSBIEN_","
+5 DO OUTPUT
End DoDot:1
+6 QUIT
OUTPUT ;
+1 SET PSBSPC=$JUSTIFY("",80)
+2 SET W=$EXTRACT($$GET1^DIQ(53.79,PSBIENS,.02)_PSBSPC,1,20)_" "
+3 SET W=W_$SELECT($PIECE(^PSB(53.79,PSBIEN,0),U,9)="":"?? ",1:$EXTRACT($PIECE(^PSB(53.79,PSBIEN,0),U,9)_" ",1,2)_" ")
+4 if $PIECE(^PSB(53.79,PSBIEN,0),U,9)=""
SET PSBUNK=1
+5 SET W=W_$EXTRACT($PIECE($GET(^PSB(53.79,PSBIEN,.1)),U,2)_PSBSPC,1,2)_" "
+6 SET W=W_$EXTRACT($EXTRACT($$GET1^DIQ(53.79,PSBIENS,.06),1,18)_PSBSPC,1,21)_" "
+7 ;Get IEN and initials of who took action, PSB*3*72
SET W=W_$EXTRACT($$GETINIT^PSBCSUTX(PSBIEN,"I")_PSBSPC,1,10)_" "
SET PSBLGD("INITIALS",$$GETINIT^PSBCSUTX(PSBIEN,"II"))=""
+8 ;Inj or Derm site info *83
+9 SET W=W_$SELECT($PIECE($GET(^PSB(53.79,PSBIEN,.1)),U,8)]"":$PIECE(^(.1),U,8),1:$PIECE(^(.1),U,6))
+10 ;
+11 DO ADD(W)
+12 SET W=$JUSTIFY("",56)
+13 ;
+14 ;find Give associated with remove event *83
+15 if $PIECE(^PSB(53.79,PSBIEN,0),U,9)="RM"
Begin DoDot:1
+16 NEW RMEV,INI
+17 SET RMEV=$$FINDGIVE^PSBUTL(PSBIEN)
+18 ;give dt/tm
SET Y=$PIECE(RMEV,U)+.0000001
+19 ;give by user ini
SET INI=$PIECE(RMEV,U,2)
+20 ;give sts code
SET X=$PIECE(RMEV,U,3)
+21 SET W=$EXTRACT(PSBSPC,1,21)_$EXTRACT(X_" ",1,2)_" "
+22 SET W=W_$EXTRACT($PIECE($GET(^PSB(53.79,PSBIEN,.1)),U,2)_PSBSPC,1,2)_" "
+23 SET W=W_$$UP^XLFSTR($EXTRACT($$FMTE^XLFDT(Y),1,18))_" "_$EXTRACT(INI_PSBSPC,1,6)
+24 ;give by user in (Legend use)
SET PSBLGD("INITIALS",$PIECE(RMEV,U,5))=""
End DoDot:1
+25 ;
+26 KILL PSBV
+27 FOR PSBNODE=.5,.6,.7
Begin DoDot:1
+28 SET PSBDD=$SELECT(PSBNODE=.5:53.795,PSBNODE=.6:53.796,1:53.797)
+29 FOR PSBY=0:0
SET PSBY=$ORDER(^PSB(53.79,PSBIEN,PSBNODE,PSBY))
if 'PSBY
QUIT
Begin DoDot:2
+30 IF $$GET1^DIQ(53.79,PSBIENS,.11)["V"
SET PSBV=1
+31 ;add W possible remove string to wrapmeds *83
+32 DO WRAPMEDS(W,$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.01),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.03),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.02),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.04))
End DoDot:2
End DoDot:1
+33 DO PRNEFF
+34 IF PSBCFLG=1
DO COMNTS
+35 DO ADD("")
+36 QUIT
PRNEFF ;Add PRN Effectiveness to Medication theropy Report - PSB*3*50
+1 NEW PSBPRN,PSBEIECMT,PSBLINE1,PSBLINE2
+2 SET PSBEIECMT=""
+3 IF $PIECE($GET(PSBRPT(.2)),U,8)=0
IF $DATA(^PSB(53.79,PSBIEN,.2))
SET PSBEIECMT=$$PRNEFF^PSBO(PSBEIECMT,PSBIEN)
+4 IF $DATA(^PSB(53.79,PSBIEN,.2))
Begin DoDot:1
+5 DO ADD("")
+6 DO ADD($JUSTIFY("",35)_"PRN Effectiveness: "_$$MAKELINE^PSBOMT1("-",78))
+7 IF $PIECE(^PSB(53.79,PSBIEN,.2),U,2)'=""
Begin DoDot:2
+8 SET PSBPRN=$PIECE(^PSB(53.79,PSBIEN,.2),U,2)
End DoDot:2
+9 IF $PIECE(^PSB(53.79,PSBIEN,.2),U,2)=""
SET PSBPRN="<No PRN Effectiveness Entered>"
+10 SET PSBLINE1=$EXTRACT(PSBPRN_PSBEIECMT,1,75)
SET PSBLINE2=$EXTRACT(PSBPRN_PSBEIECMT,76,245)
DO WRAP(PSBLINE2,PSBLINE1,PSBIEN)
End DoDot:1
+11 QUIT
COMNTS ;
+1 NEW Z,CNT
+2 SET Z=""
SET CNT=0
+3 IF $DATA(^PSB(53.79,PSBIEN,.3,0))
Begin DoDot:1
+4 DO ADD("")
+5 DO ADD($JUSTIFY("",45)_"Comments: "_$$MAKELINE^PSBOMT1("-",78))
+6 SET XT=""
FOR
SET XT=$ORDER(^PSB(53.79,PSBIEN,.3,XT))
if XT=""
QUIT
IF XT'=0
Begin DoDot:2
+7 if CNT=1
DO ADD("")
+8 SET Y=$PIECE(^PSB(53.79,PSBIEN,.3,XT,0),"^",3)
DO DD^%DT
SET XBR=Y
+9 SET Z=XBR_" "_$PIECE(^VA(200,$PIECE(^PSB(53.79,PSBIEN,.3,XT,0),"^",2),0),"^",2)
+10 DO WRAP($PIECE(^PSB(53.79,PSBIEN,.3,XT,0),"^",1),Z,PSBIEN)
+11 SET CNT=1
+12 ;Get name for legend for those who entered comments
SET PSBLGD("INITIALS",$$GET1^DIQ(53.793,XT_","_PSBIEN_",",.02,"I"))=""
End DoDot:2
+13 DO ADD($JUSTIFY("",55)_$$MAKELINE^PSBOMT1("-",78))
End DoDot:1
+14 QUIT
WRAPMEDS(W,MED,UG,UO,UOA) ;insert parm W (possible RM string) to print on line 1 *83
+1 ;THIS WILL CREATE UPTO 3 LINES
+2 SET MED=$EXTRACT(MED_$JUSTIFY("",40),1,40)
+3 NEW UGWRAP,ORWRAP
+4 SET (CNTX,UOA1,UOA16,UOA31)=""
+5 IF +$GET(UG)?1"."1.N
SET UG=0_+UG
+6 IF +$GET(UO)?1"."1.N
SET UO=0_+UO
+7 IF $GET(PSBV,0)
SET UO="NA"
+8 FOR CNT=1:15:45
Begin DoDot:1
+9 DO PARSE^PSBOMT1(UOA,CNT)
+10 SET UGWRAP=$EXTRACT(UG,CNT,(CNT+7))
SET UOWRAP=$EXTRACT(UO,CNT,(CNT+7))
+11 ;*83
IF CNT=1
DO ADD(W_MED_" "_$$PAD^PSBOMT1(UOWRAP,8)_" "_$$PAD^PSBOMT1(UGWRAP,8)_" "_$$PAD^PSBOMT1(UOA1,15))
+12 IF (CNT>1)
IF ($LENGTH(UGWRAP)>0!$LENGTH(@("UOA"_CNT))>0)
DO ADD($JUSTIFY("",94)_$$PAD^PSBOMT1(UOWRAP,8)_" "_$$PAD^PSBOMT1(UGWRAP,8)_" "_$$PAD^PSBOMT1(@("UOA"_CNT),15))
End DoDot:1
+13 QUIT
HEADA ;
+1 WRITE !
+2 ;*83
WRITE "Location",?21,"St Sch Administration Date",?50,"By",?61,"Body Site",?96,"Units",?104,"Units",?113,"Units of"
+3 WRITE !,?56,"Medication & Dosage",?96,"Ordered",?104,"Given",?113,"Administration"
+4 WRITE !
+5 WRITE $$MAKELINE^PSBOMT1("-",132)
+6 QUIT
NONSTS(PSBX,PSBY) ;
+1 DO CLEAN^PSBVT
DO PSJ1^PSBVT(PSBX,$$GET1^DIQ(53.79,PSBY_",","ORDER REFERENCE NUMBER","I"))
+2 ;Protect variable if no schedule types are passed, PSB*3*98
QUIT $GET(PSBOCRIT)'[PSBSCHT_"^"
WRITEOT ;
+1 DO HDR^PSBOMT1
+2 DO MEDS
+3 ;2 = both order types *70
NEW PSBCLINORD
SET PSBCLINORD=2
+4 DO PT^PSBOHDR(PSBXDFN,.PSBHDR)
DO HEADA
+5 IF '$DATA(TMP("PSBIENS",$JOB))
DO ADD("<<<< NO HISTORY FOUND FOR THIS TIME FRAME >>>>")
+6 SET EX=""
FOR
SET EX=$ORDER(^TMP("PSB",$JOB,EX))
if EX=""
QUIT
Begin DoDot:1
+7 IF $Y>(IOSL-5)
Begin DoDot:2
+8 WRITE $$PTFTR^PSBOHDR()
+9 DO PT^PSBOHDR(PSBXDFN,.PSBHDR)
DO HEADA
End DoDot:2
+10 WRITE !,$GET(^TMP("PSB",$JOB,EX))
End DoDot:1
+11 if $DATA(TMP("PSBIENS",$JOB))
DO LEGEND^PSBOMT1
+12 DO FTR^PSBOMT1
+13 QUIT
MEDS ;
+1 NEW MED,XA,XB
+2 SET MED=""
SET XB=$ORDER(PSBHDR(""),-1)+1
+3 SET PSBHDR(XB)=PSBSRCHL
+4 IF PSBCLSS
SET XA=0
KILL PSBGOT
FOR
SET XA=$ORDER(TMP("VA CLASS",$JOB,XA))
if +XA=0
QUIT
Begin DoDot:1
+5 KILL ^TMP($JOB,"PSBLIST")
DO IEN^PSN50P65(XA,"??","PSBLIST")
+6 IF ^TMP($JOB,"PSBLIST",0)>0
SET MED=^TMP($JOB,"PSBLIST",XA,1)
if $DATA(PSBGOT(MED))
QUIT
KILL ^TMP($JOB,"PSBLIST")
+7 IF $LENGTH(PSBHDR(XB)_" "_$GET(MED," * NO DATA FOUND * "))+3>IOM
Begin DoDot:2
+8 SET XB=XB+1
SET PSBHDR(XB)=" / "_MED
SET PSBGOT(MED)=""
End DoDot:2
QUIT
+9 SET PSBHDR(XB)=PSBHDR(XB)_$SELECT(($LENGTH(PSBHDR(XB),":")=2)&($PIECE(PSBHDR(XB),":",2)=""):" ",1:" / ")_MED
SET PSBGOT(MED)=""
End DoDot:1
+10 IF $DATA(PSBOIL)
SET XA=""
KILL PSBGOT
FOR
SET XA=$ORDER(PSBOIL(XA))
if XA=""
QUIT
Begin DoDot:1
+11 SET MED=$$GET1^DIQ(50.7,XA,.01)
if $DATA(PSBGOT(MED))
QUIT
SET PSBGOT(MED)=""
+12 IF $LENGTH(PSBHDR(XB)_" / "_MED)+3>IOM
Begin DoDot:2
+13 SET XB=XB+1
SET PSBHDR(XB)=" / "_MED
End DoDot:2
QUIT
+14 SET PSBHDR(XB)=PSBHDR(XB)_$SELECT(($LENGTH(PSBHDR(XB),":")=2)&($PIECE(PSBHDR(XB),":",2)=""):" ",1:" / ")_MED
End DoDot:1
+15 IF $DATA(PSBADDL)
SET XA=""
KILL PSBGOT
FOR
SET XA=$ORDER(PSBADDL(XA))
if XA=""
QUIT
Begin DoDot:1
+16 SET MED=$$GET1^DIQ(52.6,XA,.01)
if $DATA(PSBGOT(MED))
QUIT
SET PSBGOT(MED)=""
+17 IF $LENGTH(PSBHDR(XB)_" / "_MED)+3>IOM
Begin DoDot:2
+18 SET XB=XB+1
SET PSBHDR(XB)=" / "_MED
End DoDot:2
QUIT
+19 SET PSBHDR(XB)=PSBHDR(XB)_$SELECT(($LENGTH(PSBHDR(XB),":")=2)&($PIECE(PSBHDR(XB),":",2)=""):" ",1:" / ")_MED
End DoDot:1
+20 IF $DATA(PSBSOLL)
SET XA=""
KILL PSBGOT
FOR
SET XA=$ORDER(PSBSOLL(XA))
if XA=""
QUIT
Begin DoDot:1
+21 SET MED=$$GET1^DIQ(52.7,XA,.01)
if $DATA(PSBGOT(MED))
QUIT
SET PSBGOT(MED)=""
+22 IF $LENGTH(PSBHDR(XB)_" / "_MED)+3>IOM
Begin DoDot:2
+23 SET XB=XB+1
SET PSBHDR(XB)=" / "_MED
End DoDot:2
QUIT
+24 SET PSBHDR(XB)=PSBHDR(XB)_$SELECT(($LENGTH(PSBHDR(XB),":")=2)&($PIECE(PSBHDR(XB),":",2)=""):" ",1:" / ")_MED
End DoDot:1
+25 IF $DATA(PSBDDL)
SET XA=""
FOR
SET XA=$ORDER(PSBDDL(XA))
if XA=""
QUIT
Begin DoDot:1
+26 SET MED=$$GET1^DIQ(50,XA,.01)
+27 IF $LENGTH(PSBHDR(XB)_" / "_MED)+3>IOM
Begin DoDot:2
+28 SET XB=XB+1
SET PSBHDR(XB)=" / "_MED
End DoDot:2
QUIT
+29 SET PSBHDR(XB)=PSBHDR(XB)_$SELECT(($LENGTH(PSBHDR(XB),":")=2)&($PIECE(PSBHDR(XB),":",2)=""):" ",1:" / ")_MED
End DoDot:1
+30 QUIT
WRAP(SIZE,ZP,BRIEN) ;
+1 DO ADD($JUSTIFY("",56)_ZP)
+2 DO ADD($JUSTIFY("",56)_$EXTRACT(SIZE,1,75))
+3 IF $LENGTH(SIZE)>75
DO ADD($JUSTIFY("",56)_$EXTRACT(SIZE,76,150))
+4 QUIT
ADD(XE) ;
+1 SET ^TMP("PSB",$JOB,$ORDER(^TMP("PSB",$JOB,""),-1)+1)=XE
+2 QUIT
GETDRN(IEN1) ;
+1 ; Get the Drug IEN (p50) via OI IEN (p50.7)
+2 KILL ^TMP($JOB,"PSBLIST")
+3 DO DRGIEN^PSS50P7(IEN1,,"PSBLIST")
+4 SET DN=$ORDER(^TMP($JOB,"PSBLIST",0))
+5 KILL ^TMP($JOB,"PSBLIST")
+6 QUIT DN
GETCLSS(IEN1) ;
+1 ; Get the Items w/i VA Class
+2 KILL ^TMP($JOB,"PSBLIST")
+3 DO VAC^PSS50(IEN1,,,"PSBLIST")
+4 MERGE PSBDDRG=^TMP($JOB,"PSBLIST")
+5 KILL ^TMP($JOB,"PSBLIST")
+6 QUIT
