227 lines
9.4 KiB
Mathematica
227 lines
9.4 KiB
Mathematica
PSBOMT ;BIRMINGHAM/TEJ-BCMA MEDICATION THERAPY REPORT ;Mar 2004
|
|
;;3.0;BAR CODE MED ADMIN;**32**;Mar 2004;Build 32
|
|
;Per VHA Directive 2004-038 (or future revisions regarding same), 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
|
|
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($$GET1^DIQ(53.79,PSBIENS,"ACTION BY:INITIAL")_PSBSPC,1,10)_" ",PSBLGD("INITIALS",$$GET1^DIQ(53.79,PSBIENS,"ACTION BY","I"))=""
|
|
S W=W_$$GET1^DIQ(53.79,PSBIENS,.16)
|
|
D ADD(W)
|
|
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
|
|
..D WRAPMEDS($$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.01),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.03),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.02),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.04))
|
|
I PSBCFLG=1 D COMNTS
|
|
D ADD("")
|
|
Q
|
|
COMNTS ;
|
|
N Z,CNT
|
|
S Z="",CNT=0
|
|
I $D(^PSB(53.79,PSBIEN,.3,0)) D
|
|
.D ADD("")
|
|
.D ADD($J("",44)_"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
|
|
.D ADD($J("",54)_$$MAKELINE^PSBOMT1("-",78))
|
|
Q
|
|
WRAPMEDS(MED,UG,UO,UOA) ;
|
|
;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($J("",55)_MED_" "_$$PAD^PSBOMT1(UOWRAP,8)_" "_$$PAD^PSBOMT1(UGWRAP,8)_" "_$$PAD^PSBOMT1(UOA1,15))
|
|
.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,"Injection Site",?96,"Units",?104,"Units",?113,"Units of"
|
|
W !,?55,"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 PSBOCRIT'[PSBSCHT_"^"
|
|
WRITEOT ;
|
|
D HDR^PSBOMT1
|
|
D MEDS
|
|
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("",55)_ZP)
|
|
D ADD($J("",55)_$E(SIZE,1,75))
|
|
I $L(SIZE)>75 D ADD($J("",55)_$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
|