PSBOMT1 ;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
GETADSO ; GET ALL ADDITIVES FOR ALL ORDERABLE ITEMS
 K PSBAOUT,PSBSOUT
 S XA="" F  S XA=$O(PSBOIP("OIP",XA)) Q:XA=""  D
 .D LIST^DIC(52.6,"","@;15I","QPI","","","","AOI","","","PSBAOUT")
 .S XB=0 F  S XB=$O(PSBAOUT("DILIST",XB)) Q:XB=""  D
 ..I $P(PSBAOUT("DILIST",XB,0),"^",2)=XA D
 ...S TMP("PSBADDS",$J,$P(PSBAOUT("DILIST",XB,0),"^",1))=""
 K PSBAOUT
 ; GET ALL SOLUTIONS FOR ALL ORDERABLE ITEMS
 S XA="" F  S XA=$O(PSBOIP("OIP",XA)) Q:XA=""  D
 .D LIST^DIC(52.7,"","@;9I","QPI","","","","AOI","","","PSBSOUT")
 .S XB=0 F  S XB=$O(PSBSOUT("DILIST",XB)) Q:XB=""  D
 ..I $P(PSBSOUT("DILIST",XB,0),"^",2)=XA D
 ...S TMP("PSBSOLS",$J,$P(PSBSOUT("DILIST",XB,0),"^",1))=""
 K PSBSOUT
 Q
FINDIENS ; USE PSBOIS,PSBADDS AND PSBSOLS TO FIND ALL IENS FOR THE RPT
 ;SEARCH FOR UNIT DOSE IENS
 I $D(TMP("PSBOIS",$J)) S XA="" F  S XA=$O(TMP("PSBOIS",$J,XA)) Q:XA=""  D
 .S PSBDT=PSBSTRT F  S PSBDT=$O(^PSB(53.79,"AOIP",PSBXDFN,XA,PSBDT)) Q:PSBDT=""!(PSBDT>PSBSTOP)  D
 ..S PSBIEN="" F  S PSBIEN=$O(^PSB(53.79,"AOIP",PSBXDFN,XA,PSBDT,PSBIEN)) Q:PSBIEN=""  D
 ...Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N"
 ...S TMP("PSBIENS",$J,$$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),PSBIEN)=""
 ;SEARCH FOR ADDITIVES
 I $D(TMP("PSBADDS",$J)) S XA="" F  S XA=$O(TMP("PSBADDS",$J,XA)) Q:XA=""  D
 .S PSBIEN="" F  S PSBIEN=$O(^PSB(53.79,"AOIP3",PSBXDFN,PSBIEN)) Q:PSBIEN=""  D
 ..S XB="" F  S XB=$O(^PSB(53.79,"AOIP3",PSBXDFN,PSBIEN,XB)) Q:XB=""  D
 ...Q:XB'=XA
 ...Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N"
 ...I $P(^PSB(53.79,PSBIEN,0),"^",6)>PSBSTRT,($P(^PSB(53.79,PSBIEN,0),"^",6)<PSBSTOP)  D
 ....S TMP("PSBIENS",$J,$$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),PSBIEN)=""
 ;SEARCH FOR SOLUTIONS
 I $D(TMP("PSBSOLS",$J)) S XA="" F  S XA=$O(TMP("PSBSOLS",$J,XA)) Q:XA=""  D
 .S PSBIEN="" F  S PSBIEN=$O(^PSB(53.79,"AOIP4",PSBXDFN,PSBIEN)) Q:PSBIEN=""  D
 ..S XB="" F  S XB=$O(^PSB(53.79,"AOIP4",PSBXDFN,PSBIEN,XB)) Q:XB=""  D
 ...Q:XB'=XA
 ...Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N"
 ...I $P(^PSB(53.79,PSBIEN,0),"^",6)>PSBSTRT,($P(^PSB(53.79,PSBIEN,0),"^",6)<PSBSTOP)  D
 ....S TMP("PSBIENS",$J,$$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),PSBIEN)=""
 Q
HDR ;  Header
 W:$Y>1 @IOF
 W:$X>1 !
 S PSBRPNM="BCMA MEDICATION THERAPY REPORT"
 S PSBPGNUM=1,PSBOUTP(0)="",PSBRPT(0)=""
 S PSBPG="Page: "_PSBPGNUM_" of "_$S($O(PSBOUTP(""),-1)=0:1,1:$O(PSBOUTP(""),-1))
 I $P(PSBRPT(0),U,4)="" S $P(PSBRPT(0),U,4)=DUZ(2)
 S PSBPGRM=IOM-($L(PSBPG))
 D:$P(PSBRPT(.1),U,1)="P"
 .K PSBHDR
 .S PSBHDR(1)="BCMA MEDICATION THERAPY REPORT for "
 .S Y=$P(PSBRPT(.1),U,6) D D^DIQ S PSBHDR(1)=PSBHDR(1)_Y_"@" S Y=$P(PSBRPT(.1),U,7) S PSBHDR(1)=PSBHDR(1)_$E(Y_"0000",2,5)_" to "
 .S Y=$P(PSBRPT(.1),U,8) D D^DIQ S PSBHDR(1)=PSBHDR(1)_Y_"@" S Y=$P(PSBRPT(.1),U,9) S PSBHDR(1)=PSBHDR(1)_$E(Y_"0000",2,5)
 .S PSBHDR(2)="Schedule Type(s): --"
 .F Y=1:1:4 I $P(PSBRPT(.2),U,Y) S $P(PSBHDR(2),": ",2)=$P(PSBHDR(2),": ",2)_$S(PSBHDR(2)["--":"",1:"/ ")_$P("Continuous^PRN^On-Call^One-Time",U,Y)_" " S PSBHDR(2)=$TR(PSBHDR(2),"-","")
 .I PSBCFLG S PSBHDR(3)="Include Comments" S PSBHDR(4)=" "
 .E  S PSBHDR(3)=" "
 Q
LEGEND ; Report Legend
 K PSBLGDO
 S PSBLGD("ORDER TYPES","C")="Continuous"
 S PSBLGD("ORDER TYPES","O")="One Time"
 S PSBLGD("ORDER TYPES","OC")="On Call"
 S PSBLGD("ORDER TYPES","P")="PRN (As Needed)"
 S PSB=0 F  S PSB=$O(PSBLGD("INITIALS",PSB)) Q:+PSB=0  D
 .S PSBINIT=$$GET1^DIQ(200,PSB_",","INITIAL"),PSBLGD("INITIALS",$S(PSBINIT']" ":"*n/a*",1:PSBINIT))=$$GET1^DIQ(200,PSB_",","NAME")
 .K PSBLGD("INITIALS",PSB)
 S PSBLGDO(0)="REPORT LEGEND"
 S PSBLGDO(1)=""
 S PSBLGDO(2)=$S($G(PSBNO,0):"",1:"SCHEDULE TYPES")
 S PSBLGDO(3)=""
 I '$G(PSBNO,0) S X1="",X2=3 F  S X1=$O(PSBLGD("ORDER TYPES",X1)) Q:X1=""  S X2=X2+1,PSBLGDO(X2)=X1,$E(PSBLGDO(X2),5)="- "_PSBLGD("ORDER TYPES",X1)
 I $D(PSBLGD("INITIALS")) S $E(PSBLGDO(2),35)="INITIALS" S X1="",X2=3 F  S X1=$O(PSBLGD("INITIALS",X1)) Q:X1=""  S X2=X2+1,$E(PSBLGDO(X2),35)=X1,$E(PSBLGDO(X2),40)="- "_PSBLGD("INITIALS",X1)
 I ($Y+$O(PSBLGDO(""),-1))>(IOSL-12) D
 .W $$PTFTR^PSBOHDR()
 .D PT^PSBOHDR(PSBXDFN,.PSBHDR)
 I IOSL<1000 F  Q:($Y+$O(PSBLGDO(""),-1)+12)>IOSL  W !
 W !,$TR($J("",IOM)," ","="),!
 F X1=$O(PSBLGDO("")):1:$O(PSBLGDO(""),-1) W !,PSBLGDO(X1)
 W !!,$TR($J("",IOM)," ","="),!
 Q
FTR ;
 I (IOSL<100) F  Q:$Y>(IOSL-6)  W !
 W !,$TR($J("",IOM)," ","=")
 S X="Ward: "_PSBHDR("WARD")_"  Room-Bed: "_PSBHDR("ROOM")
 W !,PSBHDR("NAME"),?(IOM-11\2),PSBHDR("SSN"),?(IOM-$L(X)),X
 W !,"BCMA MEDICATION THERAPY REPORT",?(IOM-$L(PSBDTTM)),PSBDTTM
 Q
MAKELINE(X,CNT) ;LINE OF WHAT'S PASSED IN CNT TIMES
 N Y,Z
 S Y=""
 F Z=1:1:CNT S Y=Y_X
 Q Y
 ;
PARSE(X,CNT) ;Split text for wrapping.
 S CNTX="UOA"_CNT,@CNTX=@CNTX_$E(X,CNT,(CNT+14)),UOAX=""
 F  S:$F(@CNTX,", ",+UOAX)>0 UOAX=$F(@CNTX,", ",+UOAX)  Q:'$F(@CNTX,", ",+UOAX)
 I UOAX<1 F  S:$F(@CNTX," ",+UOAX)>0 UOAX=$F(@CNTX," ",+UOAX)  Q:'$F(@CNTX," ",+UOAX)
 I UOAX>1,(($L(UOA)-(CNT+14))>0) S CNTXX=$E(@CNTX,1,UOAX-1),@("UOA"_(CNT+15))=$E(@CNTX,UOAX,UOAX+14),@CNTX=CNTXX
 Q
 ;
PAD(X,CNT) ;
 Q $E(X_$J("",CNT),1,CNT)
 ;
CLEANALL ; KILL ALL TMP LEVELS USED VARIABLES
 K ^TMP("PSB",$J),^TMP("PSJ1",$J),PSBOIP,TMP("PSBADDS",$J),TMP("PSBSOLS",$J)
 K TMP("PSBIENS",$J)
 Q
 ;
CLEANSUM ; KILL ALL BUN THE "PSBIENS" LEVEL
 K ^TMP("PSB",$J),^TMP("PSJ1",$J),TMP("PSBIENS",$J),TMP("PSBOIS",$J),TMP("PSBADDS",$J),TMP("PSBSOLS",$J)
 Q