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 ;Sep 02, 2020@15:05:53
  1. ;;3.0;BAR CODE MED ADMIN;**3,9,13,17,40,70,72,83,82,136**;Mar 2004;Build 7
  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. ;*70 - reset PSBCLINORD = 2 to signify combined orders report
  1. ;*83 - add Give info associated with a Remove and print
  1. ;
  1. EN ;
  1. N PSBHDR,DFN,PSBGBL,X1,X2,PSBSTRT,PSBSTOP,PSBCOM,PSBSPC
  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. N PSBOR
  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. N PSBOI,XXX,XXY,PSBADD,PSBSOL
  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. ....I $G(^TMP("PSJ1",$J,850,0)) Q:$$GET1^DIQ(52.7,PSBSOL_",",18)'="YES" ; PSB*3.0*82 rbd Do not do pre-mix when additive present
  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. N PSBAOUT,PSBSOUT,XA,XB
  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 I,TYP,XDT,PSBIEN,PSBIENS
  1. F TYP="UD","ADD","SOL" D
  1. .Q:'$D(TMP("PSBIENS",$J,TYP))
  1. .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. N GIVE,G1,G2,G3,G4
  1. ; added new local variables for PSB*3.0*82 rbd - also New'ing W & PSBUNK variables
  1. N PSBUNK,W,W2,W22LINE,W22NUM,W22TEXT,W3,WCURSTAT,WINIT,WNAME
  1. N WNPIEN,WOLDSTAT,WSUB9,WSUB9BY,WSUB9CNT,WSUB9DT,WUO,PSBNODE,PSBY,PSBDD
  1. S PSBSPC=$J("",80)
  1. ; PSB*3.0*82 rbd - more room for LOCATION; chg'ed 20 to 25
  1. S W=" "_$E($$GET1^DIQ(53.79,PSBIENS,.02)_PSBSPC,1,25)_" "
  1. I $TR(W," ")="",$$MME^PSBOML(+PSBIENS) S W=" MME/UNKNOWN LOCATION "
  1. ; PSB*3.0*82 rbd - do not output status/sch type abbrevs anymore
  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 PSBUNK=0 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. ; PSB*3.0*82 rbd - Status & Schedule Type spelled out now (unabbreviated)
  1. S WCURSTAT=$S(PSBUNK:"Unknown Status",1:$P($G(^PSB(53.79,PSBIEN,0)),U,9))
  1. S W=W_$E($$STATUS(WCURSTAT)_PSBSPC,1,23)_" "
  1. S W=W_$E($$SCHED($P($G(^PSB(53.79,PSBIEN,.1)),U,2))_PSBSPC,1,19)_" "
  1. S W=W_$E($E($$GET1^DIQ(53.79,PSBIENS,.06),1,18)_PSBSPC,1,21)_" "
  1. ;*83 body site info
  1. N SITE
  1. S SITE=$$GET1^DIQ(53.79,PSBIENS,.18)
  1. S:SITE="" SITE=$$GET1^DIQ(53.79,PSBIENS,.16)
  1. ;S W=W_SITE ; PSB*3*82 rbd Site Info will now go on the next line with the Medication
  1. ;
  1. D ADD(W,TYP)
  1. ; PSB*3.0*82 rbd - put By/Body Site on line with 1st med; keep legend of Initials & Name also
  1. S WINIT=$$GETINIT^PSBCSUTX(PSBIEN,"I")
  1. S WNAME=$$GETINIT^PSBCSUTX(PSBIEN,"N")
  1. I WINIT]"",WNAME]"" S ^TMP("PSB_WINITNAM",$J,WINIT,WNAME)=""
  1. S W=" "_$E(WINIT_PSBSPC,1,25)_" " ;Get initials of who took action, PSB*3*72 - ln/spacing chg'ed PSB*3*82 rbd
  1. ;S W=$J("",56)
  1. ; PSB*3.0*82 rbd find all audit history not just associated Give for Removal
  1. ;I $P(^PSB(53.79,PSBIEN,0),U,9)="RM" D
  1. ;.S GIVE=$$FINDGIVE^PSBUTL(PSBIEN)
  1. ;.S G1=$E($P(GIVE,U,3)_PSBSPC,1,3)
  1. ;.S G2=$E($P($G(^PSB(53.79,PSBIEN,.1)),U,2)_PSBSPC,1,4)
  1. ;.S G3=$P(GIVE,U),G3=$E($$UP^XLFSTR($$FMTE^XLFDT(G3,1)),1,18)_$J("",4)
  1. ;.S G4=$E($P(GIVE,U,2)_PSBSPC,1,6)
  1. ;.S W=$J("",21)
  1. ;.S W2=G1_G2_G3_G4
  1. I $G(^PSB(53.79,PSBIEN,.9,1,0))]"" D
  1. .S WSUB9CNT=""
  1. .F S WSUB9CNT=$O(^PSB(53.79,PSBIEN,.9,WSUB9CNT),-1) Q:WSUB9CNT=0 D
  1. ..S WSUB9=$G(^PSB(53.79,PSBIEN,.9,WSUB9CNT,0)) I WSUB9]"" D
  1. ...I $P(WSUB9,U,3)["ACTION STATUS Set to" D
  1. ....S WSUB9BY=$P($P(WSUB9,U,3),"'",4),WSUB9DT=$P(WSUB9,U)
  1. ....S WOLDSTAT=$E($P(WSUB9,U,4),1,3)
  1. ....S:WOLDSTAT="REM" WOLDSTAT="RM"
  1. ....S:WOLDSTAT'="RM" WOLDSTAT=$E(WOLDSTAT)
  1. ....S W2(WSUB9CNT)=$$STATUS(WOLDSTAT)_U_WSUB9DT_U_WSUB9BY
  1. ....I WSUB9BY]"" D ; keep legend of init/name PSB*3.0*82 rbd
  1. .....S WNPIEN=$P(WSUB9,U,5)
  1. .....S WNAME=$$GET1^DIQ(200,WNPIEN,.01)
  1. .....I WNAME]"" S ^TMP("PSB_WINITNAM",$J,WSUB9BY,WNAME)=""
  1. ;
  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 ;Include units ordered for IV's
  1. ..; PSB*3.0*82 rbd Send in Units Ordered also to WRAPMEDS
  1. ..;D:PSBDD=53.795 WRAPMEDS(W,$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.01),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.03),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.04),TYP) ;insert W to Wrapmeds tag *83
  1. ..;D:PSBDD=53.796!(PSBDD=53.797) WRAPMEDS(W,$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.01)_" - "_$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.02),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.03),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.04),TYP) ;insert W to wrapmeds *83
  1. ..S WUO=$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.02)
  1. ..D:PSBDD=53.795 WRAPMEDS(W,SITE,$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.01),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.03),WUO,$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.04),TYP) ;insert W to Wrapmeds tag *83
  1. ..I PSBDD=53.796!(PSBDD=53.797) D
  1. ...D WRAPMEDS(W,SITE,$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.01)_" - "_WUO,$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.03),WUO,$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.04),TYP) ;insert W to wrapmeds *83
  1. ; PSB*3.0*82 rbd Add audit info as its own line
  1. S WSUB9CNT=$O(W2(""),-1) I WSUB9CNT?1N.N K W2(WSUB9CNT)
  1. S WSUB9CNT="" F S WSUB9CNT=$O(W2(WSUB9CNT),-1) Q:WSUB9CNT="" D
  1. .S WSUB9=W2(WSUB9CNT),W3=$J("",27),W3=W3_"(Previous Status: "_$E($P(WSUB9,U)_PSBSPC,1,23)
  1. .S W3=W3_" At "_$$UP^XLFSTR($$FMTE^XLFDT($P(WSUB9,U,2),1))_" By "
  1. .S W3=W3_$P(WSUB9,U,3)_")" D ADD(W3,TYP)
  1. ; PSB*3.0*82 rbd Add in PRN Effectiveness info.
  1. S W=$E($$GET1^DIQ(53.79,PSBIENS,.21)_PSBSPC,1,27)_" "
  1. I $TR(W," ")]"" D
  1. .S W=" " D ADD(W,TYP)
  1. .S W=" "_$E($$GET1^DIQ(53.79,PSBIENS,.21)_PSBSPC,1,27)_" "
  1. .S W22LINE=$$GET1^DIQ(53.79,PSBIENS,.22)
  1. .D WRAP2(W22LINE,25,.W22TEXT)
  1. .S W=W_$E(W22TEXT(1)_PSBSPC,1,27)_" "
  1. .S W=W_$E($$GET1^DIQ(53.79,PSBIENS,.23)_PSBSPC,1,29)_" "
  1. .S W=W_$E($$GET1^DIQ(53.79,PSBIENS,.24)_PSBSPC,1,29)
  1. .D ADD(W,TYP)
  1. .I W22TEXT>1 F W22NUM=2:1:W22TEXT D
  1. ..D ADD($J("",33)_W22TEXT(W22NUM),TYP)
  1. I PSBCOM=1 D COMNTS ;GETS COMMENTS
  1. D ADD("",TYP)
  1. Q
  1. ;
  1. STATUS(STATABBR) ; Give a full status from abbr - PSB*3.0*82 rbd
  1. Q:STATABBR="G" "Given" Q:STATABBR="I" "Infusing"
  1. Q:STATABBR="S" "Stopped" Q:STATABBR="C" "Completed"
  1. Q:STATABBR="H" "Held" Q:STATABBR="R" "Refused"
  1. Q:STATABBR="RM" "Removed" Q:STATABBR="M" "Missing Dose Requested"
  1. Q ""
  1. ;
  1. SCHED(SCHABBR) ; Give a full schedule type from abbr - PSB*3.0*82 rbd
  1. Q:SCHABBR="C" "Continuous" Q:SCHABBR="P" "PRN"
  1. Q:SCHABBR="O" "One Time" Q:SCHABBR="OC" "On Call"
  1. Q ""
  1. ;
  1. COMNTS ;
  1. N Z,CNT,PSBCMNT,PSBINIT,PSBNAME,PSBPRREC,XT,XBR ; PSB*3.0*82 rbd keep legend of init/name
  1. S Z="",CNT=0
  1. I $D(^PSB(53.79,PSBIEN,.3,0)) D
  1. .D ADD("",TYP)
  1. .D ADD($J("",27)_"Comments: "_$$MAKELINE("-",81),TYP) ; PSB*3.0*82 rbd Move Comments to align with Medication
  1. .S XT="" F S XT=$O(^PSB(53.79,PSBIEN,.3,XT),-1) Q:XT="" I XT'=0 D ; PSB*3.0*82 rbd reverse chronological for comments also
  1. ..D:CNT=1 ADD("",TYP)
  1. ..; PSB*3.0*82 rbd keep legend of init/name
  1. ..;S Y=$P(^PSB(53.79,PSBIEN,.3,XT,0),"^",3) D DD^%DT S XBR=Y
  1. ..S PSBCMNT=$G(^PSB(53.79,PSBIEN,.3,XT,0))
  1. ..S Y=$P(PSBCMNT,"^",3) D DD^%DT S XBR=Y
  1. ..S PSBPRREC=$G(^VA(200,+$P(PSBCMNT,"^",2),0))
  1. ..S PSBINIT=$P(PSBPRREC,"^",2)
  1. ..S PSBNAME=$P(PSBPRREC,"^",1)
  1. ..I PSBINIT]"",PSBNAME]"" D
  1. ...S ^TMP("PSB_WINITNAM",$J,PSBINIT,PSBNAME)=""
  1. ..;S Z=XBR_" "_$P(^VA(200,$P(^PSB(53.79,PSBIEN,.3,XT,0),"^",2),0),"^",2)
  1. ..S Z=XBR_" "_PSBINIT
  1. ..D WRAP($P(^PSB(53.79,PSBIEN,.3,XT,0),"^",1),Z,PSBIEN)
  1. ..S CNT=1
  1. .D ADD($J("",37)_$$MAKELINE("-",81),TYP) ; PSB*3.0*82 rbd Move Comments to align with Medication
  1. Q
  1. ;
  1. WRAP(SIZE,ZP,BRIEN) ;
  1. ; PSB*3.0*82 rbd Massaged Comments to possibly be 4 lines using new WRAP2 API
  1. ;D ADD($J("",56)_ZP,TYP)
  1. ;D ADD($J("",56)_$E(SIZE,1,75),TYP)
  1. ;I $L(SIZE)>75 D ADD($J("",56)_$E(SIZE,76,150),TYP)
  1. N SIZE2,SIZE2NUM D WRAP2(SIZE,50,.SIZE2),ADD($J("",37)_ZP_" "_SIZE2(1),TYP)
  1. I SIZE2>1 F SIZE2NUM=2:1:SIZE2 D
  1. .D ADD($J("",66)_SIZE2(SIZE2NUM),TYP)
  1. Q
  1. ;
  1. ; PSB*3.0*82 rbd Put in place more robust wrapping API
  1. WRAP2(TEXTLINE,MAX,TEXT) ; Splits Text into TEXT array
  1. N I,J S J=0 K TEXT
  1. I $L(TEXTLINE)'>MAX S J=J+1,TEXT(J)=TEXTLINE G WRQ
  1. WR0 ; Loop for Remaining Text
  1. S I=$F(TEXTLINE," ")
  1. I ('I)!(I>(MAX+2)) D
  1. .S J=J+1,TEXT(J)=$E(TEXTLINE,1,MAX)
  1. .S TEXTLINE=$E(TEXTLINE,MAX+1,999)
  1. I $L(TEXTLINE)>MAX F I=(MAX+1):-1:1 I $E(TEXTLINE,I)=" " D Q
  1. .S J=J+1,TEXT(J)=$E(TEXTLINE,1,I-1)
  1. .S TEXTLINE=$E(TEXTLINE,I+1,999)
  1. G:$L(TEXTLINE)>MAX WR0
  1. S:$L(TEXTLINE) J=J+1,TEXT(J)=TEXTLINE
  1. WRQ ; Quit Wrap
  1. S TEXT=J
  1. Q
  1. ; end new API for PSB*3*82 rbd
  1. HEADA ;
  1. W !
  1. ; PSB*3.0*82 rbd - Expand fields and include new fields
  1. ;W "Location",?21,"St Sch Administration Date",?50,"By",?61,"Body Site",?96,"Units",?112,"Units of" ;*83
  1. W ?1,"Location",?27,"Status",?51,"Schedule Type"
  1. W ?71,"Administration Date",?98,"Units",?109,"Units",?121,"Units of"
  1. W !?1,"By",?27,"Medication & Dosage",?71,"Body Site"
  1. W ?97,"Ordered",?109,"GIVEN",?122,"Admin"
  1. W !!?5,"PRN Reason",?33,"PRN Effectiveness",?61,"Effectiveness Entered By"
  1. W ?91,"Effectiveness Entered"
  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. ; PSB*3.0*82 rbd Send in Units Ordered as well
  1. WRAPMEDS(W,SITE,MED,UG,UO,UOA,TYP) ;insert parm W (possible RM string) to print on line 1 *83
  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=$S($L(MED)>40:$E(MED_$J("",80),1,80),1:$E(MED_$J("",40),1,40)) ;Add wrapping for med/units ordered
  1. N UGWRAP,PSBMED1,PSBMED41,PSBMED81,PSBCNT,UOWRAP,CNTX,CNTXX,UOA1,UOA16,UOA31,UOAX ; PSB*3.0*82 rbd Added Units Ordered
  1. S (CNTX,UOA1,UOA16,UOA31,PSBMED1,PSBMED41,PSBMED81)=""
  1. I +$G(UG)?1"."1.N S UG=0_+UG
  1. I +$G(UO)?1"."1.N S UO=0_+UO ; PSB*3.0*82 rbd Units Ordered added
  1. F CNT=1:15:45 D
  1. .S PSBCNT=$S(CNT=1:1,CNT=16:41,CNT=31:81,1:120)
  1. .D PARSEM(MED,PSBCNT)
  1. .D PARSE(UOA,CNT)
  1. .S UGWRAP=$E(UG,CNT,(CNT+14))
  1. .; PSB*3.0*82 rbd Units Ordered & Site handling next 3 lines of code
  1. .S UOWRAP=$E(UO,CNT,(CNT+14))
  1. .;P136 reduce SITE_PSBSPC,1,24(25);UOWRAP,9(11);UGWRAP,9(11);$J,97(99);Increase UOA1,15(11); UOA,15(11)
  1. .I CNT=1 D ADD(W_$E(MED_PSBSPC,1,43)_" "_$E(SITE_PSBSPC,1,24)_" "_$$PAD(UOWRAP,9)_" "_$$PAD(UGWRAP,9)_" "_$$PAD(UOA1,15),TYP)
  1. .I (CNT>1),($L(UGWRAP)>0!$L(@("UOA"_CNT))>0) D ADD($J("",97)_$$PAD(UOWRAP,9)_" "_$$PAD(UGWRAP,9)_" "_$$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,PSTRTA,PSTP
  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. .N PSBCLINORD,EX S PSBCLINORD=2 D PT^PSBOHDR(DFN,.PSBHDR),HEADA ;*70
  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. ; PSB*3.0*82 rbd Keep legend of initials & names
  1. W !!,"Initial - Name Legend"
  1. S WINIT="" F S WINIT=$O(^TMP("PSB_WINITNAM",$J,WINIT)) Q:WINIT="" D
  1. .S WNAME="" F S WNAME=$O(^TMP("PSB_WINITNAM",$J,WINIT,WNAME)) Q:WNAME="" D
  1. ..W !,$E(WINIT_PSBSPC,1,10)_WNAME
  1. K ^TMP("PSB_WINITNAM",$J)
  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. ;Begin P136
  1. N VAR
  1. S VAR="UOA"_CNT
  1. S @VAR=$E(X,CNT,CNT+14)
  1. Q
  1. ;End of P136, the below lines do not need anymore
  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. ;
  1. PARSEM(PSBMED,PSBCNT) ;Split text for wrapping meds, PSB*3*72
  1. N PSBCNTX,PSBMEDX,PSBMEDX,PSBCNTXX
  1. S PSBCNTX="PSBMED"_PSBCNT,@PSBCNTX=@PSBCNTX_$E(PSBMED,PSBCNT,(PSBCNT+39)),PSBMEDX=""
  1. F S:$F(@PSBCNTX,", ",+PSBMEDX)>0 PSBMEDX=$F(@PSBCNTX,", ",+PSBMEDX) Q:'$F(@PSBCNTX,", ",+PSBMEDX)
  1. I PSBMEDX<1 F S:$F(@PSBCNTX," ",+PSBMEDX)>0 PSBMEDX=$F(@PSBCNTX," ",+PSBMEDX) Q:'$F(@PSBCNTX," ",+PSBMEDX)
  1. I PSBMEDX>1,(($L(MED)-(PSBCNT+39))>0) S PSBCNTXX=$E(@PSBCNTX,1,PSBMEDX-1),@("PSBMED"_(PSBCNT+40))=$E(@PSBCNTX,PSBMEDX,PSBMEDX+39),@PSBCNTX=PSBCNTXX
  1. Q