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
PSBOMT1 ;BIRMINGHAM/TEJ-BCMA MEDICATION THERAPY REPORT ;Mar 2004
+1 ;;3.0;BAR CODE MED ADMIN;**32**;Mar 2004;Build 32
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), 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
GETADSO ; GET ALL ADDITIVES FOR ALL ORDERABLE ITEMS
+1 KILL PSBAOUT,PSBSOUT
+2 SET XA=""
FOR
SET XA=$ORDER(PSBOIP("OIP",XA))
IF XA=""
QUIT
Begin DoDot:1
+3 DO LIST^DIC(52.6,"","@;15I","QPI","","","","AOI","","","PSBAOUT")
+4 SET XB=0
FOR
SET XB=$ORDER(PSBAOUT("DILIST",XB))
IF XB=""
QUIT
Begin DoDot:2
+5 IF $PIECE(PSBAOUT("DILIST",XB,0),"^",2)=XA
Begin DoDot:3
+6 SET TMP("PSBADDS",$JOB,$PIECE(PSBAOUT("DILIST",XB,0),"^",1))=""
End DoDot:3
End DoDot:2
End DoDot:1
+7 KILL PSBAOUT
+8 ; GET ALL SOLUTIONS FOR ALL ORDERABLE ITEMS
+9 SET XA=""
FOR
SET XA=$ORDER(PSBOIP("OIP",XA))
IF XA=""
QUIT
Begin DoDot:1
+10 DO LIST^DIC(52.7,"","@;9I","QPI","","","","AOI","","","PSBSOUT")
+11 SET XB=0
FOR
SET XB=$ORDER(PSBSOUT("DILIST",XB))
IF XB=""
QUIT
Begin DoDot:2
+12 IF $PIECE(PSBSOUT("DILIST",XB,0),"^",2)=XA
Begin DoDot:3
+13 SET TMP("PSBSOLS",$JOB,$PIECE(PSBSOUT("DILIST",XB,0),"^",1))=""
End DoDot:3
End DoDot:2
End DoDot:1
+14 KILL PSBSOUT
+15 QUIT
FINDIENS ; USE PSBOIS,PSBADDS AND PSBSOLS TO FIND ALL IENS FOR THE RPT
+1 ;SEARCH FOR UNIT DOSE IENS
+2 IF $DATA(TMP("PSBOIS",$JOB))
SET XA=""
FOR
SET XA=$ORDER(TMP("PSBOIS",$JOB,XA))
IF XA=""
QUIT
Begin DoDot:1
+3 SET PSBDT=PSBSTRT
FOR
SET PSBDT=$ORDER(^PSB(53.79,"AOIP",PSBXDFN,XA,PSBDT))
IF PSBDT=""!(PSBDT>PSBSTOP)
QUIT
Begin DoDot:2
+4 SET PSBIEN=""
FOR
SET PSBIEN=$ORDER(^PSB(53.79,"AOIP",PSBXDFN,XA,PSBDT,PSBIEN))
IF PSBIEN=""
QUIT
Begin DoDot:3
+5 IF $PIECE(^PSB(53.79,PSBIEN,0),U,9)="N"
QUIT
+6 SET TMP("PSBIENS",$JOB,$$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),PSBIEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+7 ;SEARCH FOR ADDITIVES
+8 IF $DATA(TMP("PSBADDS",$JOB))
SET XA=""
FOR
SET XA=$ORDER(TMP("PSBADDS",$JOB,XA))
IF XA=""
QUIT
Begin DoDot:1
+9 SET PSBIEN=""
FOR
SET PSBIEN=$ORDER(^PSB(53.79,"AOIP3",PSBXDFN,PSBIEN))
IF PSBIEN=""
QUIT
Begin DoDot:2
+10 SET XB=""
FOR
SET XB=$ORDER(^PSB(53.79,"AOIP3",PSBXDFN,PSBIEN,XB))
IF XB=""
QUIT
Begin DoDot:3
+11 IF XB'=XA
QUIT
+12 IF $PIECE(^PSB(53.79,PSBIEN,0),U,9)="N"
QUIT
+13 IF $PIECE(^PSB(53.79,PSBIEN,0),"^",6)>PSBSTRT
IF ($PIECE(^PSB(53.79,PSBIEN,0),"^",6)<PSBSTOP)
Begin DoDot:4
+14 SET TMP("PSBIENS",$JOB,$$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),PSBIEN)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 ;SEARCH FOR SOLUTIONS
+16 IF $DATA(TMP("PSBSOLS",$JOB))
SET XA=""
FOR
SET XA=$ORDER(TMP("PSBSOLS",$JOB,XA))
IF XA=""
QUIT
Begin DoDot:1
+17 SET PSBIEN=""
FOR
SET PSBIEN=$ORDER(^PSB(53.79,"AOIP4",PSBXDFN,PSBIEN))
IF PSBIEN=""
QUIT
Begin DoDot:2
+18 SET XB=""
FOR
SET XB=$ORDER(^PSB(53.79,"AOIP4",PSBXDFN,PSBIEN,XB))
IF XB=""
QUIT
Begin DoDot:3
+19 IF XB'=XA
QUIT
+20 IF $PIECE(^PSB(53.79,PSBIEN,0),U,9)="N"
QUIT
+21 IF $PIECE(^PSB(53.79,PSBIEN,0),"^",6)>PSBSTRT
IF ($PIECE(^PSB(53.79,PSBIEN,0),"^",6)<PSBSTOP)
Begin DoDot:4
+22 SET TMP("PSBIENS",$JOB,$$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),PSBIEN)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT
HDR ; Header
+1 IF $Y>1
WRITE @IOF
+2 IF $X>1
WRITE !
+3 SET PSBRPNM="BCMA MEDICATION THERAPY REPORT"
+4 SET PSBPGNUM=1
SET PSBOUTP(0)=""
SET PSBRPT(0)=""
+5 SET PSBPG="Page: "_PSBPGNUM_" of "_$SELECT($ORDER(PSBOUTP(""),-1)=0:1,1:$ORDER(PSBOUTP(""),-1))
+6 IF $PIECE(PSBRPT(0),U,4)=""
SET $PIECE(PSBRPT(0),U,4)=DUZ(2)
+7 SET PSBPGRM=IOM-($LENGTH(PSBPG))
+8 IF $PIECE(PSBRPT(.1),U,1)="P"
Begin DoDot:1
+9 KILL PSBHDR
+10 SET PSBHDR(1)="BCMA MEDICATION THERAPY REPORT for "
+11 SET Y=$PIECE(PSBRPT(.1),U,6)
DO D^DIQ
SET PSBHDR(1)=PSBHDR(1)_Y_"@"
SET Y=$PIECE(PSBRPT(.1),U,7)
SET PSBHDR(1)=PSBHDR(1)_$EXTRACT(Y_"0000",2,5)_" to "
+12 SET Y=$PIECE(PSBRPT(.1),U,8)
DO D^DIQ
SET PSBHDR(1)=PSBHDR(1)_Y_"@"
SET Y=$PIECE(PSBRPT(.1),U,9)
SET PSBHDR(1)=PSBHDR(1)_$EXTRACT(Y_"0000",2,5)
+13 SET PSBHDR(2)="Schedule Type(s): --"
+14 FOR Y=1:1:4
IF $PIECE(PSBRPT(.2),U,Y)
SET $PIECE(PSBHDR(2),": ",2)=$PIECE(PSBHDR(2),": ",2)_$SELECT(PSBHDR(2)["--":"",1:"/ ")_$PIECE("Continuous^PRN^On-Call^One-Time",U,Y)_" "
SET PSBHDR(2)=$TRANSLATE(PSBHDR(2),"-","")
+15 IF PSBCFLG
SET PSBHDR(3)="Include Comments"
SET PSBHDR(4)=" "
+16 IF '$TEST
SET PSBHDR(3)=" "
End DoDot:1
+17 QUIT
LEGEND ; Report Legend
+1 KILL PSBLGDO
+2 SET PSBLGD("ORDER TYPES","C")="Continuous"
+3 SET PSBLGD("ORDER TYPES","O")="One Time"
+4 SET PSBLGD("ORDER TYPES","OC")="On Call"
+5 SET PSBLGD("ORDER TYPES","P")="PRN (As Needed)"
+6 SET PSB=0
FOR
SET PSB=$ORDER(PSBLGD("INITIALS",PSB))
IF +PSB=0
QUIT
Begin DoDot:1
+7 SET PSBINIT=$$GET1^DIQ(200,PSB_",","INITIAL")
SET PSBLGD("INITIALS",$SELECT(PSBINIT']" ":"*n/a*",1:PSBINIT))=$$GET1^DIQ(200,PSB_",","NAME")
+8 KILL PSBLGD("INITIALS",PSB)
End DoDot:1
+9 SET PSBLGDO(0)="REPORT LEGEND"
+10 SET PSBLGDO(1)=""
+11 SET PSBLGDO(2)=$SELECT($GET(PSBNO,0):"",1:"SCHEDULE TYPES")
+12 SET PSBLGDO(3)=""
+13 IF '$GET(PSBNO,0)
SET X1=""
SET X2=3
FOR
SET X1=$ORDER(PSBLGD("ORDER TYPES",X1))
IF X1=""
QUIT
SET X2=X2+1
SET PSBLGDO(X2)=X1
SET $EXTRACT(PSBLGDO(X2),5)="- "_PSBLGD("ORDER TYPES",X1)
+14 IF $DATA(PSBLGD("INITIALS"))
SET $EXTRACT(PSBLGDO(2),35)="INITIALS"
SET X1=""
SET X2=3
FOR
SET X1=$ORDER(PSBLGD("INITIALS",X1))
IF X1=""
QUIT
SET X2=X2+1
SET $EXTRACT(PSBLGDO(X2),35)=X1
SET $EXTRACT(PSBLGDO(X2),40)="- "_PSBLGD("INITIALS",X1)
+15 IF ($Y+$ORDER(PSBLGDO(""),-1))>(IOSL-12)
Begin DoDot:1
+16 WRITE $$PTFTR^PSBOHDR()
+17 DO PT^PSBOHDR(PSBXDFN,.PSBHDR)
End DoDot:1
+18 IF IOSL<1000
FOR
IF ($Y+$ORDER(PSBLGDO(""),-1)+12)>IOSL
QUIT
WRITE !
+19 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","="),!
+20 FOR X1=$ORDER(PSBLGDO("")):1:$ORDER(PSBLGDO(""),-1)
WRITE !,PSBLGDO(X1)
+21 WRITE !!,$TRANSLATE($JUSTIFY("",IOM)," ","="),!
+22 QUIT
FTR ;
+1 IF (IOSL<100)
FOR
IF $Y>(IOSL-6)
QUIT
WRITE !
+2 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","=")
+3 SET X="Ward: "_PSBHDR("WARD")_" Room-Bed: "_PSBHDR("ROOM")
+4 WRITE !,PSBHDR("NAME"),?(IOM-11\2),PSBHDR("SSN"),?(IOM-$LENGTH(X)),X
+5 WRITE !,"BCMA MEDICATION THERAPY REPORT",?(IOM-$LENGTH(PSBDTTM)),PSBDTTM
+6 QUIT
MAKELINE(X,CNT) ;LINE OF WHAT'S PASSED IN CNT TIMES
+1 NEW Y,Z
+2 SET Y=""
+3 FOR Z=1:1:CNT
SET Y=Y_X
+4 QUIT Y
+5 ;
PARSE(X,CNT) ;Split text for wrapping.
+1 SET CNTX="UOA"_CNT
SET @CNTX=@CNTX_$EXTRACT(X,CNT,(CNT+14))
SET UOAX=""
+2 FOR
IF $FIND(@CNTX,", ",+UOAX)>0
SET UOAX=$FIND(@CNTX,", ",+UOAX)
IF '$FIND(@CNTX,", ",+UOAX)
QUIT
+3 IF UOAX<1
FOR
IF $FIND(@CNTX," ",+UOAX)>0
SET UOAX=$FIND(@CNTX," ",+UOAX)
IF '$FIND(@CNTX," ",+UOAX)
QUIT
+4 IF UOAX>1
IF (($LENGTH(UOA)-(CNT+14))>0)
SET CNTXX=$EXTRACT(@CNTX,1,UOAX-1)
SET @("UOA"_(CNT+15))=$EXTRACT(@CNTX,UOAX,UOAX+14)
SET @CNTX=CNTXX
+5 QUIT
+6 ;
PAD(X,CNT) ;
+1 QUIT $EXTRACT(X_$JUSTIFY("",CNT),1,CNT)
+2 ;
CLEANALL ; KILL ALL TMP LEVELS USED VARIABLES
+1 KILL ^TMP("PSB",$JOB),^TMP("PSJ1",$JOB),PSBOIP,TMP("PSBADDS",$JOB),TMP("PSBSOLS",$JOB)
+2 KILL TMP("PSBIENS",$JOB)
+3 QUIT
+4 ;
CLEANSUM ; KILL ALL BUN THE "PSBIENS" LEVEL
+1 KILL ^TMP("PSB",$JOB),^TMP("PSJ1",$JOB),TMP("PSBIENS",$JOB),TMP("PSBOIS",$JOB),TMP("PSBADDS",$JOB),TMP("PSBSOLS",$JOB)
+2 QUIT
