- PSBOPM ;BIRMINGHAM/BSR - BCMA OIT HISTORY ;Sep 02, 2020@15:05:53
- ;;3.0;BAR CODE MED ADMIN;**3,9,13,17,40,70,72,83,82,136**;Mar 2004;Build 7
- ;;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
- ;
- ;*70 - reset PSBCLINORD = 2 to signify combined orders report
- ;*83 - add Give info associated with a Remove and print
- ;
- EN ;
- N PSBHDR,DFN,PSBGBL,X1,X2,PSBSTRT,PSBSTOP,PSBCOM,PSBSPC
- 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
- N PSBOR
- ;
- ;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
- N PSBOI,XXX,XXY,PSBADD,PSBSOL
- 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),"^")
- ....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
- ....;
- ....;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
- N PSBAOUT,PSBSOUT,XA,XB
- 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 I,TYP,XDT,PSBIEN,PSBIENS
- F TYP="UD","ADD","SOL" D
- .Q:'$D(TMP("PSBIENS",$J,TYP))
- .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) ;
- N GIVE,G1,G2,G3,G4
- ; added new local variables for PSB*3.0*82 rbd - also New'ing W & PSBUNK variables
- N PSBUNK,W,W2,W22LINE,W22NUM,W22TEXT,W3,WCURSTAT,WINIT,WNAME
- N WNPIEN,WOLDSTAT,WSUB9,WSUB9BY,WSUB9CNT,WSUB9DT,WUO,PSBNODE,PSBY,PSBDD
- S PSBSPC=$J("",80)
- ; PSB*3.0*82 rbd - more room for LOCATION; chg'ed 20 to 25
- S W=" "_$E($$GET1^DIQ(53.79,PSBIENS,.02)_PSBSPC,1,25)_" "
- I $TR(W," ")="",$$MME^PSBOML(+PSBIENS) S W=" MME/UNKNOWN LOCATION "
- ; PSB*3.0*82 rbd - do not output status/sch type abbrevs anymore
- ;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 PSBUNK=0 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)_" "
- ; PSB*3.0*82 rbd - Status & Schedule Type spelled out now (unabbreviated)
- S WCURSTAT=$S(PSBUNK:"Unknown Status",1:$P($G(^PSB(53.79,PSBIEN,0)),U,9))
- S W=W_$E($$STATUS(WCURSTAT)_PSBSPC,1,23)_" "
- S W=W_$E($$SCHED($P($G(^PSB(53.79,PSBIEN,.1)),U,2))_PSBSPC,1,19)_" "
- S W=W_$E($E($$GET1^DIQ(53.79,PSBIENS,.06),1,18)_PSBSPC,1,21)_" "
- ;*83 body site info
- N SITE
- S SITE=$$GET1^DIQ(53.79,PSBIENS,.18)
- S:SITE="" SITE=$$GET1^DIQ(53.79,PSBIENS,.16)
- ;S W=W_SITE ; PSB*3*82 rbd Site Info will now go on the next line with the Medication
- ;
- D ADD(W,TYP)
- ; PSB*3.0*82 rbd - put By/Body Site on line with 1st med; keep legend of Initials & Name also
- S WINIT=$$GETINIT^PSBCSUTX(PSBIEN,"I")
- S WNAME=$$GETINIT^PSBCSUTX(PSBIEN,"N")
- I WINIT]"",WNAME]"" S ^TMP("PSB_WINITNAM",$J,WINIT,WNAME)=""
- S W=" "_$E(WINIT_PSBSPC,1,25)_" " ;Get initials of who took action, PSB*3*72 - ln/spacing chg'ed PSB*3*82 rbd
- ;S W=$J("",56)
- ; PSB*3.0*82 rbd find all audit history not just associated Give for Removal
- ;I $P(^PSB(53.79,PSBIEN,0),U,9)="RM" D
- ;.S GIVE=$$FINDGIVE^PSBUTL(PSBIEN)
- ;.S G1=$E($P(GIVE,U,3)_PSBSPC,1,3)
- ;.S G2=$E($P($G(^PSB(53.79,PSBIEN,.1)),U,2)_PSBSPC,1,4)
- ;.S G3=$P(GIVE,U),G3=$E($$UP^XLFSTR($$FMTE^XLFDT(G3,1)),1,18)_$J("",4)
- ;.S G4=$E($P(GIVE,U,2)_PSBSPC,1,6)
- ;.S W=$J("",21)
- ;.S W2=G1_G2_G3_G4
- I $G(^PSB(53.79,PSBIEN,.9,1,0))]"" D
- .S WSUB9CNT=""
- .F S WSUB9CNT=$O(^PSB(53.79,PSBIEN,.9,WSUB9CNT),-1) Q:WSUB9CNT=0 D
- ..S WSUB9=$G(^PSB(53.79,PSBIEN,.9,WSUB9CNT,0)) I WSUB9]"" D
- ...I $P(WSUB9,U,3)["ACTION STATUS Set to" D
- ....S WSUB9BY=$P($P(WSUB9,U,3),"'",4),WSUB9DT=$P(WSUB9,U)
- ....S WOLDSTAT=$E($P(WSUB9,U,4),1,3)
- ....S:WOLDSTAT="REM" WOLDSTAT="RM"
- ....S:WOLDSTAT'="RM" WOLDSTAT=$E(WOLDSTAT)
- ....S W2(WSUB9CNT)=$$STATUS(WOLDSTAT)_U_WSUB9DT_U_WSUB9BY
- ....I WSUB9BY]"" D ; keep legend of init/name PSB*3.0*82 rbd
- .....S WNPIEN=$P(WSUB9,U,5)
- .....S WNAME=$$GET1^DIQ(200,WNPIEN,.01)
- .....I WNAME]"" S ^TMP("PSB_WINITNAM",$J,WSUB9BY,WNAME)=""
- ;
- 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 ;Include units ordered for IV's
- ..; PSB*3.0*82 rbd Send in Units Ordered also to WRAPMEDS
- ..;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
- ..;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
- ..S WUO=$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.02)
- ..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
- ..I PSBDD=53.796!(PSBDD=53.797) D
- ...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
- ; PSB*3.0*82 rbd Add audit info as its own line
- S WSUB9CNT=$O(W2(""),-1) I WSUB9CNT?1N.N K W2(WSUB9CNT)
- S WSUB9CNT="" F S WSUB9CNT=$O(W2(WSUB9CNT),-1) Q:WSUB9CNT="" D
- .S WSUB9=W2(WSUB9CNT),W3=$J("",27),W3=W3_"(Previous Status: "_$E($P(WSUB9,U)_PSBSPC,1,23)
- .S W3=W3_" At "_$$UP^XLFSTR($$FMTE^XLFDT($P(WSUB9,U,2),1))_" By "
- .S W3=W3_$P(WSUB9,U,3)_")" D ADD(W3,TYP)
- ; PSB*3.0*82 rbd Add in PRN Effectiveness info.
- S W=$E($$GET1^DIQ(53.79,PSBIENS,.21)_PSBSPC,1,27)_" "
- I $TR(W," ")]"" D
- .S W=" " D ADD(W,TYP)
- .S W=" "_$E($$GET1^DIQ(53.79,PSBIENS,.21)_PSBSPC,1,27)_" "
- .S W22LINE=$$GET1^DIQ(53.79,PSBIENS,.22)
- .D WRAP2(W22LINE,25,.W22TEXT)
- .S W=W_$E(W22TEXT(1)_PSBSPC,1,27)_" "
- .S W=W_$E($$GET1^DIQ(53.79,PSBIENS,.23)_PSBSPC,1,29)_" "
- .S W=W_$E($$GET1^DIQ(53.79,PSBIENS,.24)_PSBSPC,1,29)
- .D ADD(W,TYP)
- .I W22TEXT>1 F W22NUM=2:1:W22TEXT D
- ..D ADD($J("",33)_W22TEXT(W22NUM),TYP)
- I PSBCOM=1 D COMNTS ;GETS COMMENTS
- D ADD("",TYP)
- Q
- ;
- STATUS(STATABBR) ; Give a full status from abbr - PSB*3.0*82 rbd
- Q:STATABBR="G" "Given" Q:STATABBR="I" "Infusing"
- Q:STATABBR="S" "Stopped" Q:STATABBR="C" "Completed"
- Q:STATABBR="H" "Held" Q:STATABBR="R" "Refused"
- Q:STATABBR="RM" "Removed" Q:STATABBR="M" "Missing Dose Requested"
- Q ""
- ;
- SCHED(SCHABBR) ; Give a full schedule type from abbr - PSB*3.0*82 rbd
- Q:SCHABBR="C" "Continuous" Q:SCHABBR="P" "PRN"
- Q:SCHABBR="O" "One Time" Q:SCHABBR="OC" "On Call"
- Q ""
- ;
- COMNTS ;
- N Z,CNT,PSBCMNT,PSBINIT,PSBNAME,PSBPRREC,XT,XBR ; PSB*3.0*82 rbd keep legend of init/name
- S Z="",CNT=0
- I $D(^PSB(53.79,PSBIEN,.3,0)) D
- .D ADD("",TYP)
- .D ADD($J("",27)_"Comments: "_$$MAKELINE("-",81),TYP) ; PSB*3.0*82 rbd Move Comments to align with Medication
- .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
- ..D:CNT=1 ADD("",TYP)
- ..; PSB*3.0*82 rbd keep legend of init/name
- ..;S Y=$P(^PSB(53.79,PSBIEN,.3,XT,0),"^",3) D DD^%DT S XBR=Y
- ..S PSBCMNT=$G(^PSB(53.79,PSBIEN,.3,XT,0))
- ..S Y=$P(PSBCMNT,"^",3) D DD^%DT S XBR=Y
- ..S PSBPRREC=$G(^VA(200,+$P(PSBCMNT,"^",2),0))
- ..S PSBINIT=$P(PSBPRREC,"^",2)
- ..S PSBNAME=$P(PSBPRREC,"^",1)
- ..I PSBINIT]"",PSBNAME]"" D
- ...S ^TMP("PSB_WINITNAM",$J,PSBINIT,PSBNAME)=""
- ..;S Z=XBR_" "_$P(^VA(200,$P(^PSB(53.79,PSBIEN,.3,XT,0),"^",2),0),"^",2)
- ..S Z=XBR_" "_PSBINIT
- ..D WRAP($P(^PSB(53.79,PSBIEN,.3,XT,0),"^",1),Z,PSBIEN)
- ..S CNT=1
- .D ADD($J("",37)_$$MAKELINE("-",81),TYP) ; PSB*3.0*82 rbd Move Comments to align with Medication
- Q
- ;
- WRAP(SIZE,ZP,BRIEN) ;
- ; PSB*3.0*82 rbd Massaged Comments to possibly be 4 lines using new WRAP2 API
- ;D ADD($J("",56)_ZP,TYP)
- ;D ADD($J("",56)_$E(SIZE,1,75),TYP)
- ;I $L(SIZE)>75 D ADD($J("",56)_$E(SIZE,76,150),TYP)
- N SIZE2,SIZE2NUM D WRAP2(SIZE,50,.SIZE2),ADD($J("",37)_ZP_" "_SIZE2(1),TYP)
- I SIZE2>1 F SIZE2NUM=2:1:SIZE2 D
- .D ADD($J("",66)_SIZE2(SIZE2NUM),TYP)
- Q
- ;
- ; PSB*3.0*82 rbd Put in place more robust wrapping API
- WRAP2(TEXTLINE,MAX,TEXT) ; Splits Text into TEXT array
- N I,J S J=0 K TEXT
- I $L(TEXTLINE)'>MAX S J=J+1,TEXT(J)=TEXTLINE G WRQ
- WR0 ; Loop for Remaining Text
- S I=$F(TEXTLINE," ")
- I ('I)!(I>(MAX+2)) D
- .S J=J+1,TEXT(J)=$E(TEXTLINE,1,MAX)
- .S TEXTLINE=$E(TEXTLINE,MAX+1,999)
- I $L(TEXTLINE)>MAX F I=(MAX+1):-1:1 I $E(TEXTLINE,I)=" " D Q
- .S J=J+1,TEXT(J)=$E(TEXTLINE,1,I-1)
- .S TEXTLINE=$E(TEXTLINE,I+1,999)
- G:$L(TEXTLINE)>MAX WR0
- S:$L(TEXTLINE) J=J+1,TEXT(J)=TEXTLINE
- WRQ ; Quit Wrap
- S TEXT=J
- Q
- ; end new API for PSB*3*82 rbd
- HEADA ;
- W !
- ; PSB*3.0*82 rbd - Expand fields and include new fields
- ;W "Location",?21,"St Sch Administration Date",?50,"By",?61,"Body Site",?96,"Units",?112,"Units of" ;*83
- W ?1,"Location",?27,"Status",?51,"Schedule Type"
- W ?71,"Administration Date",?98,"Units",?109,"Units",?121,"Units of"
- W !?1,"By",?27,"Medication & Dosage",?71,"Body Site"
- W ?97,"Ordered",?109,"GIVEN",?122,"Admin"
- W !!?5,"PRN Reason",?33,"PRN Effectiveness",?61,"Effectiveness Entered By"
- W ?91,"Effectiveness Entered"
- W !
- W $$MAKELINE("-",132)
- Q
- ;
- ADD(XE,TYP) ;
- S ^TMP("PSB",$J,TYP,$O(^TMP("PSB",$J,TYP,""),-1)+1)=XE
- Q
- ;
- ; PSB*3.0*82 rbd Send in Units Ordered as well
- WRAPMEDS(W,SITE,MED,UG,UO,UOA,TYP) ;insert parm W (possible RM string) to print on line 1 *83
- ;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=$S($L(MED)>40:$E(MED_$J("",80),1,80),1:$E(MED_$J("",40),1,40)) ;Add wrapping for med/units ordered
- N UGWRAP,PSBMED1,PSBMED41,PSBMED81,PSBCNT,UOWRAP,CNTX,CNTXX,UOA1,UOA16,UOA31,UOAX ; PSB*3.0*82 rbd Added Units Ordered
- S (CNTX,UOA1,UOA16,UOA31,PSBMED1,PSBMED41,PSBMED81)=""
- I +$G(UG)?1"."1.N S UG=0_+UG
- I +$G(UO)?1"."1.N S UO=0_+UO ; PSB*3.0*82 rbd Units Ordered added
- F CNT=1:15:45 D
- .S PSBCNT=$S(CNT=1:1,CNT=16:41,CNT=31:81,1:120)
- .D PARSEM(MED,PSBCNT)
- .D PARSE(UOA,CNT)
- .S UGWRAP=$E(UG,CNT,(CNT+14))
- .; PSB*3.0*82 rbd Units Ordered & Site handling next 3 lines of code
- .S UOWRAP=$E(UO,CNT,(CNT+14))
- .;P136 reduce SITE_PSBSPC,1,24(25);UOWRAP,9(11);UGWRAP,9(11);$J,97(99);Increase UOA1,15(11); UOA,15(11)
- .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)
- .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)
- Q
- ;
- PAD(X,CNT) ;
- Q $E(X_$J("",CNT),1,CNT)
- WRITEOT ;
- N TPE,PSTRTA,PSTP
- 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)
- .N PSBCLINORD,EX S PSBCLINORD=2 D PT^PSBOHDR(DFN,.PSBHDR),HEADA ;*70
- .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))
- ; PSB*3.0*82 rbd Keep legend of initials & names
- W !!,"Initial - Name Legend"
- S WINIT="" F S WINIT=$O(^TMP("PSB_WINITNAM",$J,WINIT)) Q:WINIT="" D
- .S WNAME="" F S WNAME=$O(^TMP("PSB_WINITNAM",$J,WINIT,WNAME)) Q:WNAME="" D
- ..W !,$E(WINIT_PSBSPC,1,10)_WNAME
- K ^TMP("PSB_WINITNAM",$J)
- 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.
- ;Begin P136
- N VAR
- S VAR="UOA"_CNT
- S @VAR=$E(X,CNT,CNT+14)
- Q
- ;End of P136, the below lines do not need anymore
- 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
- ;
- PARSEM(PSBMED,PSBCNT) ;Split text for wrapping meds, PSB*3*72
- N PSBCNTX,PSBMEDX,PSBMEDX,PSBCNTXX
- S PSBCNTX="PSBMED"_PSBCNT,@PSBCNTX=@PSBCNTX_$E(PSBMED,PSBCNT,(PSBCNT+39)),PSBMEDX=""
- F S:$F(@PSBCNTX,", ",+PSBMEDX)>0 PSBMEDX=$F(@PSBCNTX,", ",+PSBMEDX) Q:'$F(@PSBCNTX,", ",+PSBMEDX)
- I PSBMEDX<1 F S:$F(@PSBCNTX," ",+PSBMEDX)>0 PSBMEDX=$F(@PSBCNTX," ",+PSBMEDX) Q:'$F(@PSBCNTX," ",+PSBMEDX)
- 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
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBOPM 17317 printed Feb 18, 2025@23:07:14 Page 2
- 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
- +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 ;
- +11 ;*70 - reset PSBCLINORD = 2 to signify combined orders report
- +12 ;*83 - add Give info associated with a Remove and print
- +13 ;
- EN ;
- +1 NEW PSBHDR,DFN,PSBGBL,X1,X2,PSBSTRT,PSBSTOP,PSBCOM,PSBSPC
- +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 NEW PSBOR
- +3 ;
- +4 ;IF PSBORDNM DOESN'T CONTAIN A "U" OR A "V", SKIP THE ORDER LOOKUP
- +5 SET PSBOR=1
- +6 IF PSBORDNM'["U"
- IF PSBORDNM'["V"
- Begin DoDot:1
- +7 if '$$GETORD^PSBOPM1(.PSBORDNM)
- SET PSBOR=0
- +8 IF 'PSBOR&(PSBORDNM]"")
- SET TMP("PSBOIS",$JOB,PSBORDNM)=""
- End DoDot:1
- +9 IF PSBOR
- Begin DoDot:1
- +10 DO GETORDN
- +11 DO GETOIS
- End DoDot:1
- +12 ; GET ALL ADDITIVES AND SOLUTIONS
- DO GETADSO
- +13 ; FIND EVERY MED LOG ENTRIES THAT SHOULD BE ON THE RPT
- DO FINDIENS^PSBOPM1
- +14 ; WRITE DATA TO GLOBAL
- DO PREOUT
- +15 ;
- DO WRITEOT
- +16 ; CLEAN UP AND LEAVE LIST OF IENS FOR THE REPORT.
- DO CLEANSUM
- +17 QUIT
- +18 ;
- 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 NEW PSBOI,XXX,XXY,PSBADD,PSBSOL
- +2 IF PSBORDNM["U"
- Begin DoDot:1
- +3 ;GET UNIT DOSE ORDERS
- +4 IF $DATA(^TMP("PSJ1",$JOB,2))
- Begin DoDot:2
- +5 SET PSBOI=$PIECE(^TMP("PSJ1",$JOB,2),"^")
- +6 SET PSBOI=$SELECT(PSBOI["U":$TRANSLATE(PSBOI,"U",""),PSBOI["V":$TRANSLATE(PSBOI,"V",""),1:PSBOI)
- +7 SET TMP("PSBOIS",$JOB,PSBOI)=""
- End DoDot:2
- End DoDot:1
- +8 ;
- +9 ;IV ORDERS NEED TO USE THE ADDITIVE AND SOLUTION NUMBER TO BACK
- +10 ;TRACK TO THE OI ASSOCIATED WITH IT
- +11 IF PSBORDNM["V"
- Begin DoDot:1
- +12 ;GET ADDITIVES OFF THE ORDER
- +13 IF $GET(^TMP("PSJ1",$JOB,850,0))
- Begin DoDot:2
- +14 SET XXX=""
- FOR
- SET XXX=$ORDER(^TMP("PSJ1",$JOB,850,XXX))
- if XXX=""
- QUIT
- Begin DoDot:3
- +15 SET XXY=""
- FOR
- SET XXY=$ORDER(^TMP("PSJ1",$JOB,850,XXX,XXY))
- if XXY=""
- QUIT
- Begin DoDot:4
- +16 SET PSBADD=$PIECE(^TMP("PSJ1",$JOB,850,XXX,XXY),"^")
- +17 ;CONVERT ADDITIVE TO ORDERABLE ITEM AND ADD TO LIST
- +18 SET TMP("PSBOIS",$JOB,$$OFROMA(PSBADD))=""
- End DoDot:4
- End DoDot:3
- End DoDot:2
- +19 ; GET SOLUTIONS OFF THE ORDER
- +20 IF $GET(^TMP("PSJ1",$JOB,950,0))
- Begin DoDot:2
- +21 SET XXX=""
- FOR
- SET XXX=$ORDER(^TMP("PSJ1",$JOB,950,XXX))
- if XXX=""
- QUIT
- Begin DoDot:3
- +22 SET XXY=""
- FOR
- SET XXY=$ORDER(^TMP("PSJ1",$JOB,950,XXX,XXY))
- if XXY=""
- QUIT
- Begin DoDot:4
- +23 SET PSBSOL=$PIECE(^TMP("PSJ1",$JOB,950,XXX,XXY),"^")
- +24 ; PSB*3.0*82 rbd Do not do pre-mix when additive present
- IF $GET(^TMP("PSJ1",$JOB,850,0))
- if $$GET1^DIQ(52.7,PSBSOL_",",18)'="YES"
- QUIT
- +25 ;
- +26 ;CONVERT SOLUTIOIN TO ORDERABLE ITEM AND ADD TO LIST
- +27 SET TMP("PSBOIS",$JOB,$$OFROMS(PSBSOL))=""
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +28 QUIT
- +29 ;
- 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 NEW PSBAOUT,PSBSOUT,XA,XB
- +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 I,TYP,XDT,PSBIEN,PSBIENS
- +2 FOR TYP="UD","ADD","SOL"
- Begin DoDot:1
- +3 if '$DATA(TMP("PSBIENS",$JOB,TYP))
- QUIT
- +4 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 NEW GIVE,G1,G2,G3,G4
- +2 ; added new local variables for PSB*3.0*82 rbd - also New'ing W & PSBUNK variables
- +3 NEW PSBUNK,W,W2,W22LINE,W22NUM,W22TEXT,W3,WCURSTAT,WINIT,WNAME
- +4 NEW WNPIEN,WOLDSTAT,WSUB9,WSUB9BY,WSUB9CNT,WSUB9DT,WUO,PSBNODE,PSBY,PSBDD
- +5 SET PSBSPC=$JUSTIFY("",80)
- +6 ; PSB*3.0*82 rbd - more room for LOCATION; chg'ed 20 to 25
- +7 SET W=" "_$EXTRACT($$GET1^DIQ(53.79,PSBIENS,.02)_PSBSPC,1,25)_" "
- +8 IF $TRANSLATE(W," ")=""
- IF $$MME^PSBOML(+PSBIENS)
- SET W=" MME/UNKNOWN LOCATION "
- +9 ; PSB*3.0*82 rbd - do not output status/sch type abbrevs anymore
- +10 ;S W=W_$S($P(^PSB(53.79,PSBIEN,0),U,9)="":"?? ",1:$E($P(^PSB(53.79,PSBIEN,0),U,9)_" ",1,2)_" ")
- +11 SET PSBUNK=0
- if $PIECE(^PSB(53.79,PSBIEN,0),U,9)=""
- SET PSBUNK=1
- +12 ;S W=W_$E($P($G(^PSB(53.79,PSBIEN,.1)),U,2)_PSBSPC,1,2)_" "
- +13 ; PSB*3.0*82 rbd - Status & Schedule Type spelled out now (unabbreviated)
- +14 SET WCURSTAT=$SELECT(PSBUNK:"Unknown Status",1:$PIECE($GET(^PSB(53.79,PSBIEN,0)),U,9))
- +15 SET W=W_$EXTRACT($$STATUS(WCURSTAT)_PSBSPC,1,23)_" "
- +16 SET W=W_$EXTRACT($$SCHED($PIECE($GET(^PSB(53.79,PSBIEN,.1)),U,2))_PSBSPC,1,19)_" "
- +17 SET W=W_$EXTRACT($EXTRACT($$GET1^DIQ(53.79,PSBIENS,.06),1,18)_PSBSPC,1,21)_" "
- +18 ;*83 body site info
- +19 NEW SITE
- +20 SET SITE=$$GET1^DIQ(53.79,PSBIENS,.18)
- +21 if SITE=""
- SET SITE=$$GET1^DIQ(53.79,PSBIENS,.16)
- +22 ;S W=W_SITE ; PSB*3*82 rbd Site Info will now go on the next line with the Medication
- +23 ;
- +24 DO ADD(W,TYP)
- +25 ; PSB*3.0*82 rbd - put By/Body Site on line with 1st med; keep legend of Initials & Name also
- +26 SET WINIT=$$GETINIT^PSBCSUTX(PSBIEN,"I")
- +27 SET WNAME=$$GETINIT^PSBCSUTX(PSBIEN,"N")
- +28 IF WINIT]""
- IF WNAME]""
- SET ^TMP("PSB_WINITNAM",$JOB,WINIT,WNAME)=""
- +29 ;Get initials of who took action, PSB*3*72 - ln/spacing chg'ed PSB*3*82 rbd
- SET W=" "_$EXTRACT(WINIT_PSBSPC,1,25)_" "
- +30 ;S W=$J("",56)
- +31 ; PSB*3.0*82 rbd find all audit history not just associated Give for Removal
- +32 ;I $P(^PSB(53.79,PSBIEN,0),U,9)="RM" D
- +33 ;.S GIVE=$$FINDGIVE^PSBUTL(PSBIEN)
- +34 ;.S G1=$E($P(GIVE,U,3)_PSBSPC,1,3)
- +35 ;.S G2=$E($P($G(^PSB(53.79,PSBIEN,.1)),U,2)_PSBSPC,1,4)
- +36 ;.S G3=$P(GIVE,U),G3=$E($$UP^XLFSTR($$FMTE^XLFDT(G3,1)),1,18)_$J("",4)
- +37 ;.S G4=$E($P(GIVE,U,2)_PSBSPC,1,6)
- +38 ;.S W=$J("",21)
- +39 ;.S W2=G1_G2_G3_G4
- +40 IF $GET(^PSB(53.79,PSBIEN,.9,1,0))]""
- Begin DoDot:1
- +41 SET WSUB9CNT=""
- +42 FOR
- SET WSUB9CNT=$ORDER(^PSB(53.79,PSBIEN,.9,WSUB9CNT),-1)
- if WSUB9CNT=0
- QUIT
- Begin DoDot:2
- +43 SET WSUB9=$GET(^PSB(53.79,PSBIEN,.9,WSUB9CNT,0))
- IF WSUB9]""
- Begin DoDot:3
- +44 IF $PIECE(WSUB9,U,3)["ACTION STATUS Set to"
- Begin DoDot:4
- +45 SET WSUB9BY=$PIECE($PIECE(WSUB9,U,3),"'",4)
- SET WSUB9DT=$PIECE(WSUB9,U)
- +46 SET WOLDSTAT=$EXTRACT($PIECE(WSUB9,U,4),1,3)
- +47 if WOLDSTAT="REM"
- SET WOLDSTAT="RM"
- +48 if WOLDSTAT'="RM"
- SET WOLDSTAT=$EXTRACT(WOLDSTAT)
- +49 SET W2(WSUB9CNT)=$$STATUS(WOLDSTAT)_U_WSUB9DT_U_WSUB9BY
- +50 ; keep legend of init/name PSB*3.0*82 rbd
- IF WSUB9BY]""
- Begin DoDot:5
- +51 SET WNPIEN=$PIECE(WSUB9,U,5)
- +52 SET WNAME=$$GET1^DIQ(200,WNPIEN,.01)
- +53 IF WNAME]""
- SET ^TMP("PSB_WINITNAM",$JOB,WSUB9BY,WNAME)=""
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +54 ;
- +55 FOR PSBNODE=.5,.6,.7
- Begin DoDot:1
- +56 SET PSBDD=$SELECT(PSBNODE=.5:53.795,PSBNODE=.6:53.796,1:53.797)
- +57 ;Include units ordered for IV's
- FOR PSBY=0:0
- SET PSBY=$ORDER(^PSB(53.79,PSBIEN,PSBNODE,PSBY))
- if 'PSBY
- QUIT
- Begin DoDot:2
- +58 ; PSB*3.0*82 rbd Send in Units Ordered also to WRAPMEDS
- +59 ;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
- +60 ;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
- +61 SET WUO=$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.02)
- +62 ;insert W to Wrapmeds tag *83
- if PSBDD=53.795
- DO WRAPMEDS(W,SITE,$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.01),$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.03),WUO,$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.04),TYP)
- +63 IF PSBDD=53.796!(PSBDD=53.797)
- Begin DoDot:3
- +64 ;insert W to wrapmeds *83
- DO WRAPMEDS(W,SITE,$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.01)_" - "_WUO,$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.03),WUO,$$GET1^DIQ(PSBDD,PSBY_","_PSBIENS,.04),TYP)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +65 ; PSB*3.0*82 rbd Add audit info as its own line
- +66 SET WSUB9CNT=$ORDER(W2(""),-1)
- IF WSUB9CNT?1N.N
- KILL W2(WSUB9CNT)
- +67 SET WSUB9CNT=""
- FOR
- SET WSUB9CNT=$ORDER(W2(WSUB9CNT),-1)
- if WSUB9CNT=""
- QUIT
- Begin DoDot:1
- +68 SET WSUB9=W2(WSUB9CNT)
- SET W3=$JUSTIFY("",27)
- SET W3=W3_"(Previous Status: "_$EXTRACT($PIECE(WSUB9,U)_PSBSPC,1,23)
- +69 SET W3=W3_" At "_$$UP^XLFSTR($$FMTE^XLFDT($PIECE(WSUB9,U,2),1))_" By "
- +70 SET W3=W3_$PIECE(WSUB9,U,3)_")"
- DO ADD(W3,TYP)
- End DoDot:1
- +71 ; PSB*3.0*82 rbd Add in PRN Effectiveness info.
- +72 SET W=$EXTRACT($$GET1^DIQ(53.79,PSBIENS,.21)_PSBSPC,1,27)_" "
- +73 IF $TRANSLATE(W," ")]""
- Begin DoDot:1
- +74 SET W=" "
- DO ADD(W,TYP)
- +75 SET W=" "_$EXTRACT($$GET1^DIQ(53.79,PSBIENS,.21)_PSBSPC,1,27)_" "
- +76 SET W22LINE=$$GET1^DIQ(53.79,PSBIENS,.22)
- +77 DO WRAP2(W22LINE,25,.W22TEXT)
- +78 SET W=W_$EXTRACT(W22TEXT(1)_PSBSPC,1,27)_" "
- +79 SET W=W_$EXTRACT($$GET1^DIQ(53.79,PSBIENS,.23)_PSBSPC,1,29)_" "
- +80 SET W=W_$EXTRACT($$GET1^DIQ(53.79,PSBIENS,.24)_PSBSPC,1,29)
- +81 DO ADD(W,TYP)
- +82 IF W22TEXT>1
- FOR W22NUM=2:1:W22TEXT
- Begin DoDot:2
- +83 DO ADD($JUSTIFY("",33)_W22TEXT(W22NUM),TYP)
- End DoDot:2
- End DoDot:1
- +84 ;GETS COMMENTS
- IF PSBCOM=1
- DO COMNTS
- +85 DO ADD("",TYP)
- +86 QUIT
- +87 ;
- STATUS(STATABBR) ; Give a full status from abbr - PSB*3.0*82 rbd
- +1 if STATABBR="G"
- QUIT "Given"
- if STATABBR="I"
- QUIT "Infusing"
- +2 if STATABBR="S"
- QUIT "Stopped"
- if STATABBR="C"
- QUIT "Completed"
- +3 if STATABBR="H"
- QUIT "Held"
- if STATABBR="R"
- QUIT "Refused"
- +4 if STATABBR="RM"
- QUIT "Removed"
- if STATABBR="M"
- QUIT "Missing Dose Requested"
- +5 QUIT ""
- +6 ;
- SCHED(SCHABBR) ; Give a full schedule type from abbr - PSB*3.0*82 rbd
- +1 if SCHABBR="C"
- QUIT "Continuous"
- if SCHABBR="P"
- QUIT "PRN"
- +2 if SCHABBR="O"
- QUIT "One Time"
- if SCHABBR="OC"
- QUIT "On Call"
- +3 QUIT ""
- +4 ;
- COMNTS ;
- +1 ; PSB*3.0*82 rbd keep legend of init/name
- NEW Z,CNT,PSBCMNT,PSBINIT,PSBNAME,PSBPRREC,XT,XBR
- +2 SET Z=""
- SET CNT=0
- +3 IF $DATA(^PSB(53.79,PSBIEN,.3,0))
- Begin DoDot:1
- +4 DO ADD("",TYP)
- +5 ; PSB*3.0*82 rbd Move Comments to align with Medication
- DO ADD($JUSTIFY("",27)_"Comments: "_$$MAKELINE("-",81),TYP)
- +6 ; PSB*3.0*82 rbd reverse chronological for comments also
- SET XT=""
- FOR
- SET XT=$ORDER(^PSB(53.79,PSBIEN,.3,XT),-1)
- if XT=""
- QUIT
- IF XT'=0
- Begin DoDot:2
- +7 if CNT=1
- DO ADD("",TYP)
- +8 ; PSB*3.0*82 rbd keep legend of init/name
- +9 ;S Y=$P(^PSB(53.79,PSBIEN,.3,XT,0),"^",3) D DD^%DT S XBR=Y
- +10 SET PSBCMNT=$GET(^PSB(53.79,PSBIEN,.3,XT,0))
- +11 SET Y=$PIECE(PSBCMNT,"^",3)
- DO DD^%DT
- SET XBR=Y
- +12 SET PSBPRREC=$GET(^VA(200,+$PIECE(PSBCMNT,"^",2),0))
- +13 SET PSBINIT=$PIECE(PSBPRREC,"^",2)
- +14 SET PSBNAME=$PIECE(PSBPRREC,"^",1)
- +15 IF PSBINIT]""
- IF PSBNAME]""
- Begin DoDot:3
- +16 SET ^TMP("PSB_WINITNAM",$JOB,PSBINIT,PSBNAME)=""
- End DoDot:3
- +17 ;S Z=XBR_" "_$P(^VA(200,$P(^PSB(53.79,PSBIEN,.3,XT,0),"^",2),0),"^",2)
- +18 SET Z=XBR_" "_PSBINIT
- +19 DO WRAP($PIECE(^PSB(53.79,PSBIEN,.3,XT,0),"^",1),Z,PSBIEN)
- +20 SET CNT=1
- End DoDot:2
- +21 ; PSB*3.0*82 rbd Move Comments to align with Medication
- DO ADD($JUSTIFY("",37)_$$MAKELINE("-",81),TYP)
- End DoDot:1
- +22 QUIT
- +23 ;
- WRAP(SIZE,ZP,BRIEN) ;
- +1 ; PSB*3.0*82 rbd Massaged Comments to possibly be 4 lines using new WRAP2 API
- +2 ;D ADD($J("",56)_ZP,TYP)
- +3 ;D ADD($J("",56)_$E(SIZE,1,75),TYP)
- +4 ;I $L(SIZE)>75 D ADD($J("",56)_$E(SIZE,76,150),TYP)
- +5 NEW SIZE2,SIZE2NUM
- DO WRAP2(SIZE,50,.SIZE2)
- DO ADD($JUSTIFY("",37)_ZP_" "_SIZE2(1),TYP)
- +6 IF SIZE2>1
- FOR SIZE2NUM=2:1:SIZE2
- Begin DoDot:1
- +7 DO ADD($JUSTIFY("",66)_SIZE2(SIZE2NUM),TYP)
- End DoDot:1
- +8 QUIT
- +9 ;
- +10 ; PSB*3.0*82 rbd Put in place more robust wrapping API
- WRAP2(TEXTLINE,MAX,TEXT) ; Splits Text into TEXT array
- +1 NEW I,J
- SET J=0
- KILL TEXT
- +2 IF $LENGTH(TEXTLINE)'>MAX
- SET J=J+1
- SET TEXT(J)=TEXTLINE
- GOTO WRQ
- WR0 ; Loop for Remaining Text
- +1 SET I=$FIND(TEXTLINE," ")
- +2 IF ('I)!(I>(MAX+2))
- Begin DoDot:1
- +3 SET J=J+1
- SET TEXT(J)=$EXTRACT(TEXTLINE,1,MAX)
- +4 SET TEXTLINE=$EXTRACT(TEXTLINE,MAX+1,999)
- End DoDot:1
- +5 IF $LENGTH(TEXTLINE)>MAX
- FOR I=(MAX+1):-1:1
- IF $EXTRACT(TEXTLINE,I)=" "
- Begin DoDot:1
- +6 SET J=J+1
- SET TEXT(J)=$EXTRACT(TEXTLINE,1,I-1)
- +7 SET TEXTLINE=$EXTRACT(TEXTLINE,I+1,999)
- End DoDot:1
- QUIT
- +8 if $LENGTH(TEXTLINE)>MAX
- GOTO WR0
- +9 if $LENGTH(TEXTLINE)
- SET J=J+1
- SET TEXT(J)=TEXTLINE
- WRQ ; Quit Wrap
- +1 SET TEXT=J
- +2 QUIT
- +3 ; end new API for PSB*3*82 rbd
- HEADA ;
- +1 WRITE !
- +2 ; PSB*3.0*82 rbd - Expand fields and include new fields
- +3 ;W "Location",?21,"St Sch Administration Date",?50,"By",?61,"Body Site",?96,"Units",?112,"Units of" ;*83
- +4 WRITE ?1,"Location",?27,"Status",?51,"Schedule Type"
- +5 WRITE ?71,"Administration Date",?98,"Units",?109,"Units",?121,"Units of"
- +6 WRITE !?1,"By",?27,"Medication & Dosage",?71,"Body Site"
- +7 WRITE ?97,"Ordered",?109,"GIVEN",?122,"Admin"
- +8 WRITE !!?5,"PRN Reason",?33,"PRN Effectiveness",?61,"Effectiveness Entered By"
- +9 WRITE ?91,"Effectiveness Entered"
- +10 WRITE !
- +11 WRITE $$MAKELINE("-",132)
- +12 QUIT
- +13 ;
- ADD(XE,TYP) ;
- +1 SET ^TMP("PSB",$JOB,TYP,$ORDER(^TMP("PSB",$JOB,TYP,""),-1)+1)=XE
- +2 QUIT
- +3 ;
- +4 ; PSB*3.0*82 rbd Send in Units Ordered as well
- 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
- +2 ;UG/UOA MAX AT 30/40 AND WILL BE WRAPPED AT 15 EACH
- +3 ;THIS WILL CREATE UPTO 3 LINES
- +4 ;Add wrapping for med/units ordered
- SET MED=$SELECT($LENGTH(MED)>40:$EXTRACT(MED_$JUSTIFY("",80),1,80),1:$EXTRACT(MED_$JUSTIFY("",40),1,40))
- +5 ; PSB*3.0*82 rbd Added Units Ordered
- NEW UGWRAP,PSBMED1,PSBMED41,PSBMED81,PSBCNT,UOWRAP,CNTX,CNTXX,UOA1,UOA16,UOA31,UOAX
- +6 SET (CNTX,UOA1,UOA16,UOA31,PSBMED1,PSBMED41,PSBMED81)=""
- +7 IF +$GET(UG)?1"."1.N
- SET UG=0_+UG
- +8 ; PSB*3.0*82 rbd Units Ordered added
- IF +$GET(UO)?1"."1.N
- SET UO=0_+UO
- +9 FOR CNT=1:15:45
- Begin DoDot:1
- +10 SET PSBCNT=$SELECT(CNT=1:1,CNT=16:41,CNT=31:81,1:120)
- +11 DO PARSEM(MED,PSBCNT)
- +12 DO PARSE(UOA,CNT)
- +13 SET UGWRAP=$EXTRACT(UG,CNT,(CNT+14))
- +14 ; PSB*3.0*82 rbd Units Ordered & Site handling next 3 lines of code
- +15 SET UOWRAP=$EXTRACT(UO,CNT,(CNT+14))
- +16 ;P136 reduce SITE_PSBSPC,1,24(25);UOWRAP,9(11);UGWRAP,9(11);$J,97(99);Increase UOA1,15(11); UOA,15(11)
- +17 IF CNT=1
- DO ADD(W_$EXTRACT(MED_PSBSPC,1,43)_" "_$EXTRACT(SITE_PSBSPC,1,24)_" "_$$PAD(UOWRAP,9)_" "_$$PAD(UGWRAP,9)_" "_$$PAD(UOA1,15),TYP)
- +18 IF (CNT>1)
- IF ($LENGTH(UGWRAP)>0!$LENGTH(@("UOA"_CNT))>0)
- DO ADD($JUSTIFY("",97)_$$PAD(UOWRAP,9)_" "_$$PAD(UGWRAP,9)_" "_$$PAD(@("UOA"_CNT),15),TYP)
- End DoDot:1
- +19 QUIT
- +20 ;
- PAD(X,CNT) ;
- +1 QUIT $EXTRACT(X_$JUSTIFY("",CNT),1,CNT)
- WRITEOT ;
- +1 NEW TPE,PSTRTA,PSTP
- +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 ;*70
- NEW PSBCLINORD,EX
- SET PSBCLINORD=2
- 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 ; PSB*3.0*82 rbd Keep legend of initials & names
- +15 WRITE !!,"Initial - Name Legend"
- +16 SET WINIT=""
- FOR
- SET WINIT=$ORDER(^TMP("PSB_WINITNAM",$JOB,WINIT))
- if WINIT=""
- QUIT
- Begin DoDot:1
- +17 SET WNAME=""
- FOR
- SET WNAME=$ORDER(^TMP("PSB_WINITNAM",$JOB,WINIT,WNAME))
- if WNAME=""
- QUIT
- Begin DoDot:2
- +18 WRITE !,$EXTRACT(WINIT_PSBSPC,1,10)_WNAME
- End DoDot:2
- End DoDot:1
- +19 KILL ^TMP("PSB_WINITNAM",$JOB)
- +20 WRITE $$PTFTR^PSBOHDR()
- +21 QUIT
- +22 ;
- 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 ;Begin P136
- +2 NEW VAR
- +3 SET VAR="UOA"_CNT
- +4 SET @VAR=$EXTRACT(X,CNT,CNT+14)
- +5 QUIT
- +6 ;End of P136, the below lines do not need anymore
- +7 SET CNTX="UOA"_CNT
- SET @CNTX=@CNTX_$EXTRACT(X,CNT,(CNT+14))
- SET UOAX=""
- +8 FOR
- if $FIND(@CNTX,", ",+UOAX)>0
- SET UOAX=$FIND(@CNTX,", ",+UOAX)
- if '$FIND(@CNTX,", ",+UOAX)
- QUIT
- +9 IF UOAX<1
- FOR
- if $FIND(@CNTX," ",+UOAX)>0
- SET UOAX=$FIND(@CNTX," ",+UOAX)
- if '$FIND(@CNTX," ",+UOAX)
- QUIT
- +10 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
- +11 QUIT
- +12 ;
- PARSEM(PSBMED,PSBCNT) ;Split text for wrapping meds, PSB*3*72
- +1 NEW PSBCNTX,PSBMEDX,PSBMEDX,PSBCNTXX
- +2 SET PSBCNTX="PSBMED"_PSBCNT
- SET @PSBCNTX=@PSBCNTX_$EXTRACT(PSBMED,PSBCNT,(PSBCNT+39))
- SET PSBMEDX=""
- +3 FOR
- if $FIND(@PSBCNTX,", ",+PSBMEDX)>0
- SET PSBMEDX=$FIND(@PSBCNTX,", ",+PSBMEDX)
- if '$FIND(@PSBCNTX,", ",+PSBMEDX)
- QUIT
- +4 IF PSBMEDX<1
- FOR
- if $FIND(@PSBCNTX," ",+PSBMEDX)>0
- SET PSBMEDX=$FIND(@PSBCNTX," ",+PSBMEDX)
- if '$FIND(@PSBCNTX," ",+PSBMEDX)
- QUIT
- +5 IF PSBMEDX>1
- IF (($LENGTH(MED)-(PSBCNT+39))>0)
- SET PSBCNTXX=$EXTRACT(@PSBCNTX,1,PSBMEDX-1)
- SET @("PSBMED"_(PSBCNT+40))=$EXTRACT(@PSBCNTX,PSBMEDX,PSBMEDX+39)
- SET @PSBCNTX=PSBCNTXX
- +6 QUIT