- 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 Feb 18, 2025@23:07:08 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