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

PSBOMT.m

Go to the documentation of this file.
  1. 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
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ; Reference/IA
  1. ; File 50.7/2880
  1. ; File 52.6/436
  1. ; File 52.7/437
  1. ; File 200/10060
  1. ; EN^PSJBCMA1/2829
  1. ; IEN^PSN50P65/4543
  1. ; DRGIEN^PSS50P7/4662
  1. ; VAC^PSS50/4533
  1. ; ^PSDRUG(/221
  1. ;
  1. ;*70 - reset PSBCLINORD = 2 to signify combined orders report
  1. ;*83 - Add MRR meds remove times to report.
  1. ;
  1. EN ;
  1. N PSBHDR,PSBORDS,PSBORD,PSBOIP
  1. N TMP
  1. K TMP("PSBOIS",$J),TMP("VA CLASS",$J),TMP("PSBADDS",$J),TMP("PSBSOLS",$J),PSBLGD,PSBOIL,PSBDDL,PSBSOLL,PSBADDL
  1. S PSBCLSS=0,PSBCFLG=0
  1. S PSBXDFN=$P(PSBRPT(.1),U,2)
  1. S PSBSTRT=$P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,7),PSBSTOP=$P(PSBRPT(.1),U,8)+$P(PSBRPT(.1),U,9)
  1. K PSBOCRIT F Y=1:1:4 I $P(PSBRPT(.2),U,Y) S PSBOCRIT=$G(PSBOCRIT,"")_$P("C^P^OC^O",U,Y)_"^"
  1. D NOW^%DTC S (Y,PSBNOWX)=% D DD^%DT S PSBDTTM=$E(Y,1,18)
  1. S:+PSBSTRT'>0 PSBSTRT=$$FMADD^XLFDT(X,-1)
  1. S:+PSBSTOP'>0 PSBSTOP=$P(%,".")
  1. I $D(PSBRPT(.2)) I $P(PSBRPT(.2),U,8) S PSBCFLG=1
  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"
  1. .I $P(PSBRPT(2,XD,0),U,2)="OIT" D Q
  1. ..S PSBSRCHL="ORDERABLE ITEM SEARCH LIST:",PSBOIL(+$P(PSBRPT(2,XD,0),U,3))=""
  1. ..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)))=""
  1. .I $P(PSBRPT(2,XD,0),U,2)="ADD" D Q
  1. ..S PSBSRCHL="IV MEDICATION SEARCH LIST:"
  1. ..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))=""
  1. .I $P(PSBRPT(2,XD,0),U,2)="SOL" D Q
  1. ..S PSBSRCHL="IV MEDICATION SEARCH LIST:"
  1. ..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))=""
  1. .I $P(PSBRPT(2,XD,0),U,2)="DD" D K PSBDRGS Q
  1. ..S PSBSRCHL="DISPENSED DRUG SEARCH LIST:",PSBDDL($P(PSBRPT(2,XD,0),U,3))=""
  1. ..K PSBDRGS S PSBDRGS="" D OILST^PSBRPCMO(.PSBDRGS,$P(PSBRPT(2,XD,0),U,3),"UD")
  1. ..F X2=PSBDRGS(0):1:$O(PSBDRGS(""),-1) I +PSBDRGS(1)'<0 S TMP("PSBOIS",$J,$P(PSBDRGS(X2),U,4))=""
  1. .I $P(PSBRPT(2,XD,0),U,2)="VAC" D
  1. ..S PSBSRCHL="VA DRUG CLASS SEARCH LIST:"
  1. ..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
  1. ..S PSBCLSS=1
  1. M PSBOIP("OIP")=TMP("PSBOIS",$J)
  1. D OUT(PSBXDFN,PSBSTRT,PSBSTOP)
  1. Q
  1. OUT(PSBXDFN,PSBSTRT,PSBSTOP) ;
  1. D:PSBCLSS GETOIS ; POSSBLE CLASS ITEMS VIA AVAIL ORDERS
  1. D GETADSO^PSBOMT1 ; ALL ADDS AND SOLS
  1. D FINDIENS^PSBOMT1 ; FIND ALL MED LOG ENTRS
  1. D PREOUT ; WRIT TO GLOBL
  1. D WRITEOT
  1. D CLEANSUM^PSBOMT1
  1. D CLEANALL^PSBOMT1
  1. Q
  1. GETOIS ;
  1. K ^TMP("PSJ",$J),PSBTMP
  1. D EN^PSJBCMA(PSBXDFN,PSBSTRT)
  1. Q:^TMP("PSJ",$J,1,0)<0
  1. M PSBTMP=^TMP("PSJ",$J) K ^TMP("PSJ",$J)
  1. S X=0 F S X=$O(PSBTMP(X)) Q:+X=0 D
  1. .Q:$G(PSBOCRIT,"")'[$P(PSBTMP(X,1),U,2)_"^"
  1. .S PSBORDN=$P(PSBTMP(X,0),U,3) S PSBORDS(PSBORDN)=""
  1. .I $D(PSBTMP(X,700)) D Q
  1. ..F XX=1:1:PSBTMP(X,700,0) D
  1. ...S PSBCLS="" F S PSBCLS=$O(TMP("VA CLASS",$J,PSBCLS)) Q:+PSBCLS=0 D
  1. ....I '$D(TMP("VA CLASS",$J,PSBCLS,"DDRG",$P(PSBTMP(X,700,XX,0),U))) Q
  1. ....S PSBORDS(PSBORDN,"DD",$P(PSBTMP(X,700,XX,0),U))=""
  1. ....S PSBORDS(PSBORDN,"OIP",$P(PSBTMP(X,3),U))=""
  1. ..M PSBOIP("OIP")=PSBORDS(PSBORDN,"OIP")
  1. .I $D(PSBTMP(X,850)) M PSBORDS(PSBORDN,"ADD")=PSBTMP(X,850) D
  1. ..F XX=1:1:PSBORDS(PSBORDN,"ADD",0) S PSBORDS(PSBORDN,"OIP",$$OFROMA($P(PSBORDS(PSBORDN,"ADD",XX,0),U)))=""
  1. ..M PSBOIP("OIP")=PSBORDS(PSBORDN,"OIP")
  1. .I $D(PSBTMP(X,950)) M PSBORDS(PSBORDN,"SOL")=PSBTMP(X,950) D
  1. ..F XX=1:1:PSBORDS(PSBORDN,"SOL",0) S PSBORDS(PSBORDN,"OIP",$$OFROMS($P(PSBORDS(PSBORDN,"SOL",XX,0),U)))=""
  1. ..M PSBOIP("OIP")=PSBORDS(PSBORDN,"OIP")
  1. K PSBTMP
  1. M TMP("PSBOIS",$J)=PSBOIP("OIP")
  1. Q
  1. OFROMA(PSBADD) ;OITEM FROM AN ADDITIVE
  1. S X1=$$GET1^DIQ(52.6,PSBADD_",",15,"I")
  1. I PSBCLSS D
  1. .S X2=$$GETDRN(X1)
  1. .S PSBCLS="" K X3 F Q:$D(X3) S PSBCLS=$O(TMP("VA CLASS",$J,PSBCLS)) Q:+PSBCLS=0 D
  1. ..I $D(TMP("VA CLASS",$J,PSBCLS,"DDRG",X2)) S X3=X1
  1. .I '$D(X3) S X3=0
  1. Q $G(X3,X1)
  1. OFROMS(PSBSOL) ;OITEM FROM A SOLUTION
  1. S X1=$$GET1^DIQ(52.7,PSBSOL_",",9,"I")
  1. I PSBCLSS D
  1. .S X2=$$GETDRN(X1)
  1. .S PSBCLS="" K X3 F Q:$D(X3) S PSBCLS=$O(TMP("VA CLASS",$J,PSBCLS)) Q:+PSBCLS=0 D
  1. ..I $D(TMP("VA CLASS",$J,PSBCLS,"DDRG",X2)) S X3=X1
  1. .I '$D(X3) S X3=0
  1. Q $G(X3,X1)
  1. PREOUT ;
  1. 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
  1. .Q:$$NONSTS(PSBXDFN,XIEN)
  1. .S PSBIEN=XIEN
  1. .S PSBIENS=PSBIEN_","
  1. .D OUTPUT
  1. Q
  1. OUTPUT ;
  1. S PSBSPC=$J("",80)
  1. S W=$E($$GET1^DIQ(53.79,PSBIENS,.02)_PSBSPC,1,20)_" "
  1. S W=W_$S($P(^PSB(53.79,PSBIEN,0),U,9)="":"?? ",1:$E($P(^PSB(53.79,PSBIEN,0),U,9)_" ",1,2)_" ")
  1. S:$P(^PSB(53.79,PSBIEN,0),U,9)="" PSBUNK=1
  1. S W=W_$E($P($G(^PSB(53.79,PSBIEN,.1)),U,2)_PSBSPC,1,2)_" "
  1. S W=W_$E($E($$GET1^DIQ(53.79,PSBIENS,.06),1,18)_PSBSPC,1,21)_" "
  1. 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
  1. ;Inj or Derm site info *83
  1. S W=W_$S($P($G(^PSB(53.79,PSBIEN,.1)),U,8)]"":$P(^(.1),U,8),1:$P(^(.1),U,6))
  1. ;
  1. D ADD(W)
  1. S W=$J("",56)
  1. ;
  1. ;find Give associated with remove event *83
  1. D:$P(^PSB(53.79,PSBIEN,0),U,9)="RM"
  1. .N RMEV,INI
  1. .S RMEV=$$FINDGIVE^PSBUTL(PSBIEN)
  1. .S Y=$P(RMEV,U)+.0000001 ;give dt/tm
  1. .S INI=$P(RMEV,U,2) ;give by user ini
  1. .S X=$P(RMEV,U,3) ;give sts code
  1. .S W=$E(PSBSPC,1,21)_$E(X_" ",1,2)_" "
  1. .S W=W_$E($P($G(^PSB(53.79,PSBIEN,.1)),U,2)_PSBSPC,1,2)_" "
  1. .S W=W_$$UP^XLFSTR($E($$FMTE^XLFDT(Y),1,18))_" "_$E(INI_PSBSPC,1,6)
  1. .S PSBLGD("INITIALS",$P(RMEV,U,5))="" ;give by user in (Legend use)
  1. ;
  1. K PSBV
  1. F PSBNODE=.5,.6,.7 D
  1. .S PSBDD=$S(PSBNODE=.5:53.795,PSBNODE=.6:53.796,1:53.797)
  1. .F PSBY=0:0 S PSBY=$O(^PSB(53.79,PSBIEN,PSBNODE,PSBY)) Q:'PSBY D
  1. ..I $$GET1^DIQ(53.79,PSBIENS,.11)["V" S PSBV=1
  1. ..;add W possible remove string to wrapmeds *83
  1. ..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))
  1. D PRNEFF
  1. I PSBCFLG=1 D COMNTS
  1. D ADD("")
  1. Q
  1. PRNEFF ;Add PRN Effectiveness to Medication theropy Report - PSB*3*50
  1. N PSBPRN,PSBEIECMT,PSBLINE1,PSBLINE2
  1. S PSBEIECMT=""
  1. I $P($G(PSBRPT(.2)),U,8)=0,$D(^PSB(53.79,PSBIEN,.2)) S PSBEIECMT=$$PRNEFF^PSBO(PSBEIECMT,PSBIEN)
  1. I $D(^PSB(53.79,PSBIEN,.2)) D
  1. .D ADD("")
  1. .D ADD($J("",35)_"PRN Effectiveness: "_$$MAKELINE^PSBOMT1("-",78))
  1. .I $P(^PSB(53.79,PSBIEN,.2),U,2)'="" D
  1. ..S PSBPRN=$P(^PSB(53.79,PSBIEN,.2),U,2)
  1. .I $P(^PSB(53.79,PSBIEN,.2),U,2)="" S PSBPRN="<No PRN Effectiveness Entered>"
  1. .S PSBLINE1=$E(PSBPRN_PSBEIECMT,1,75),PSBLINE2=$E(PSBPRN_PSBEIECMT,76,245) D WRAP(PSBLINE2,PSBLINE1,PSBIEN)
  1. Q
  1. COMNTS ;
  1. N Z,CNT
  1. S Z="",CNT=0
  1. I $D(^PSB(53.79,PSBIEN,.3,0)) D
  1. .D ADD("")
  1. .D ADD($J("",45)_"Comments: "_$$MAKELINE^PSBOMT1("-",78))
  1. .S XT="" F S XT=$O(^PSB(53.79,PSBIEN,.3,XT)) Q:XT="" I XT'=0 D
  1. ..D:CNT=1 ADD("")
  1. ..S Y=$P(^PSB(53.79,PSBIEN,.3,XT,0),"^",3) D DD^%DT S XBR=Y
  1. ..S Z=XBR_" "_$P(^VA(200,$P(^PSB(53.79,PSBIEN,.3,XT,0),"^",2),0),"^",2)
  1. ..D WRAP($P(^PSB(53.79,PSBIEN,.3,XT,0),"^",1),Z,PSBIEN)
  1. ..S CNT=1
  1. ..S PSBLGD("INITIALS",$$GET1^DIQ(53.793,XT_","_PSBIEN_",",.02,"I"))="" ;Get name for legend for those who entered comments
  1. .D ADD($J("",55)_$$MAKELINE^PSBOMT1("-",78))
  1. Q
  1. 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
  1. S MED=$E(MED_$J("",40),1,40)
  1. N UGWRAP,ORWRAP
  1. S (CNTX,UOA1,UOA16,UOA31)=""
  1. I +$G(UG)?1"."1.N S UG=0_+UG
  1. I +$G(UO)?1"."1.N S UO=0_+UO
  1. I $G(PSBV,0) S UO="NA"
  1. F CNT=1:15:45 D
  1. .D PARSE^PSBOMT1(UOA,CNT)
  1. .S UGWRAP=$E(UG,CNT,(CNT+7)),UOWRAP=$E(UO,CNT,(CNT+7))
  1. .I CNT=1 D ADD(W_MED_" "_$$PAD^PSBOMT1(UOWRAP,8)_" "_$$PAD^PSBOMT1(UGWRAP,8)_" "_$$PAD^PSBOMT1(UOA1,15)) ;*83
  1. .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))
  1. Q
  1. HEADA ;
  1. W !
  1. W "Location",?21,"St Sch Administration Date",?50,"By",?61,"Body Site",?96,"Units",?104,"Units",?113,"Units of" ;*83
  1. W !,?56,"Medication & Dosage",?96,"Ordered",?104,"Given",?113,"Administration"
  1. W !
  1. W $$MAKELINE^PSBOMT1("-",132)
  1. Q
  1. NONSTS(PSBX,PSBY) ;
  1. D CLEAN^PSBVT,PSJ1^PSBVT(PSBX,$$GET1^DIQ(53.79,PSBY_",","ORDER REFERENCE NUMBER","I"))
  1. Q $G(PSBOCRIT)'[PSBSCHT_"^" ;Protect variable if no schedule types are passed, PSB*3*98
  1. WRITEOT ;
  1. D HDR^PSBOMT1
  1. D MEDS
  1. N PSBCLINORD S PSBCLINORD=2 ;2 = both order types *70
  1. D PT^PSBOHDR(PSBXDFN,.PSBHDR),HEADA
  1. I '$D(TMP("PSBIENS",$J)) D ADD("<<<< NO HISTORY FOUND FOR THIS TIME FRAME >>>>")
  1. S EX="" F S EX=$O(^TMP("PSB",$J,EX)) Q:EX="" D
  1. .I $Y>(IOSL-5) D
  1. ..W $$PTFTR^PSBOHDR()
  1. ..D PT^PSBOHDR(PSBXDFN,.PSBHDR),HEADA
  1. .W !,$G(^TMP("PSB",$J,EX))
  1. D:$D(TMP("PSBIENS",$J)) LEGEND^PSBOMT1
  1. D FTR^PSBOMT1
  1. Q
  1. MEDS ;
  1. N MED,XA,XB
  1. S MED="",XB=$O(PSBHDR(""),-1)+1
  1. S PSBHDR(XB)=PSBSRCHL
  1. I PSBCLSS S XA=0 K PSBGOT F S XA=$O(TMP("VA CLASS",$J,XA)) Q:+XA=0 D
  1. .K ^TMP($J,"PSBLIST") D IEN^PSN50P65(XA,"??","PSBLIST")
  1. .I ^TMP($J,"PSBLIST",0)>0 S MED=^TMP($J,"PSBLIST",XA,1) Q:$D(PSBGOT(MED)) K ^TMP($J,"PSBLIST")
  1. .I $L(PSBHDR(XB)_" "_$G(MED," * NO DATA FOUND * "))+3>IOM D Q
  1. ..S XB=XB+1,PSBHDR(XB)=" / "_MED S PSBGOT(MED)=""
  1. .S PSBHDR(XB)=PSBHDR(XB)_$S(($L(PSBHDR(XB),":")=2)&($P(PSBHDR(XB),":",2)=""):" ",1:" / ")_MED,PSBGOT(MED)=""
  1. I $D(PSBOIL) S XA="" K PSBGOT F S XA=$O(PSBOIL(XA)) Q:XA="" D
  1. .S MED=$$GET1^DIQ(50.7,XA,.01) Q:$D(PSBGOT(MED)) S PSBGOT(MED)=""
  1. .I $L(PSBHDR(XB)_" / "_MED)+3>IOM D Q
  1. ..S XB=XB+1,PSBHDR(XB)=" / "_MED
  1. .S PSBHDR(XB)=PSBHDR(XB)_$S(($L(PSBHDR(XB),":")=2)&($P(PSBHDR(XB),":",2)=""):" ",1:" / ")_MED
  1. I $D(PSBADDL) S XA="" K PSBGOT F S XA=$O(PSBADDL(XA)) Q:XA="" D
  1. .S MED=$$GET1^DIQ(52.6,XA,.01) Q:$D(PSBGOT(MED)) S PSBGOT(MED)=""
  1. .I $L(PSBHDR(XB)_" / "_MED)+3>IOM D Q
  1. ..S XB=XB+1,PSBHDR(XB)=" / "_MED
  1. .S PSBHDR(XB)=PSBHDR(XB)_$S(($L(PSBHDR(XB),":")=2)&($P(PSBHDR(XB),":",2)=""):" ",1:" / ")_MED
  1. I $D(PSBSOLL) S XA="" K PSBGOT F S XA=$O(PSBSOLL(XA)) Q:XA="" D
  1. .S MED=$$GET1^DIQ(52.7,XA,.01) Q:$D(PSBGOT(MED)) S PSBGOT(MED)=""
  1. .I $L(PSBHDR(XB)_" / "_MED)+3>IOM D Q
  1. ..S XB=XB+1,PSBHDR(XB)=" / "_MED
  1. .S PSBHDR(XB)=PSBHDR(XB)_$S(($L(PSBHDR(XB),":")=2)&($P(PSBHDR(XB),":",2)=""):" ",1:" / ")_MED
  1. I $D(PSBDDL) S XA="" F S XA=$O(PSBDDL(XA)) Q:XA="" D
  1. .S MED=$$GET1^DIQ(50,XA,.01)
  1. .I $L(PSBHDR(XB)_" / "_MED)+3>IOM D Q
  1. ..S XB=XB+1,PSBHDR(XB)=" / "_MED
  1. .S PSBHDR(XB)=PSBHDR(XB)_$S(($L(PSBHDR(XB),":")=2)&($P(PSBHDR(XB),":",2)=""):" ",1:" / ")_MED
  1. Q
  1. WRAP(SIZE,ZP,BRIEN) ;
  1. D ADD($J("",56)_ZP)
  1. D ADD($J("",56)_$E(SIZE,1,75))
  1. I $L(SIZE)>75 D ADD($J("",56)_$E(SIZE,76,150))
  1. Q
  1. ADD(XE) ;
  1. S ^TMP("PSB",$J,$O(^TMP("PSB",$J,""),-1)+1)=XE
  1. Q
  1. GETDRN(IEN1) ;
  1. ; Get the Drug IEN (p50) via OI IEN (p50.7)
  1. K ^TMP($J,"PSBLIST")
  1. D DRGIEN^PSS50P7(IEN1,,"PSBLIST")
  1. S DN=$O(^TMP($J,"PSBLIST",0))
  1. K ^TMP($J,"PSBLIST")
  1. Q DN
  1. GETCLSS(IEN1) ;
  1. ; Get the Items w/i VA Class
  1. K ^TMP($J,"PSBLIST")
  1. D VAC^PSS50(IEN1,,,"PSBLIST")
  1. M PSBDDRG=^TMP($J,"PSBLIST")
  1. K ^TMP($J,"PSBLIST")
  1. Q