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

PSBOPM.m

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