PSBOPM ;BIRMINGHAM/BSR-BCMA OIT HISTORY ; 5/2/07 9:52am
;;3.0;BAR CODE MED ADMIN;**3,9,13,17,40**;Mar 2004;Build 9
;;Per VHA Directive 2004-038, 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
;
EN ;
N PSBHDR,DFN
S PSBGBL="^TMP(""PSBO"",$J,""B"")"
F S PSBGBL=$Q(@PSBGBL) Q:PSBGBL="" Q:$QS(PSBGBL,2)'=$J Q:$QS(PSBGBL,1)'["PSBO" D
.S DFN=$QS(PSBGBL,5)
I '$G(DFN) W !,("Error: No Patient IEN") Q
S PSBSTRT=$P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,7)
S PSBSTOP=$P(PSBRPT(.1),U,8)+$P(PSBRPT(.1),U,9)
S PSBCOM=$P(PSBRPT(.2),"^",8) ;COMMENT FLAG 1 MEANS YES
I PSBSTRT="0" D
.D NOW^%DTC S PSBSTOP=%
.S X1=((PSBSTOP)\1) S X2=-$$GET^XPAR("ALL","PSB MED HIST DAYS BACK")
.S:X2'<0 X2=-30 D C^%DTC S PSBSTRT=X
.S PSBCOM=$$GET^XPAR("ALL","PSB RPT INCL COMMENTS")
D OUT(DFN,PSBSTRT,PSBSTOP,PSBORDNM)
Q
;
OUT(DFN,PSBSTRT,PSBSTOP,PSBORDNM) ;
D CLEANALL ;CLEAN UP VARIABLES AND TMP ARRAY
;
;IF PSBORDNM DOESN'T CONTAIN A "U" OR A "V", SKIP THE ORDER LOOKUP
S PSBOR=1
I PSBORDNM'["U",PSBORDNM'["V" D
.S:'$$GETORD^PSBOPM1(.PSBORDNM) PSBOR=0
.I 'PSBOR&(PSBORDNM]"") S TMP("PSBOIS",$J,PSBORDNM)=""
I PSBOR D
.D GETORDN
.D GETOIS
D GETADSO ; GET ALL ADDITIVES AND SOLUTIONS
D FINDIENS^PSBOPM1 ; FIND EVERY MED LOG ENTRIES THAT SHOULD BE ON THE RPT
D PREOUT ; WRITE DATA TO GLOBAL
D WRITEOT ;
D CLEANSUM ; CLEAN UP AND LEAVE LIST OF IENS FOR THE REPORT.
Q
;
GETORDN ;
K ^TMP("PSJ1",$J)
D EN^PSJBCMA1(DFN,PSBORDNM,1)
Q
;
GETOIS ; LOAD PSBOIS(#) WITH ALL OF THE ORDERABLE ITEMS
I PSBORDNM["U" D
.;GET UNIT DOSE ORDERS
.I $D(^TMP("PSJ1",$J,2)) D
..S PSBOI=$P(^TMP("PSJ1",$J,2),"^")
..S PSBOI=$S(PSBOI["U":$TR(PSBOI,"U",""),PSBOI["V":$TR(PSBOI,"V",""),1:PSBOI)
..S TMP("PSBOIS",$J,PSBOI)=""
;
;IV ORDERS NEED TO USE THE ADDITIVE AND SOLUTION NUMBER TO BACK
;TRACK TO THE OI ASSOCIATED WITH IT
I PSBORDNM["V" D
.;GET ADDITIVES OFF THE ORDER
.I $G(^TMP("PSJ1",$J,850,0)) D
..S XXX="" F S XXX=$O(^TMP("PSJ1",$J,850,XXX)) Q:XXX="" D
...S XXY="" F S XXY=$O(^TMP("PSJ1",$J,850,XXX,XXY)) Q:XXY="" D
....S PSBADD=$P(^TMP("PSJ1",$J,850,XXX,XXY),"^")
....;CONVERT ADDITIVE TO ORDERABLE ITEM AND ADD TO LIST
....S TMP("PSBOIS",$J,$$OFROMA(PSBADD))=""
.; GET SOLUTIONS OFF THE ORDER
.I $G(^TMP("PSJ1",$J,950,0)) D
..S XXX="" F S XXX=$O(^TMP("PSJ1",$J,950,XXX)) Q:XXX="" D
...S XXY="" F S XXY=$O(^TMP("PSJ1",$J,950,XXX,XXY)) Q:XXY="" D
....S PSBSOL=$P(^TMP("PSJ1",$J,950,XXX,XXY),"^")
....;
....;CONVERT SOLUTIOIN TO ORDERABLE ITEM AND ADD TO LIST
....S TMP("PSBOIS",$J,$$OFROMS(PSBSOL))=""
Q
;
OFROMA(PSBADD) ;GET ORDERABLE ITEM FROM AN ADDITIVE
Q $$GET1^DIQ(52.6,PSBADD_",",15,"I")
;
OFROMS(PSBSOL) ; GET ORDERABLE ITEM FROM A SOLUTION
Q $$GET1^DIQ(52.7,PSBSOL_",",9,"I")
;
GETADSO ; GET ALL ADDITIVES FOR ALL ORDERABLE ITEMS
K PSBAOUT,PSBSOUT
S XA="" F S XA=$O(TMP("PSBOIS",$J,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(TMP("PSBOIS",$J,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
;
PREOUT ;
N TYP
F TYP="UD","ADD","SOL" D
.Q:'$D(TMP("PSBIENS",$J,TYP))
.K PSBUNK S XDT="" F S XDT=$O(TMP("PSBIENS",$J,TYP,XDT),-1) Q:XDT="" D
..S I="" F S I=$O(TMP("PSBIENS",$J,TYP,XDT,I)) Q:I="" D
...I TYP="UD" Q:$D(TMP("PSBIENS",$J,"ADD",XDT,I)) Q:$D(TMP("PSBIENS",$J,"SOL",XDT,I))
...S PSBIEN=I
...S PSBIENS=PSBIEN_","
...D OUTPUT(TYP)
Q
;
OUTPUT(TYP) ;
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)_" "
S W=W_$$GET1^DIQ(53.79,PSBIENS,.16)
D ADD(W,TYP)
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
..D WRAPMEDS($$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.01),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.03),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.04),TYP)
I PSBCOM=1 D COMNTS ;GETS COMMENTS
D ADD("",TYP)
Q
;
COMNTS ;
N Z,CNT
S Z="",CNT=0
I $D(^PSB(53.79,PSBIEN,.3,0)) D
.D ADD("",TYP)
.D ADD($J("",44)_"Comments: "_$$MAKELINE("-",78),TYP)
.S XT="" F S XT=$O(^PSB(53.79,PSBIEN,.3,XT)) Q:XT="" I XT'=0 D
..D:CNT=1 ADD("",TYP)
..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("-",78),TYP)
Q
;
WRAP(SIZE,ZP,BRIEN) ;
D ADD($J("",55)_ZP,TYP)
D ADD($J("",55)_$E(SIZE,1,75),TYP)
I $L(SIZE)>75 D ADD($J("",55)_$E(SIZE,76,150),TYP)
Q
;
HEADA ;
W !
W "Location",?21,"St Sch Administration Date",?50,"By",?61,"Injection Site",?96,"Units",?112,"Units of"
W !,?55,"Medication & Dosage",?96,"GIVEN",?112,"Administration"
W !
W $$MAKELINE("-",132)
Q
;
ADD(XE,TYP) ;
S ^TMP("PSB",$J,TYP,$O(^TMP("PSB",$J,TYP,""),-1)+1)=XE
Q
;
WRAPMEDS(MED,UG,UOA,TYP) ;
;MED IS NOT WRAPPED: MAX LENGTH IN PSDRUG/52.6/52.7 IS 40
;UG/UOA MAX AT 30/40 AND WILL BE WRAPPED AT 15 EACH
;THIS WILL CREATE UPTO 3 LINES
S MED=$E(MED_$J("",40),1,40)
N UGWRAP
S (CNTX,UOA1,UOA16,UOA31)=""
I +$G(UG)?1"."1.N S UG=0_+UG
F CNT=1:15:45 D
.D PARSE(UOA,CNT)
.S UGWRAP=$E(UG,CNT,(CNT+14))
.I CNT=1 D ADD($J("",55)_MED_" "_$$PAD(UGWRAP,15)_" "_$$PAD(UOA1,15),TYP)
.I (CNT>1),($L(UGWRAP)>0!$L(@("UOA"_CNT))>0) D ADD($J("",96)_$$PAD(UGWRAP,15)_" "_$$PAD(@("UOA"_CNT),15),TYP)
Q
;
PAD(X,CNT) ;
Q $E(X_$J("",CNT),1,CNT)
WRITEOT ;
N TPE
S Y=$P(PSBSTRT,".",1) D D^DIQ S PSTRTA=Y
S Y=$P(PSBSTOP,".",1) D D^DIQ S PSTP=Y
S PSBHDR(1)="MEDICATION HISTORY for "_PSTRTA_" to "_PSTP
I '$D(TMP("PSBIENS",$J)) D ADD("<<<< NO HISTORY FOUND FOR THIS TIME FRAME >>>>","UD")
S TPE="" F S TPE=$O(^TMP("PSB",$J,TPE)) Q:TPE="" D
.D MEDS(TPE)
.D PT^PSBOHDR(DFN,.PSBHDR),HEADA
.S EX="" F S EX=$O(^TMP("PSB",$J,TPE,EX)) Q:EX="" D
..I $Y>(IOSL-5) D
...W $$PTFTR^PSBOHDR()
...D PT^PSBOHDR(DFN,.PSBHDR),HEADA
..W !,$G(^TMP("PSB",$J,TPE,EX))
W $$PTFTR^PSBOHDR()
Q
;
FTR() ;
I (IOSL<100) F Q:$Y>(IOSL-10) 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
Q ""
;
MEDS(TYP) ;
N MED,XA,XB,DPTR,DRG,FLE,SBSC
S MED="",XB=3,DRG=""
S PSBHDR(3)="MEDICATIONS SEARCH LIST:"
S XA="" F S XA=$O(TMP("PSBOIS",$J,XA)) Q:XA="" D
.S MED=$$GET1^DIQ(50.7,XA,.01)
.I $L(PSBHDR(XB)_" "_MED)>IOM D
..S XB=XB+1,PSBHDR(XB)=" "_MED
.E S PSBHDR(XB)=PSBHDR(XB)_$S($L(PSBHDR(XB))<26:" ",1:"; ")_MED
S XA=999 F S XA=$O(PSBHDR(XA),-1) Q:XA=XB K PSBHDR(XA)
I TYP'="" D
.I TYP["UD" S TYP="UNIT DOSE",SBSC="PSBOIS",FLE=50.7
.I TYP["AD" S TYP="ADDITIVE",SBSC="PSBADDS",FLE=52.6
.I TYP["SO" S TYP="SOLUTION",SBSC="PSBSOLS",FLE=52.7
.S DPTR="" F S DPTR=$O(TMP(SBSC,$J,DPTR)) Q:DPTR="" I TMP(SBSC,$J,DPTR) D
..S DRG=$$GET1^DIQ(FLE,DPTR,.01)
..S PSBHDR($O(PSBHDR(999),-1)+1)=$S(TYP="UNIT DOSE":"",1:"SEARCH FOR "_TYP_": "_DRG)
.K TMP(SBSC,$J)
Q
;
CLEANALL ; KILL ALL TMP LEVELS USED VARIABLES
K ^TMP("PSB",$J),^TMP("PSJ1",$J),TMP("PSBOIS",$J),TMP("PSBADDS",$J),TMP("PSBSOLS",$J),TMP("PSBIENS",$J),TMP("ARY",$J),DRG,DPTR,PSBOR,FLE,SBSC,TPE
Q
;
CLEANSUM ; KILLL ALL BUT THE "PSBIENS" LEVEL
K ^TMP("PSB",$J),^TMP("PSJ1",$J),TMP("PSBIENS",$J),TMP("PSBOIS",$J),TMP("PSBADDS",$J),TMP("PSBSOLS",$J)
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
;
PSBOPM ;BIRMINGHAM/BSR-BCMA OIT HISTORY ; 5/2/07 9:52am
+1 ;;3.0;BAR CODE MED ADMIN;**3,9,13,17,40**;Mar 2004;Build 9
+2 ;;Per VHA Directive 2004-038, 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 ;
EN ;
+1 NEW PSBHDR,DFN
+2 SET PSBGBL="^TMP(""PSBO"",$J,""B"")"
+3 FOR
SET PSBGBL=$QUERY(@PSBGBL)
IF PSBGBL=""
QUIT
IF $QSUBSCRIPT(PSBGBL,2)'=$JOB
QUIT
IF $QSUBSCRIPT(PSBGBL,1)'["PSBO"
QUIT
Begin DoDot:1
+4 SET DFN=$QSUBSCRIPT(PSBGBL,5)
End DoDot:1
+5 IF '$GET(DFN)
WRITE !,("Error: No Patient IEN")
QUIT
+6 SET PSBSTRT=$PIECE(PSBRPT(.1),U,6)+$PIECE(PSBRPT(.1),U,7)
+7 SET PSBSTOP=$PIECE(PSBRPT(.1),U,8)+$PIECE(PSBRPT(.1),U,9)
+8 ;COMMENT FLAG 1 MEANS YES
SET PSBCOM=$PIECE(PSBRPT(.2),"^",8)
+9 IF PSBSTRT="0"
Begin DoDot:1
+10 DO NOW^%DTC
SET PSBSTOP=%
+11 SET X1=((PSBSTOP)\1)
SET X2=-$$GET^XPAR("ALL","PSB MED HIST DAYS BACK")
+12 IF X2'<0
SET X2=-30
DO C^%DTC
SET PSBSTRT=X
+13 SET PSBCOM=$$GET^XPAR("ALL","PSB RPT INCL COMMENTS")
End DoDot:1
+14 DO OUT(DFN,PSBSTRT,PSBSTOP,PSBORDNM)
+15 QUIT
+16 ;
OUT(DFN,PSBSTRT,PSBSTOP,PSBORDNM) ;
+1 ;CLEAN UP VARIABLES AND TMP ARRAY
DO CLEANALL
+2 ;
+3 ;IF PSBORDNM DOESN'T CONTAIN A "U" OR A "V", SKIP THE ORDER LOOKUP
+4 SET PSBOR=1
+5 IF PSBORDNM'["U"
IF PSBORDNM'["V"
Begin DoDot:1
+6 IF '$$GETORD^PSBOPM1(.PSBORDNM)
SET PSBOR=0
+7 IF 'PSBOR&(PSBORDNM]"")
SET TMP("PSBOIS",$JOB,PSBORDNM)=""
End DoDot:1
+8 IF PSBOR
Begin DoDot:1
+9 DO GETORDN
+10 DO GETOIS
End DoDot:1
+11 ; GET ALL ADDITIVES AND SOLUTIONS
DO GETADSO
+12 ; FIND EVERY MED LOG ENTRIES THAT SHOULD BE ON THE RPT
DO FINDIENS^PSBOPM1
+13 ; WRITE DATA TO GLOBAL
DO PREOUT
+14 ;
DO WRITEOT
+15 ; CLEAN UP AND LEAVE LIST OF IENS FOR THE REPORT.
DO CLEANSUM
+16 QUIT
+17 ;
GETORDN ;
+1 KILL ^TMP("PSJ1",$JOB)
+2 DO EN^PSJBCMA1(DFN,PSBORDNM,1)
+3 QUIT
+4 ;
GETOIS ; LOAD PSBOIS(#) WITH ALL OF THE ORDERABLE ITEMS
+1 IF PSBORDNM["U"
Begin DoDot:1
+2 ;GET UNIT DOSE ORDERS
+3 IF $DATA(^TMP("PSJ1",$JOB,2))
Begin DoDot:2
+4 SET PSBOI=$PIECE(^TMP("PSJ1",$JOB,2),"^")
+5 SET PSBOI=$SELECT(PSBOI["U":$TRANSLATE(PSBOI,"U",""),PSBOI["V":$TRANSLATE(PSBOI,"V",""),1:PSBOI)
+6 SET TMP("PSBOIS",$JOB,PSBOI)=""
End DoDot:2
End DoDot:1
+7 ;
+8 ;IV ORDERS NEED TO USE THE ADDITIVE AND SOLUTION NUMBER TO BACK
+9 ;TRACK TO THE OI ASSOCIATED WITH IT
+10 IF PSBORDNM["V"
Begin DoDot:1
+11 ;GET ADDITIVES OFF THE ORDER
+12 IF $GET(^TMP("PSJ1",$JOB,850,0))
Begin DoDot:2
+13 SET XXX=""
FOR
SET XXX=$ORDER(^TMP("PSJ1",$JOB,850,XXX))
IF XXX=""
QUIT
Begin DoDot:3
+14 SET XXY=""
FOR
SET XXY=$ORDER(^TMP("PSJ1",$JOB,850,XXX,XXY))
IF XXY=""
QUIT
Begin DoDot:4
+15 SET PSBADD=$PIECE(^TMP("PSJ1",$JOB,850,XXX,XXY),"^")
+16 ;CONVERT ADDITIVE TO ORDERABLE ITEM AND ADD TO LIST
+17 SET TMP("PSBOIS",$JOB,$$OFROMA(PSBADD))=""
End DoDot:4
End DoDot:3
End DoDot:2
+18 ; GET SOLUTIONS OFF THE ORDER
+19 IF $GET(^TMP("PSJ1",$JOB,950,0))
Begin DoDot:2
+20 SET XXX=""
FOR
SET XXX=$ORDER(^TMP("PSJ1",$JOB,950,XXX))
IF XXX=""
QUIT
Begin DoDot:3
+21 SET XXY=""
FOR
SET XXY=$ORDER(^TMP("PSJ1",$JOB,950,XXX,XXY))
IF XXY=""
QUIT
Begin DoDot:4
+22 SET PSBSOL=$PIECE(^TMP("PSJ1",$JOB,950,XXX,XXY),"^")
+23 ;
+24 ;CONVERT SOLUTIOIN TO ORDERABLE ITEM AND ADD TO LIST
+25 SET TMP("PSBOIS",$JOB,$$OFROMS(PSBSOL))=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+26 QUIT
+27 ;
OFROMA(PSBADD) ;GET ORDERABLE ITEM FROM AN ADDITIVE
+1 QUIT $$GET1^DIQ(52.6,PSBADD_",",15,"I")
+2 ;
OFROMS(PSBSOL) ; GET ORDERABLE ITEM FROM A SOLUTION
+1 QUIT $$GET1^DIQ(52.7,PSBSOL_",",9,"I")
+2 ;
GETADSO ; GET ALL ADDITIVES FOR ALL ORDERABLE ITEMS
+1 KILL PSBAOUT,PSBSOUT
+2 SET XA=""
FOR
SET XA=$ORDER(TMP("PSBOIS",$JOB,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(TMP("PSBOIS",$JOB,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
+16 ;
PREOUT ;
+1 NEW TYP
+2 FOR TYP="UD","ADD","SOL"
Begin DoDot:1
+3 IF '$DATA(TMP("PSBIENS",$JOB,TYP))
QUIT
+4 KILL PSBUNK
SET XDT=""
FOR
SET XDT=$ORDER(TMP("PSBIENS",$JOB,TYP,XDT),-1)
IF XDT=""
QUIT
Begin DoDot:2
+5 SET I=""
FOR
SET I=$ORDER(TMP("PSBIENS",$JOB,TYP,XDT,I))
IF I=""
QUIT
Begin DoDot:3
+6 IF TYP="UD"
IF $DATA(TMP("PSBIENS",$JOB,"ADD",XDT,I))
QUIT
IF $DATA(TMP("PSBIENS",$JOB,"SOL",XDT,I))
QUIT
+7 SET PSBIEN=I
+8 SET PSBIENS=PSBIEN_","
+9 DO OUTPUT(TYP)
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
OUTPUT(TYP) ;
+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 SET W=W_$EXTRACT($$GET1^DIQ(53.79,PSBIENS,"ACTION BY:INITIAL")_PSBSPC,1,10)_" "
+8 SET W=W_$$GET1^DIQ(53.79,PSBIENS,.16)
+9 DO ADD(W,TYP)
+10 FOR PSBNODE=.5,.6,.7
Begin DoDot:1
+11 SET PSBDD=$SELECT(PSBNODE=.5:53.795,PSBNODE=.6:53.796,1:53.797)
+12 FOR PSBY=0:0
SET PSBY=$ORDER(^PSB(53.79,PSBIEN,PSBNODE,PSBY))
IF 'PSBY
QUIT
Begin DoDot:2
+13 DO WRAPMEDS($$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.01),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.03),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.04),TYP)
End DoDot:2
End DoDot:1
+14 ;GETS COMMENTS
IF PSBCOM=1
DO COMNTS
+15 DO ADD("",TYP)
+16 QUIT
+17 ;
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("",TYP)
+5 DO ADD($JUSTIFY("",44)_"Comments: "_$$MAKELINE("-",78),TYP)
+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("",TYP)
+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
End DoDot:2
+12 DO ADD($JUSTIFY("",54)_$$MAKELINE("-",78),TYP)
End DoDot:1
+13 QUIT
+14 ;
WRAP(SIZE,ZP,BRIEN) ;
+1 DO ADD($JUSTIFY("",55)_ZP,TYP)
+2 DO ADD($JUSTIFY("",55)_$EXTRACT(SIZE,1,75),TYP)
+3 IF $LENGTH(SIZE)>75
DO ADD($JUSTIFY("",55)_$EXTRACT(SIZE,76,150),TYP)
+4 QUIT
+5 ;
HEADA ;
+1 WRITE !
+2 WRITE "Location",?21,"St Sch Administration Date",?50,"By",?61,"Injection Site",?96,"Units",?112,"Units of"
+3 WRITE !,?55,"Medication & Dosage",?96,"GIVEN",?112,"Administration"
+4 WRITE !
+5 WRITE $$MAKELINE("-",132)
+6 QUIT
+7 ;
ADD(XE,TYP) ;
+1 SET ^TMP("PSB",$JOB,TYP,$ORDER(^TMP("PSB",$JOB,TYP,""),-1)+1)=XE
+2 QUIT
+3 ;
WRAPMEDS(MED,UG,UOA,TYP) ;
+1 ;MED IS NOT WRAPPED: MAX LENGTH IN PSDRUG/52.6/52.7 IS 40
+2 ;UG/UOA MAX AT 30/40 AND WILL BE WRAPPED AT 15 EACH
+3 ;THIS WILL CREATE UPTO 3 LINES
+4 SET MED=$EXTRACT(MED_$JUSTIFY("",40),1,40)
+5 NEW UGWRAP
+6 SET (CNTX,UOA1,UOA16,UOA31)=""
+7 IF +$GET(UG)?1"."1.N
SET UG=0_+UG
+8 FOR CNT=1:15:45
Begin DoDot:1
+9 DO PARSE(UOA,CNT)
+10 SET UGWRAP=$EXTRACT(UG,CNT,(CNT+14))
+11 IF CNT=1
DO ADD($JUSTIFY("",55)_MED_" "_$$PAD(UGWRAP,15)_" "_$$PAD(UOA1,15),TYP)
+12 IF (CNT>1)
IF ($LENGTH(UGWRAP)>0!$LENGTH(@("UOA"_CNT))>0)
DO ADD($JUSTIFY("",96)_$$PAD(UGWRAP,15)_" "_$$PAD(@("UOA"_CNT),15),TYP)
End DoDot:1
+13 QUIT
+14 ;
PAD(X,CNT) ;
+1 QUIT $EXTRACT(X_$JUSTIFY("",CNT),1,CNT)
WRITEOT ;
+1 NEW TPE
+2 SET Y=$PIECE(PSBSTRT,".",1)
DO D^DIQ
SET PSTRTA=Y
+3 SET Y=$PIECE(PSBSTOP,".",1)
DO D^DIQ
SET PSTP=Y
+4 SET PSBHDR(1)="MEDICATION HISTORY for "_PSTRTA_" to "_PSTP
+5 IF '$DATA(TMP("PSBIENS",$JOB))
DO ADD("<<<< NO HISTORY FOUND FOR THIS TIME FRAME >>>>","UD")
+6 SET TPE=""
FOR
SET TPE=$ORDER(^TMP("PSB",$JOB,TPE))
IF TPE=""
QUIT
Begin DoDot:1
+7 DO MEDS(TPE)
+8 DO PT^PSBOHDR(DFN,.PSBHDR)
DO HEADA
+9 SET EX=""
FOR
SET EX=$ORDER(^TMP("PSB",$JOB,TPE,EX))
IF EX=""
QUIT
Begin DoDot:2
+10 IF $Y>(IOSL-5)
Begin DoDot:3
+11 WRITE $$PTFTR^PSBOHDR()
+12 DO PT^PSBOHDR(DFN,.PSBHDR)
DO HEADA
End DoDot:3
+13 WRITE !,$GET(^TMP("PSB",$JOB,TPE,EX))
End DoDot:2
End DoDot:1
+14 WRITE $$PTFTR^PSBOHDR()
+15 QUIT
+16 ;
FTR() ;
+1 IF (IOSL<100)
FOR
IF $Y>(IOSL-10)
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 QUIT ""
+6 ;
MEDS(TYP) ;
+1 NEW MED,XA,XB,DPTR,DRG,FLE,SBSC
+2 SET MED=""
SET XB=3
SET DRG=""
+3 SET PSBHDR(3)="MEDICATIONS SEARCH LIST:"
+4 SET XA=""
FOR
SET XA=$ORDER(TMP("PSBOIS",$JOB,XA))
IF XA=""
QUIT
Begin DoDot:1
+5 SET MED=$$GET1^DIQ(50.7,XA,.01)
+6 IF $LENGTH(PSBHDR(XB)_" "_MED)>IOM
Begin DoDot:2
+7 SET XB=XB+1
SET PSBHDR(XB)=" "_MED
End DoDot:2
+8 IF '$TEST
SET PSBHDR(XB)=PSBHDR(XB)_$SELECT($LENGTH(PSBHDR(XB))<26:" ",1:"; ")_MED
End DoDot:1
+9 SET XA=999
FOR
SET XA=$ORDER(PSBHDR(XA),-1)
IF XA=XB
QUIT
KILL PSBHDR(XA)
+10 IF TYP'=""
Begin DoDot:1
+11 IF TYP["UD"
SET TYP="UNIT DOSE"
SET SBSC="PSBOIS"
SET FLE=50.7
+12 IF TYP["AD"
SET TYP="ADDITIVE"
SET SBSC="PSBADDS"
SET FLE=52.6
+13 IF TYP["SO"
SET TYP="SOLUTION"
SET SBSC="PSBSOLS"
SET FLE=52.7
+14 SET DPTR=""
FOR
SET DPTR=$ORDER(TMP(SBSC,$JOB,DPTR))
IF DPTR=""
QUIT
IF TMP(SBSC,$JOB,DPTR)
Begin DoDot:2
+15 SET DRG=$$GET1^DIQ(FLE,DPTR,.01)
+16 SET PSBHDR($ORDER(PSBHDR(999),-1)+1)=$SELECT(TYP="UNIT DOSE":"",1:"SEARCH FOR "_TYP_": "_DRG)
End DoDot:2
+17 KILL TMP(SBSC,$JOB)
End DoDot:1
+18 QUIT
+19 ;
CLEANALL ; KILL ALL TMP LEVELS USED VARIABLES
+1 KILL ^TMP("PSB",$JOB),^TMP("PSJ1",$JOB),TMP("PSBOIS",$JOB),TMP("PSBADDS",$JOB),TMP("PSBSOLS",$JOB),TMP("PSBIENS",$JOB),TMP("ARY",$JOB),DRG,DPTR,PSBOR,FLE,SBSC,TPE
+2 QUIT
+3 ;
CLEANSUM ; KILLL ALL BUT 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
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 ;
