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

PSBOCI.m

Go to the documentation of this file. 
  1. PSBOCI ;BIRMINGHAM/TEJ-COVERSHEET IV OVERVIEW REPORT ;Mar 2004
  1.  ;;3.0;BAR CODE MED ADMIN;**32**;Mar 2004;Build 32
  1.  ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
  1.  ;
  1.  ; Reference/IA
  1.  ; File 4/10090
  1. EN ;
  1.  N PSBX1X,RESULTS,RESULT,PSBFUTR
  1.  S PSBFUTR=$TR(PSBRPT(1),"~","^")
  1.  S (PSBOCRIT,PSBXFLG,PSBCFLG,PSBBGX)=""  ; srch crit - "A"ctive,"D"C ed,"E"xpired"
  1.  S PSBOCRIT="DEA"
  1.  S:$P(PSBFUTR,U,11) PSBXFLG=1
  1.  S:$P(PSBFUTR,U,12) PSBBGX=PSBBGX_"I"
  1.  S:$P(PSBFUTR,U,13) PSBBGX=PSBBGX_"S"
  1.  S:$P(PSBFUTR,U,14) PSBBGX=PSBBGX_"A"
  1.  I $D(PSBRPT(.2)) I $P(PSBRPT(.2),U,8) S PSBCFLG=1
  1.  K PSBSRTBY,PSBCMT,PSBADM,PSBDATA,PSBOUTP,PSBLGD
  1.  S PSBSORT=1
  1.  D NOW^%DTC S (Y,PSBNOWX)=% D DD^%DT S PSBDTTM=Y
  1.  D GETPAR^PSBPAR("ALL","PSB ADMIN BEFORE")
  1.  S PSBB4=0 S:RESULTS(0)>0 PSBB4=+RESULTS(0)
  1.  D GETPAR^PSBPAR("ALL","PSB ADMIN AFTER")
  1.  S PSBAFT=0 S:RESULTS(0)>0 PSBAFT=+RESULTS(0)
  1.  K ^XTMP("PSBO",$J,"PSBLIST")
  1.  S (PSBPGNUM,PSBLNTOT)=""
  1.  K PSBLIST,PSBLIST2
  1.  S PSBXDFN=$P(PSBRPT(.1),U,2)
  1.  S PSBLIST(PSBXDFN)=""
  1.  S (PSBX1X,PSBTOT)=0
  1.  F  S PSBX1X=$O(PSBLIST(PSBX1X)) Q:+PSBX1X=0  D
  1.  .D RPC^PSBCSUTL(.PSBAREA,PSBX1X)
  1.  .M PSBDATA=@PSBAREA
  1.  .S PSBX2X=1
  1.  .S (PSBLIST2("All Other"),PSBLIST2("Infusing"),PSBLIST2("Stopped"),PSBLIST2(" * NO * "))=0
  1.  .K PSBBSO
  1.  .F  S PSBX2X=$O(PSBDATA(PSBX2X)) Q:+PSBX2X=0  D
  1.  ..S PSBDATA=PSBDATA(PSBX2X)
  1.  ..I $P(PSBDATA,U)="ORD" K PSBORDN,PSBDRUGN D  Q
  1.  ...S PSBEND=0
  1.  ...S PSBTB=$P(PSBDATA,U,29) S PSBTB=$S(PSBTB=1:"UD",PSBTB=2:"IVPB",PSBTB=3:"IV",1:" * ERROR * ")
  1.  ...I (PSBTB'="IV") F PSBX2X=PSBX2X:1 D  Q:PSBEND>0
  1.  ....S PSBEND=0 I $P(PSBDATA(PSBX2X),U)="END" S PSBEND=PSBX2X
  1.  ...Q:PSBEND>0
  1.  ...S PSBSTS1=$P(PSBDATA,U,23)
  1.  ...S PSBSTS=$S((PSBSTS1="A")&(($P(PSBDATA,U,27)>PSBNOWX)):"Active",PSBSTS1="H":"On Hold",PSBSTS1="D":"Discontinued",PSBSTS1="DE":"Discontinued (Edit)",(PSBSTS1="E")!($P(PSBDATA,U,27)'>PSBNOWX):"Expired",1:" * ERROR * ")
  1.  ...S V=$$FMADD^XLFDT(PSBNOWX,,,PSBB4)
  1.  ...S PSBSTSX=$S($P(PSBDATA,U,27)'>PSBNOWX:"EXPIRED/DC'd",$P(PSBDATA,U,22)'>V:"ACTIVE",V:"FUTURE",1:" * ERROR * ")
  1.  ...I PSBSTSX=" * ERROR * "  F PSBX2X=PSBX2X:1 D  Q:PSBEND>0
  1.  ....S PSBEND=0 I $P(PSBDATA(PSBX2X),U)="END" S PSBEND=PSBX2X
  1.  ...Q:PSBEND>0
  1.  ...S PSBORDN=$P(PSBDATA,U,3)
  1.  ...S PSBORITX=$P(PSBDATA,U,9)
  1.  ...S PSBSTS(PSBORDN,PSBSTS)=""
  1.  ...S PSBOSTDT=$P(PSBDATA,U,22)
  1.  ...S PSBOSTDT(PSBORDN,PSBOSTDT)=""
  1.  ...S PSBOSPDT=$P(PSBDATA,U,27)
  1.  ...S PSBOSPDT(PSBORDN,PSBOSPDT)=""
  1.  ...S PSBDOSR=$P(PSBDATA,U,10)_", "_$P(PSBDATA,U,11)
  1.  ...S PSBDOSR=$TR($E(PSBDOSR,1)," ")_$E(PSBDOSR,2,999)
  1.  ...S PSBDOSR(PSBORDN,PSBDOSR)=""
  1.  ...S X2="A",PSBLIST2("All Other",PSBORITX,PSBORDN,"*NA*")=" "
  1.  ...S PSBBSO(PSBORDN)="" S:$G(PSBSTSX)="ACTIVE" PSBBSO(PSBORDN)="AVAILABLE"
  1.  ..Q:'$D(PSBORDN)
  1.  ..I $P(PSBDATA,U)="ORC" D  Q
  1.  ...S PSBSI=$P(PSBDATA(PSBX2X),U,2)
  1.  ...I PSBSI]" " S PSBSI(PSBORDN,PSBSI)=""
  1.  ..Q:'$D(PSBORDN)
  1.  ..I "^DD^ADD^SOL"[(U_$P(PSBDATA(PSBX2X),U)) D  Q
  1.  ...F I=PSBX2X:1 S PSBDATA1=PSBDATA(I) D  Q:$D(PSBOMDR(PSBORDN))
  1.  ....I "^DD^ADD^SOL"[(U_$P(PSBDATA1,U)) S PSBX2X=I S PSBDRUGN=$G(PSBDRUGN,"")_$P(PSBDATA1,U,3)_", " Q
  1.  ....S $E(PSBDRUGN,$L(PSBDRUGN)-1)="" S PSBDRUGN(PSBORDN,$E(PSBDRUGN,1,250))=PSBDRUGN
  1.  ....S PSBOMDR(PSBORDN,$E((PSBDRUGN_"; "_PSBDOSR),1,250))=PSBDRUGN_"; "_PSBDOSR
  1.  ..Q:'$D(PSBORDN)
  1.  ..I $P(PSBDATA,U)="ORF" D  Q
  1.  ...S:$P(PSBDATA,U,2)]"" PSBFLGD(PSBORDN,$P(PSBDATA,U,3)_" - "_$P(PSBDATA,U,4))=""
  1.  ..Q:'$D(PSBORDN)
  1.  ..I $P(PSBDATA,U)="ID"  D  Q
  1.  ...F PSBX3X=PSBX2X:1 S PSBDATA=PSBDATA(PSBX3X) Q:($P(PSBDATA,U)'="ID")  D
  1.  ....S PSBX2X=PSBX3X
  1.  ....K X2
  1.  ....S X2="A",PSBLIST2("All Other",PSBORITX,PSBORDN,$P(PSBDATA,U,2))=PSBBSO(PSBORDN) I $D(PSBLIST2("All Other",PSBORITX,PSBORDN,"*NA*")) K PSBLIST2("All Other",PSBORITX,PSBORDN,"*NA*")
  1.  ..Q:'$D(PSBORDN)
  1.  ..I ($P(PSBDATA,U)="ADM")&($P(PSBDATA,U,4)]"") D  Q
  1.  ...I $P(PSBDATA,U,3)]"" D
  1.  ....K X2
  1.  ....S PSBBID(PSBORDN,$P(PSBDATA,U,3))=""
  1.  ....I $P(^PSB(53.79,$P(PSBDATA,U,4),0),U,9)="I" S X2="I",PSBLIST2("Infusing")=PSBLIST2("Infusing")+1,PSBLIST2("Infusing",PSBORITX,PSBORDN,$P(PSBDATA,U,3))="INFUSING"
  1.  ....I $P(^PSB(53.79,$P(PSBDATA,U,4),0),U,9)="S" S X2="S",PSBLIST2("Stopped")=PSBLIST2("Stopped")+1,PSBLIST2("Stopped",PSBORITX,PSBORDN,$P(PSBDATA,U,3))="STOPPED"
  1.  ....I PSBBGX[$G(X2,"A") S:PSBXFLG PSBLGD(PSBORDN,"INITIALS",$P(PSBDATA,U,8))=""
  1.  ....S:'$D(X2) X2="A",PSBLIST2("All Other",PSBORITX,PSBORDN,$P(PSBDATA,U,3))=$$GET1^DIQ(53.79,$P(PSBDATA,U,4)_",","ACTION STATUS")
  1.  ....I $D(PSBLIST2("All Other",PSBORITX,PSBORDN,"*NA*")) K PSBLIST2("All Other",PSBORITX,PSBORDN,"*NA*")
  1.  ..Q:'$D(PSBORDN)
  1.  ..I $P(PSBDATA,U,1)="END" Q
  1.  F I="All Other","Infusing","Stopped" S X="",PSBLIST2(I)=0 F  S X=$O(PSBLIST2(I,X)) Q:X=""  S XI="" F  S XI=$O(PSBLIST2(I,X,XI),-1) Q:XI=""  D
  1.  .S PSBX2X="" F  S PSBX2X=$O(PSBLIST2(I,X,XI,PSBX2X),-1) Q:PSBX2X=""  S PSBLIST2(I)=PSBLIST2(I)+1  I (PSBBGX[$E(I,1)) S PSBTOT=PSBTOT+1
  1.  D CREATHDR
  1.  D SUBHDR
  1.  D BLDRPT
  1.  D WRTRPT
  1.  Q
  1. BLDRPT ; Bld RPT
  1.  K PSBL2ULN
  1.  S PSBTOPHD=PSBLNTOT-2
  1.  I '$D(PSBLIST2) D  Q
  1.  .S PSBOUTP(0,PSBLNTOT)="W !!,""<<<< NO ORDERS TO DISPLAY >>>>"",!!"
  1.  S PSBMORE=5 F PSBX1X="Infusing","Stopped","All Other" D
  1.  .I PSBX1X'=" * ERROR * " S PSBSUM=PSBX1X_" ["_PSBLIST2(PSBX1X)_"]" S PSBOUTP($$PGTOT,PSBLNTOT)="W !!,"""_PSBSUM_""""
  1.  .Q:PSBLIST2(PSBX1X)=0
  1.  .Q:PSBBGX'[$E(PSBX1X,1)
  1.  .S:$L(PSBSUM)>$G(PSBL2ULN,0) PSBL2ULN=$L(PSBSUM)
  1.  .S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBL2ULN),"" "",""=""),!"
  1.  .S PSBOUTP($$PGTOT,PSBLNTOT)="W !"
  1.  .K PSBDATA
  1.  .S X0="",PSBTOT1=0
  1.  .F  S X0=$O(PSBLIST2(PSBX1X,X0))  Q:X0=""  S PSBX2X="" F  S PSBX2X=$O(PSBLIST2(PSBX1X,X0,PSBX2X)) Q:PSBX2X=""  S XI="" F  S XI=$O(PSBLIST2(PSBX1X,X0,PSBX2X,XI)) Q:XI=""  D
  1.  ..K PSBDATA(1)
  1.  ..S PSBDATA(1,1)=XI
  1.  ..S PSBDATA(1,2)=$O(PSBSTS(PSBX2X,""))
  1.  ..S PSBDATA(1,3)=PSBLIST2(PSBX1X,X0,PSBX2X,XI)
  1.  ..S Y0=$O(PSBOMDR(PSBX2X,"")) I Y0]"" S PSBDATA(1,4)="("_X0_")",PSBDATA(1,4,0)=PSBOMDR(PSBX2X,Y0)
  1.  ..I "IS"[$E(PSBDATA(1,3),1) S (PSBCHG,PSBDATA(1,5))="",PSBORLST(0)=PSBX2X D RPC^PSBCHKIV(.PSBCHG,PSBXDFN,.PSBORLST)
  1.  ..I $D(PSBCHG(0)) I PSBCHG(0)>0 I ($P(PSBCHG(1),U)=PSBX2X)!($P(PSBCHG(1),U,5)=PSBX2X) F X2=0:1 Q:PSBCHG(X2)="END"  I $P(PSBCHG(X2),U)="CD" S PSBDATA(1,5)="Changed Order" Q
  1.  ..S PSBDATA(1,6)=$$FMTDT^PSBOCE1($O(PSBOSTDT(PSBX2X,"")))
  1.  ..S PSBDATA(1,7)=$$FMTDT^PSBOCE1($E($O(PSBOSPDT(PSBX2X,"")),1,12))
  1.  ..S PSBSIDAT(1)=$O(PSBSI(PSBX2X,""))
  1.  ..S PSBTOT1=PSBTOT1+1
  1.  ..K PSBDATA(2),PSBSILN
  1.  ..D BUILDLN^PSBOCI1,SIOPI^PSBOCM(.PSBSIDAT,PSBTAB7,"Other Print Info:")
  1.  ..I $D(PSBRPLN) S PSBMORE=$O(PSBRPLN(""),-1)+6 I $D(PSBSILN) S PSBMORE=PSBMORE+$O(PSBSILN(""),-1)
  1.  ..K PSB1 I $D(PSBFLGD(PSBX2X)) S PSB="" F  S PSB=$O(PSBFLGD(PSBX2X,PSB)) Q:PSB=""  I ($P(PSB,":")'="NOX")&($P(PSB,":")'="STAT") S PSB1=$G(PSB1,"")_PSB
  1.  ..S PSBCNT=PSBTOT1_"   "_$G(PSB1,"")
  1.  ..S PSBOUTP($$PGTOT,PSBLNTOT)="W """_PSBCNT_""""
  1.  ..S I="" F  S I=$O(PSBRPLN(I)) Q:+I=0  D
  1.  ...S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBRPLN(I)_""""
  1.  ..S I="" F  S I=$O(PSBSILN(I)) Q:+I=0  D
  1.  ...S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBSILN(I)_""""
  1.  ..S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBTAB7),"" "",""-""),!"
  1.  ..K PSBRPLN,PSBDATA,PSBSILN
  1.  K PSBNO S PSBNO=1 D:+PSBTOT>0 LGD^PSBOCM K PSBNO
  1.  Q
  1. WRTRPT ;  writ
  1.  I $O(PSBOUTP(""),-1)<1 D  Q
  1.  .X PSBOUTP($O(PSBOUTP(""),-1),14)
  1.  .D PTFTR^PSBOCI1
  1.  S PSBPGNUM=1
  1.  S PSBZ="" F  S PSBZ=$O(PSBOUTP(PSBZ)) Q:PSBZ=""  D
  1.  .I PSBPGNUM'=PSBZ D PTFTR^PSBOCI1 S PSBPGNUM=PSBZ D HDR,SUBHDR
  1.  .S PSBX2X="" F  S PSBX2X=$O(PSBOUTP(PSBZ,PSBX2X)) Q:PSBX2X=""  D
  1.  ..X PSBOUTP(PSBZ,PSBX2X)
  1.  D PTFTR^PSBOCI1
  1.  K ^XTMP("PSBO",$J,"PSBLIST"),PSBOUTP
  1.  Q
  1. HDR ;  Hder
  1.  W:$Y>1 @IOF
  1.  W:$X>1 !
  1.  S PSBRPNM="BCMA COVERSHEET IV OVERVIEW REPORT"
  1.  D:$P(PSBRPT(.1),U,1)="P"
  1.  .S PSBHDR(0)=PSBRPNM
  1.  .S PSBHDR(1)="Order Type(s): --"
  1.  .F Y=12,13,18 I $P(PSBFUTR,U,Y) S $P(PSBHDR(1),": ",2)=$P(PSBHDR(1),": ",2)_$S(PSBHDR(1)["--":"",1:"/ ")_$P("^^^^^^^^^^^Infusing Bags^Stopped Bags^^^^^All Others",U,Y)_" " S PSBHDR(1)=$TR(PSBHDR(1),"-","")
  1.  .I $P(PSBFUTR,U,11) S PSBHDR(2)="Include Action(s)"_$S(PSBCFLG:" & Comments/Reasons",1:"")
  1.  .D PT^PSBOHDR(PSBXDFN,.PSBHDR)
  1.  Q
  1. SUBHDR ;
  1.  N PSBAL S PSBAL=$O(PSBHDR("ALERGY",""),-1) S PSBAL=$S((PSBAL/12)>(PSBAL\12):(PSBAL\12)+1,1:(PSBAL\12))
  1.  N PSBRE S PSBRE=$O(PSBHDR("REAC",""),-1) S PSBRE=$S((PSBRE/12)>(PSBRE\12):(PSBRE\12)+1,1:(PSBRE\12))
  1.  S PSBLNTOT=$O(PSBHDR(""),-1)+9+PSBAL+PSBRE+1
  1.  I $G(PSBPGNUM,0)=1 W !,?(PSBTAB7-($L("Total Items reported: "_+PSBTOT))),"Total Items reported: "_+PSBTOT,! S PSBLNTOT=PSBLNTOT+2
  1.  W !,$TR($J("",PSBTAB7)," ","_") S PSBLNTOT=PSBLNTOT+1
  1.  W !,$G(PSBHD1,"") S PSBLNTOT=PSBLNTOT+1
  1.  W !,$G(PSBHD2,"") S PSBLNTOT=PSBLNTOT+1
  1.  W !,$TR($J("",PSBTAB7)," ","="),! S PSBLNTOT=PSBLNTOT+2
  1.  I $D(NOTE(PSBPGNUM)) W NOTE(PSBPGNUM),!! S PSBLNTOT=PSBLNTOT+2
  1.  Q
  1. PGTOT(X) ;PG Nmbr
  1.  I (PSBLNTOT+PSBMORE)>(IOSL) D PGC^PSBOCE1
  1.  I $G(X,1) S PSBLNTOT=PSBLNTOT+$G(X,1),PSBMORE=PSBMORE-$G(X,1)
  1.  Q PSBPGNUM
  1. CREATHDR ;
  1.  K PSBHD1,PSBHD2
  1.  I IOM'<132 S PSBHD1=$P($T(HD132A),"~",2),PSBHD2=$P($T(HD132B),";",2),PSBBLANK=$P($T(C132BLK),";",2)
  1.  E  S PSBHD1="THIS REPORT SUPPORTS >131 CHAR./LINE PRINT FORMATS ONLY" K PSBLIST2 Q
  1.  ; tabs
  1.  S PSBTAB0=1 F PSBI=0:1:($L(PSBHD1,"|")-1) S:PSBI>0 @("PSBTAB"_PSBI)=($F(PSBHD1,"|",@("PSBTAB"_(PSBI-1))+1))-1
  1.  S PSBPGNUM=1
  1.  D HDR
  1.  Q
  1. HD132A ;~    Bag ID     |    Order    |       Bag       |   Medication; Infusion Rate, Route  | Bag Info |    Order Start  |    Order Stop  |
  1.  Q
  1. HD132B ;               |    Status   |     Status      |                                     |          |     Date        |      Date      |
  1.  Q
  1. C132BLK ;;                |            |                 |                                     |          |                 |                |
  1.  Q