PSBO ;BIRMINGHAM/EFC - BCMA OUTPUTS ;03/06/16 3:06pm
;;3.0;BAR CODE MED ADMIN;**13,32,2,25,28,51,50,42,58,68,70,83**;Mar 2004;Build 89
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; Reference/IA
; ^ORD(101.24/3429
; ^PSDRUG(/221
;
;*68-Add PSBSIFL as 19th parameter to RPC tag to control printing of
; special instruction/other print info.
;*58 - Tag WRAP previously wrapped on a max text limit of 250 char.
; Since the use of Enhanced Order Checks, that limit has to
; be removed and the length of the input string will be used.
;*70 - Add PSBCLINORD as 20th parameter to RPC tag to control the
; type of order to appear on reports that want to be able to
; show Clinic Orders or IM orders. Set C=CO I=IM
; CCR #1459: Adding clinic to BL and BZ chui labels.
;*83 - Add call to cleanup all PSB* variables for all reports run.
;
RPC(RESULTS,PSBTYPE,PSBDFN,PSBSTRT,PSBSTOP,PSBINCL,PSBDEV,PSBSORT,PSBOI,PSBWLOC,PSBWSORT,PSBFUTR,PSBORDNM,PSBRCRI,PSBLIST,PSBPST,PSBTR,PSBDIV,PSBSIFL,PSBCLINORD,PSB21,PSB22,PSB23,PSB24,PSB25,PSBCLLST) ;
;
; RPC: PSB REPORT
;
; Description:
; Used by the client to create individual patient extracts of
; CHUI report options to display on the client.
;
;
S RESULTS=$NAME(^TMP("PSBO",$J))
N PSBIENS,PSBRPT,PSBFDA,DIC,PSBANS
N PSBMODE ;*70
K ^TMP("PSBO",$J) S ^TMP("PSBO",$J,1)="-1^"
S DFN=PSBDFN
D NEW^PSBO1(.PSBRPT,PSBTYPE)
I PSBDFN'="",PSBTYPE="MH"!(PSBTYPE="WA")!(PSBTYPE="ML")!(PSBTYPE="MT") D PAINCMT^PSBCSUTL(PSBDFN) ;;Add Comment if Pain Score entered in BCMA was marked "Entered in Error" in Vitals.
I +PSBRPT(0)<1 S ^TMP("PSBO",$J,1)="-1^Error: "_$P(PSBRPT(0),U,2) Q
S PSBIENS=+PSBRPT(0)_","
S PSBSTRT(0)=$E($P(PSBSTRT,".",2)_"0000",1,4),PSBSTRT=PSBSTRT\1
S PSBSTOP(0)=$E($P(PSBSTOP,".",2)_"0000",1,4),PSBSTOP=PSBSTOP\1
D:$G(PSBDEV)]""
.D NOW^%DTC
.I $P(PSBDEV,U,2)="" D VAL^DIE(53.69,PSBIENS,.06,"F",PSBDEV,"PSBRET","PSBFDA")
.I $P(PSBDEV,U,2)'="" D VAL^DIE(53.69,PSBIENS,.06,"F","`"_$P(PSBDEV,U,2),"PSBRET","PSBFDA")
.D VAL^DIE(53.69,PSBIENS,.07,"F",$S($P(PSBRCRI,U)="QD":$P(PSBRCRI,U,2),1:%),"PSBRET","PSBFDA")
D:$G(PSBOI)]"" VAL^DIE(53.69,PSBIENS,.09,"F",PSBOI,"PSBRET","PSBFDA")
S:($G(PSBSORT)']"")&(PSBTYPE'="XA") PSBSORT="P" D VAL^DIE(53.69,PSBIENS,.11,"F",PSBSORT,"PSBRET","PSBFDA")
I "^SF"[("^"_PSBTYPE) D VAL^DIE(53.69,PSBIENS,.51,"F",PSBSORT,"PSBRET","PSBFDA")
S PSBPST=$TR($G(PSBPST),"^",",")
D VAL^DIE(53.69,PSBIENS,.52,"F",PSBPST,"PSBRET","PSBFDA")
S PSBTR=$TR($G(PSBTR),"^",",")
I $G(PSBDIV)]"" D VAL^DIE(53.69,PSBIENS,.04,"F",$G(PSBDIV),"PSBRET","PSBFDA")
D VAL^DIE(53.69,PSBIENS,2,"F",PSBTR,"PSBRET","PSBFDA")
D VAL^DIE(53.69,PSBIENS,.12,"F","`"_PSBDFN,"PSBRET","PSBFDA")
I $G(PSBWLOC)]"" S PSBFDA(53.69,PSBIENS,.13)=PSBWLOC
D:$G(PSBWSORT)]"" VAL^DIE(53.69,PSBIENS,.15,"F",PSBWSORT,"PSBRET","PSBFDA")
D VAL^DIE(53.69,PSBIENS,.16,"F",PSBSTRT,"PSBRET","PSBFDA")
D VAL^DIE(53.69,PSBIENS,.17,"F",PSBSTRT(0),"PSBRET","PSBFDA")
D VAL^DIE(53.69,PSBIENS,.18,"F",PSBSTOP,"PSBRET","PSBFDA")
D VAL^DIE(53.69,PSBIENS,.19,"F",PSBSTOP(0),"PSBRET","PSBFDA")
D:$G(PSBINCL)]""
.D VAL^DIE(53.69,PSBIENS,.21,"F",+$P(PSBINCL,"^",1),"PSBRET","PSBFDA")
.D VAL^DIE(53.69,PSBIENS,.22,"F",+$P(PSBINCL,"^",2),"PSBRET","PSBFDA")
.D VAL^DIE(53.69,PSBIENS,.23,"F",+$P(PSBINCL,"^",3),"PSBRET","PSBFDA")
.D VAL^DIE(53.69,PSBIENS,.24,"F",+$P(PSBINCL,"^",4),"PSBRET","PSBFDA")
.D VAL^DIE(53.69,PSBIENS,.28,"F",+$P(PSBINCL,"^",5),"PSBRET","PSBFDA")
.D VAL^DIE(53.69,PSBIENS,.29,"F",+$P(PSBINCL,"^",6),"PSBRET","PSBFDA")
D:$G(PSBFUTR)]""
.D VAL^DIE(53.69,PSBIENS,.25,"F",+$P(PSBFUTR,"^",1),"PSBRET","PSBFDA")
.D VAL^DIE(53.69,PSBIENS,.26,"F",+$P(PSBFUTR,"^",2),"PSBRET","PSBFDA")
.D VAL^DIE(53.69,PSBIENS,.27,"F",+$P(PSBFUTR,"^",3),"PSBRET","PSBFDA")
.D VAL^DIE(53.69,PSBIENS,.41,"F",+$P(PSBFUTR,"^",4),"PSBRET","PSBFDA")
.D VAL^DIE(53.69,PSBIENS,.61,"F",$TR(PSBFUTR,"^ ","~"),"PSBRET","PSBFDA")
;*68 add SIOPI flag when present
D:$D(PSBSIFL)
.D VAL^DIE(53.69,PSBIENS,3,"F",PSBSIFL,"PSBRET","PSBFDA")
;*70 add PSBCLINORD indicator when present
D:$D(PSBCLINORD)
.D VAL^DIE(53.69,PSBIENS,4,"F",PSBCLINORD,"PSBRET","PSBFDA")
D FILE^DIE("","PSBFDA")
I "^SF"'[("^"_PSBTYPE) I $G(PSBLIST(0),"")]"" D LIST^PSBO1(.PSBLIST)
I "^SF"'[("^"_PSBTYPE) I $G(PSBCLLST(0),"")]"" D LIST^PSBO1(.PSBCLLST)
I $G(PSBDEV)]"" D PRINT^PSBO1 S RESULTS=$NAME(^TMP("PSBO",$J)) Q
D HFSOPEN^PSBUTL("RPC") I POP S ^TMP("PSBO",$J,1)="ERROR: UNABLE TO ACCESS HFS DIRECTORY "_$$DEFDIR^%ZISH(),^TMP("PSBO",$J,2)="PLEASE CHECK DIRECTORY WRITE PRIVILEGES." Q
U IO D DQ(+PSBIENS)
D HFSCLOSE^PSBUTL("RPC")
S RESULTS=$NAME(^TMP("PSBO",$J))
D:$G(PSBDEV)]"" PRINT^PSBO1
Q
;
XQ(PSBTYPE) ; Called via Kernel Menus
N PSBANS,PSBANS1,PSBRPT,PSBSAVE,DA,DIK,DR,DDSFILE,PSBCNT
D NEW^PSBO1(.PSBRPT,PSBTYPE)
I +PSBRPT(0)<1 W !,"Error: ",$P(PSBRPT(0),U,2) S DIR(0)="E" D ^DIR Q
S DA=+PSBRPT(0),DR="[PSBO "_PSBTYPE_"]",DDSFILE=53.69 D ^DDS
W @IOF
I 'PSBSAVE W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!"
D:PSBSAVE
.;Check Drug to Patient Relationship.
.I (PSBTYPE="BL")!(PSBTYPE="BZ") S PSBANS="" D CHECK^PSBO1 I PSBANS=0!($D(DIRUT)) W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!" Q
.;
.;*70 (CCR #1459 begin)
.I $O(PSBCL(""))]"" D
..N PSBI
..S PSBCL="" F PSBI=0:1 S PSBCL=$O(PSBCL(PSBCL)) Q:PSBCL=""
..I PSBI=1 D Q
...S PSBCL=$O(PSBCL(PSBCL)),$P(^PSB(53.69,DA,4),U,3)=$O(^SC("B",PSBCL,""))
..;
..K DIR,Y
..;
..S PSBCL="" F PSBCNT=3:1 S PSBCL=$O(PSBCL(PSBCL)) Q:PSBCL="" D
...S DIR("A",PSBCNT)=(PSBCNT-2)_". "_PSBCL,PSBCL(PSBCL)=(PSBCNT-2)
..;
..S DIR(0)="NAO^1:"_(PSBCNT-3) ;,DIR("B")=(PSBCNT-3)
..S DIR("A",1)="Select the appropriate clinic:"
..S DIR("A",2)=""
..S DIR("A",(PSBCNT+1))=""
..S DIR("A")="Enter a number 1 thru "_(PSBCNT-3)_": "
..S DIR("?")="Select a number from 1 - "_(PSBCNT-3)_" or <Return> to exit"
..;
..D ^DIR
..I Y=""!(Y=-1)!(Y=U) S PSBANS=0 Q
..S PSBCL="" F S PSBCL=$O(PSBCL(PSBCL)) Q:PSBCL="" D
...I PSBCL[" (Ward)" Q
...I Y=PSBCL(PSBCL) S $P(^PSB(53.69,DA,4),U,3)=$O(^SC("B",PSBCL,""))
.K PSBCL
.I $G(PSBANS)=0 D Q
..W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!"
.;*70 (CCR #-1459 end)
.;
.;Allow "'BROWSER" Device
.S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D
..S IOP="`"_IOP,%ZIS="N"
..D ^%ZIS
..I IO=IO(0) S PSBSIO=1
..D HOME^%ZIS K IOP
.I $$GET1^DIQ(53.69,DA_",",.06)["BROWSER"!(PSBSIO=1) S IOP=$$GET1^DIQ(53.69,DA_",",.06)_";132" D ^%ZIS U IO D DQ(DA) D ^%ZISC K IOP Q
.;
.W @IOF,"Submitting Your Report Request to TaskMan..."
.S ZTIO=$$GET1^DIQ(53.69,DA_",",.06)
.S ZTDTH=$P(^PSB(53.69,DA,0),U,7)
.S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
.S ZTRTN="DQ^PSBO("_DA_")"
.D ^%ZTLOAD
.W "Submitted!",!,"Your Task Number Is: ",$G(ZTSK),!
K ^TMP("PSBO",$J)
Q
;
DQ(PSBRPT) ; Dequeue report from Taskman
N PSBDFN
Q:'$D(^PSB(53.69,PSBRPT,0)) ; No Such Report
S $P(^PSB(53.69,PSBRPT,0),U,8)=$G(ZTSK,"RPC")
D SETUP,@("EN^PSBO"_$P(PSBRPT(0),U,5))
K ^TMP("PSBO",$J),PSBSIFLG
S ZTREQ="@"
D CLEAN^PSBVT ;*83 cleanup all PSB* variables for all reports called
Q
;
IOM() ; Returns good margin or not
Q:IOM'<132 1
W !,"**************************************************************"
W !,"* SORRY, Your selected DEVICE does not print 132 columns. *"
W !,"**************************************************************"
W !
Q 0
;
VAL(PSBFLDS) ; Validate that fields in PSBFLDS are filled in
N PSB,PSBFLD,PSBMSG,PSBSTOP,PSBST,PSBDAYS S PSBSTRT=""
F PSB=1:1 Q:$P(PSBFLDS,";",PSB)="" S PSBFLD=$P(PSBFLDS,";",PSB),PSBFLD(PSBFLD)=$$GET^DDSVAL(53.69,DA,PSBFLD)
I $D(PSBFLD(.11)) K:$E(PSBFLD(.11))="P" PSBFLD(.13),PSBFLD(.15) K:$E(PSBFLD(.11))="W" PSBFLD(.12)
S PSB="" F S PSB=$O(PSBFLD(PSB)) Q:PSB="" D:PSBFLD(PSB)=""
.I '$D(PSBMSG) S PSBMSG(0)="UNABLE TO FILE REQUEST",PSBMSG(1)=" ",PSBMSG(2)="ERROR: MISSING DATA - ALL FIELDS ARE REQUIRED",PSBMSG(3)=" "
.D FIELD^DID(53.69,PSB,"","TITLE;LABEL","PSB")
.S Z=" Missing Field: "_$S(PSB("TITLE")]"":PSB("TITLE"),1:PSB("LABEL"))
.S PSBMSG($O(PSBMSG(""),-1)+1)=Z
; Check Times
D:$G(PSBFLD(.16))
.S PSBSTRT=PSBFLD(.16)+$G(PSBFLD(.17))
.D:$P($$GET1^DIQ(53.69,DA_",",.01),U)["MH"
..S PSBDAYS=$$GET1^DIQ(101.24,$$FIND1^DIC(101.24,"","X","ORRP BCMA MAH","B")_",",.42) ;check maxdays
..S:PSBDAYS="" PSBDAYS=7
..S X=PSBSTRT\1 D H^%DTC S PSBST=%H+PSBDAYS ;Determine stop date
.S PSBSTOP=$S($G(PSBFLD(.18)):PSBFLD(.18),1:PSBFLD(.16))+$G(PSBFLD(.19))
.I PSBSTOP<PSBSTRT S Y=$O(PSBMSG(""),-1)+1,PSBMSG(Y)=" Date: Stop Date/Time is before Start Date/Time"
.I $P($$GET1^DIQ(53.69,DA_",",.01),U)["MH" S X=PSBSTOP\1 D H^%DTC I %H>PSBST S Y=$O(PSBMSG(""),-1)+1,PSBMSG(Y)=" The date range cannot exceed "_PSBDAYS_" day(s) as defined in the CPRS 'MAXIMUM DAYS BACK' parameter"
Q:'$D(PSBMSG) ; All is well
D MSG^DDSUTL(.PSBMSG)
S DDSERROR=1
Q
;
SETUP ; Setup parameters for the report in PSBRPT
N PSBWRDL,PSBINDX,PSBWRDA,QQ,PSBSORT,RECS
S RECS=0 ;init RECS found to 0 *70
K ^TMP("PSBO",$J)
F X=0,.1,.2,.3,.4,.5,1 S PSBRPT(X)=$G(^PSB(53.69,PSBRPT,X))
I $D(^PSB(53.69,PSBRPT,2)) M PSBRPT(2)=^PSB(53.69,PSBRPT,2)
I $D(^PSB(53.69,PSBRPT,3)) M PSBRPT(3)=^PSB(53.69,PSBRPT,3)
I $D(^PSB(53.69,PSBRPT,4)) M PSBRPT(4)=^PSB(53.69,PSBRPT,4) ;*68
I $G(PSBRPT(4))="" S PSBRPT(4)="^I^" ;if null def to I *70
S PSBRPT(.52)=$P($G(^PSB(53.69,PSBRPT,.5)),U,2)
S PSBSIFLG=$P($G(PSBRPT(4)),U) ;*68
S PSBCLINORD=$S($P($G(PSBRPT(4)),U,2)="C":1,1:0)
I $P(PSBRPT(0),"-")="ST",PSBRPT(3)]"" Q ;Running a MSF report PSB*3*28
I $P(PSBRPT(0),"-")="SF",PSBRPT(.52)]"" Q ;Running a MSF report PSB*3*28
;
S PSBSORT=$P(PSBRPT(.1),U,1) ;init PSBSORT ;*70
;
;* * Patient Mode * *
I PSBSORT="P" D I 'PSBDFN Q RECS
.S PSBDFN=+$P(PSBRPT(.1),U,2) Q:'PSBDFN
.N VA,VADM S DFN=PSBDFN D DEM^VADPT
.Q:(VADM(1)="")!(VA("PID")="")
.S ^TMP("PSBO",$J,PSBDFN,0)=VADM(1)_U_VA("PID"),^TMP("PSBO",$J,"B",VADM(1),PSBDFN)=""
.S RECS=1
;
;* * WARDs per Nurse file group & All patient DFN's * * ;*70
I PSBSORT="W" D
.S PSBWRD=$P(PSBRPT(.1),U,3) Q:'PSBWRD
.D WARD^NURSUT5("L^"_PSBWRD,.PSBWRDA)
.Q:$O(PSBWRDA(""))=""
.S QQ="" F S QQ=$O(PSBWRDA(PSBWRD,2,QQ)) Q:QQ="" S PSBWRDL=$P(PSBWRDA(PSBWRD,2,QQ,.01),U,2) D
..F PSBDFN=0:0 S PSBDFN=$O(^DPT("CN",PSBWRDL,PSBDFN)) Q:'PSBDFN D
...S DFN=PSBDFN D DEM^VADPT
...Q:(VADM(1)="")!(VA("PID")="")
...S ^TMP("PSBO",$J,PSBDFN,0)=VADM(1)_U_VA("PID")
...; Determine Sort or default to Pt Name...
...S:$P(PSBRPT(.1),U,5)="P" PSBINDX=VADM(1)
...I $P(PSBRPT(.1),U,5)="B" S PSBINDX=$P($G(^DPT(PSBDFN,.101)),U) S:PSBINDX="" PSBINDX="** NO ROOM BED **"
...S:$P(PSBRPT(.1),U,5)="" PSBINDX=VADM(1)
...S:$G(PSBINDX)="" PSBINDX=VADM(1)
...S ^TMP("PSBO",$J,"B",PSBINDX,PSBDFN)=""
.S:$D(^TMP("PSBO",$J)) RECS=1
;
;* * Clinics selected & All patient DFN's * * ;*70
I PSBSORT="C" D
.Q:'$D(PSBRPT(2)) ;no Clinics selected
.D CLIN(.PSBRPT)
.M ^TMP("PSBO",$J)=^TMP("PSJCL",$J) K ^TMP("PSJCL",$J)
.S:$D(^TMP("PSBO",$J)) RECS=1
;
Q
;Q RECS
;
WRAP(X,Y,Z) ; Quick text wrap
;
; Input Parameters Description:
; X: Left Column of display [Optional]
; Y: Cols to wrap in [Optional]
; Z: Text to wrap [Optional]
;
N PSB
F Q:'$L(Z) D
.W:$X>X !
.W:$X<X ?X
.I $L(Z)<Y W Z S Z="" Q
.F PSB=Y:-1:0 Q:$E(Z,PSB)=" "
.S:PSB<1 PSB=Y
.W $E(Z,1,PSB)
.S Z=$E(Z,PSB+1,$L(Z))
Q ""
;
PRNEFF(PSBEIECMT,PSBIEN) ;Check for PRN Error comment
N PSBCMTCH
I $P($G(PSBRPT(.2)),U,8)=0 S PSBCMTCH=0 F S PSBCMTCH=$O(^PSB(53.79,PSBIEN,.3,PSBCMTCH)) Q:PSBCMTCH="" D
.I $P($G(^PSB(53.79,PSBIEN,.3,PSBCMTCH,0)),U)["**Pain Score of" S PSBEIECMT=" **This Pain Score may have been Entered in Error. See Vitals Package.**"
Q PSBEIECMT
;
FILTERCO ; rebuild TMP using needed recs and remove clinics not wanted
N QQ,COCNT,CLNAM
I '$G(PSBIENS) N PSBIENS S PSBIENS=PSBRPT
S COCNT=0 K ^TMP("PSJTMP",$J)
K ^TMP("PSJTMP",$J)
F QQ=0:0 S QQ=$O(^TMP("PSJ",$J,QQ)) Q:'QQ D
. Q:$P($G(^TMP("PSJ",$J,QQ,0)),U,3)["P"
. S CLNAM=$P($G(^TMP("PSJ",$J,QQ,0)),U,11) Q:CLNAM="" ;Not a CO
. ;ignore orders that are CO and for a Clinic not asked for
. I CLNAM]"",'$D(^PSB(53.69,+PSBIENS,2,"B",CLNAM)) Q
. S COCNT=COCNT+1
. M ^TMP("PSJTMP",$J,COCNT)=^TMP("PSJ",$J,QQ)
K ^TMP("PSJ",$J) M ^TMP("PSJ",$J)=^TMP("PSJTMP",$J)
K ^TMP("PSJTMP",$J)
S:'$D(^TMP("PSJ",$J)) ^TMP("PSJ",$J,1,0)=-1
Q
;
CLIN(RPTARR,DFNLST) ;Build DFN list of patient orders per Clinics selected
; Input: RPTARR - Report request array from file 53.69. (required)
; DFNLST - pass by ref array name if array needed and not
; a tmp global pass a 1. (optional)
; default is TMP global
; DFNLST - array of DFN's only
;
N DFNARR,GLB,ROOT,STARTDT
K ^TMP("PSJCL",$J)
S STARTDT=$P($G(RPTARR(.1)),U,6)
S:STARTDT="" STARTDT=$P($$NOW^XLFDT,".")
;
;Begin query read with Unit Dose xref and report start date range
S GLB=$NA(^PS(55,"AUDC",STARTDT)),ROOT=$E(GLB,1,13)
D QUERY(GLB,ROOT,9999999,.RPTARR,.DFNARR)
;
;Now do query read for IV xref and report start date range
S GLB=$NA(^PS(55,"AIVC",STARTDT)),ROOT=$E(GLB,1,13)
D QUERY(GLB,ROOT,9999999,.RPTARR,.DFNARR)
;
I $G(DFNLST) M DFNLST=DFNARR Q ;if DFNLST then return array and quit
D BLDTMP(.DFNARR)
Q
;
QUERY(GLB,ROOT,RPSTOPDT,RPTAR,DFNAR) ;Loops thru global xref via $Query
; for qualifying recs to find DFN's
N CLN,CLNNAM,DFN,STPDT,NOD1,NOD2
I GLB["UD" D
.S NOD1=5,NOD2=8
E D
.S NOD1="IV",NOD2="DSS"
;
F S GLB=$Q(@GLB) Q:$E(GLB,1,13)'=ROOT D
.S STPDT=$P($QS(GLB,3),"."),CLN=$QS(GLB,4),DFN=$QS(GLB,5),OR=$QS(GLB,6)
.Q:$D(DFNAR(DFN)) ;quit if DFN already on ARR
.S CLNODE=$G(^PS(55,DFN,NOD1,OR,NOD2))
.Q:'$$CLINIC(CLNODE) ;not active bcma clin order
.S CLNNAM=$$GET1^DIQ(44,CLN,.01) ;get clinic name
.Q:STPDT>RPSTOPDT ;quit if rec beyond stop date
.Q:'$D(RPTAR(2,"B",CLNNAM)) ;quit if Not on Cln sel list
.;
.S DFNAR(DFN)="" ;Keep - Set DFN in array
Q
;
BLDTMP(ARR) ;Build Tmp global for DFN's to be included on the report
N VA,VADM,PSJINDX
F DFN=0:0 S DFN=$O(ARR(DFN)) Q:'DFN D
.K VA,VADM D DEM^VADPT
.Q:(VADM(1)="")!(VA("PID")="")
.S ^TMP("PSJCL",$J,DFN,0)=VADM(1)_U_VA("PID")
.S PSJINDX=VADM(1)
.S ^TMP("PSJCL",$J,"B",PSJINDX,DFN)=""
.S RECS=1
Q
;
CLINIC(CL) ;Is this a Clinic order that would show on the VDL in CO mode also?
Q:'($P(CL,"^",2)?7N!($P(CL,"^",2)?7N1".".N)) 0 ;no appt date, IM ord
Q:'$D(^PS(53.46,"B",+CL)) 0 ;no PTR to 44, IM ord
N A S A=$O(^PS(53.46,"B",+CL,"")) Q:'A 0 ;no 53.46 ien, IM ord
Q $P(^PS(53.46,A,0),"^",4) ;Send to BCMA? flag
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBO 15307 printed Oct 16, 2024@17:41:09 Page 2
PSBO ;BIRMINGHAM/EFC - BCMA OUTPUTS ;03/06/16 3:06pm
+1 ;;3.0;BAR CODE MED ADMIN;**13,32,2,25,28,51,50,42,58,68,70,83**;Mar 2004;Build 89
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; ^ORD(101.24/3429
+6 ; ^PSDRUG(/221
+7 ;
+8 ;*68-Add PSBSIFL as 19th parameter to RPC tag to control printing of
+9 ; special instruction/other print info.
+10 ;*58 - Tag WRAP previously wrapped on a max text limit of 250 char.
+11 ; Since the use of Enhanced Order Checks, that limit has to
+12 ; be removed and the length of the input string will be used.
+13 ;*70 - Add PSBCLINORD as 20th parameter to RPC tag to control the
+14 ; type of order to appear on reports that want to be able to
+15 ; show Clinic Orders or IM orders. Set C=CO I=IM
+16 ; CCR #1459: Adding clinic to BL and BZ chui labels.
+17 ;*83 - Add call to cleanup all PSB* variables for all reports run.
+18 ;
RPC(RESULTS,PSBTYPE,PSBDFN,PSBSTRT,PSBSTOP,PSBINCL,PSBDEV,PSBSORT,PSBOI,PSBWLOC,PSBWSORT,PSBFUTR,PSBORDNM,PSBRCRI,PSBLIST,PSBPST,PSBTR,PSBDIV,PSBSIFL,PSBCLINORD,PSB21,PSB22,PSB23,PSB24,PSB25,PSBCLLST) ;
+1 ;
+2 ; RPC: PSB REPORT
+3 ;
+4 ; Description:
+5 ; Used by the client to create individual patient extracts of
+6 ; CHUI report options to display on the client.
+7 ;
+8 ;
+9 SET RESULTS=$NAME(^TMP("PSBO",$JOB))
+10 NEW PSBIENS,PSBRPT,PSBFDA,DIC,PSBANS
+11 ;*70
NEW PSBMODE
+12 KILL ^TMP("PSBO",$JOB)
SET ^TMP("PSBO",$JOB,1)="-1^"
+13 SET DFN=PSBDFN
+14 DO NEW^PSBO1(.PSBRPT,PSBTYPE)
+15 ;;Add Comment if Pain Score entered in BCMA was marked "Entered in Error" in Vitals.
IF PSBDFN'=""
IF PSBTYPE="MH"!(PSBTYPE="WA")!(PSBTYPE="ML")!(PSBTYPE="MT")
DO PAINCMT^PSBCSUTL(PSBDFN)
+16 IF +PSBRPT(0)<1
SET ^TMP("PSBO",$JOB,1)="-1^Error: "_$PIECE(PSBRPT(0),U,2)
QUIT
+17 SET PSBIENS=+PSBRPT(0)_","
+18 SET PSBSTRT(0)=$EXTRACT($PIECE(PSBSTRT,".",2)_"0000",1,4)
SET PSBSTRT=PSBSTRT\1
+19 SET PSBSTOP(0)=$EXTRACT($PIECE(PSBSTOP,".",2)_"0000",1,4)
SET PSBSTOP=PSBSTOP\1
+20 if $GET(PSBDEV)]""
Begin DoDot:1
+21 DO NOW^%DTC
+22 IF $PIECE(PSBDEV,U,2)=""
DO VAL^DIE(53.69,PSBIENS,.06,"F",PSBDEV,"PSBRET","PSBFDA")
+23 IF $PIECE(PSBDEV,U,2)'=""
DO VAL^DIE(53.69,PSBIENS,.06,"F","`"_$PIECE(PSBDEV,U,2),"PSBRET","PSBFDA")
+24 DO VAL^DIE(53.69,PSBIENS,.07,"F",$SELECT($PIECE(PSBRCRI,U)="QD":$PIECE(PSBRCRI,U,2),1:%),"PSBRET","PSBFDA")
End DoDot:1
+25 if $GET(PSBOI)]""
DO VAL^DIE(53.69,PSBIENS,.09,"F",PSBOI,"PSBRET","PSBFDA")
+26 if ($GET(PSBSORT)']"")&(PSBTYPE'="XA")
SET PSBSORT="P"
DO VAL^DIE(53.69,PSBIENS,.11,"F",PSBSORT,"PSBRET","PSBFDA")
+27 IF "^SF"[("^"_PSBTYPE)
DO VAL^DIE(53.69,PSBIENS,.51,"F",PSBSORT,"PSBRET","PSBFDA")
+28 SET PSBPST=$TRANSLATE($GET(PSBPST),"^",",")
+29 DO VAL^DIE(53.69,PSBIENS,.52,"F",PSBPST,"PSBRET","PSBFDA")
+30 SET PSBTR=$TRANSLATE($GET(PSBTR),"^",",")
+31 IF $GET(PSBDIV)]""
DO VAL^DIE(53.69,PSBIENS,.04,"F",$GET(PSBDIV),"PSBRET","PSBFDA")
+32 DO VAL^DIE(53.69,PSBIENS,2,"F",PSBTR,"PSBRET","PSBFDA")
+33 DO VAL^DIE(53.69,PSBIENS,.12,"F","`"_PSBDFN,"PSBRET","PSBFDA")
+34 IF $GET(PSBWLOC)]""
SET PSBFDA(53.69,PSBIENS,.13)=PSBWLOC
+35 if $GET(PSBWSORT)]""
DO VAL^DIE(53.69,PSBIENS,.15,"F",PSBWSORT,"PSBRET","PSBFDA")
+36 DO VAL^DIE(53.69,PSBIENS,.16,"F",PSBSTRT,"PSBRET","PSBFDA")
+37 DO VAL^DIE(53.69,PSBIENS,.17,"F",PSBSTRT(0),"PSBRET","PSBFDA")
+38 DO VAL^DIE(53.69,PSBIENS,.18,"F",PSBSTOP,"PSBRET","PSBFDA")
+39 DO VAL^DIE(53.69,PSBIENS,.19,"F",PSBSTOP(0),"PSBRET","PSBFDA")
+40 if $GET(PSBINCL)]""
Begin DoDot:1
+41 DO VAL^DIE(53.69,PSBIENS,.21,"F",+$PIECE(PSBINCL,"^",1),"PSBRET","PSBFDA")
+42 DO VAL^DIE(53.69,PSBIENS,.22,"F",+$PIECE(PSBINCL,"^",2),"PSBRET","PSBFDA")
+43 DO VAL^DIE(53.69,PSBIENS,.23,"F",+$PIECE(PSBINCL,"^",3),"PSBRET","PSBFDA")
+44 DO VAL^DIE(53.69,PSBIENS,.24,"F",+$PIECE(PSBINCL,"^",4),"PSBRET","PSBFDA")
+45 DO VAL^DIE(53.69,PSBIENS,.28,"F",+$PIECE(PSBINCL,"^",5),"PSBRET","PSBFDA")
+46 DO VAL^DIE(53.69,PSBIENS,.29,"F",+$PIECE(PSBINCL,"^",6),"PSBRET","PSBFDA")
End DoDot:1
+47 if $GET(PSBFUTR)]""
Begin DoDot:1
+48 DO VAL^DIE(53.69,PSBIENS,.25,"F",+$PIECE(PSBFUTR,"^",1),"PSBRET","PSBFDA")
+49 DO VAL^DIE(53.69,PSBIENS,.26,"F",+$PIECE(PSBFUTR,"^",2),"PSBRET","PSBFDA")
+50 DO VAL^DIE(53.69,PSBIENS,.27,"F",+$PIECE(PSBFUTR,"^",3),"PSBRET","PSBFDA")
+51 DO VAL^DIE(53.69,PSBIENS,.41,"F",+$PIECE(PSBFUTR,"^",4),"PSBRET","PSBFDA")
+52 DO VAL^DIE(53.69,PSBIENS,.61,"F",$TRANSLATE(PSBFUTR,"^ ","~"),"PSBRET","PSBFDA")
End DoDot:1
+53 ;*68 add SIOPI flag when present
+54 if $DATA(PSBSIFL)
Begin DoDot:1
+55 DO VAL^DIE(53.69,PSBIENS,3,"F",PSBSIFL,"PSBRET","PSBFDA")
End DoDot:1
+56 ;*70 add PSBCLINORD indicator when present
+57 if $DATA(PSBCLINORD)
Begin DoDot:1
+58 DO VAL^DIE(53.69,PSBIENS,4,"F",PSBCLINORD,"PSBRET","PSBFDA")
End DoDot:1
+59 DO FILE^DIE("","PSBFDA")
+60 IF "^SF"'[("^"_PSBTYPE)
IF $GET(PSBLIST(0),"")]""
DO LIST^PSBO1(.PSBLIST)
+61 IF "^SF"'[("^"_PSBTYPE)
IF $GET(PSBCLLST(0),"")]""
DO LIST^PSBO1(.PSBCLLST)
+62 IF $GET(PSBDEV)]""
DO PRINT^PSBO1
SET RESULTS=$NAME(^TMP("PSBO",$JOB))
QUIT
+63 DO HFSOPEN^PSBUTL("RPC")
IF POP
SET ^TMP("PSBO",$JOB,1)="ERROR: UNABLE TO ACCESS HFS DIRECTORY "_$$DEFDIR^%ZISH()
SET ^TMP("PSBO",$JOB,2)="PLEASE CHECK DIRECTORY WRITE PRIVILEGES."
QUIT
+64 USE IO
DO DQ(+PSBIENS)
+65 DO HFSCLOSE^PSBUTL("RPC")
+66 SET RESULTS=$NAME(^TMP("PSBO",$JOB))
+67 if $GET(PSBDEV)]""
DO PRINT^PSBO1
+68 QUIT
+69 ;
XQ(PSBTYPE) ; Called via Kernel Menus
+1 NEW PSBANS,PSBANS1,PSBRPT,PSBSAVE,DA,DIK,DR,DDSFILE,PSBCNT
+2 DO NEW^PSBO1(.PSBRPT,PSBTYPE)
+3 IF +PSBRPT(0)<1
WRITE !,"Error: ",$PIECE(PSBRPT(0),U,2)
SET DIR(0)="E"
DO ^DIR
QUIT
+4 SET DA=+PSBRPT(0)
SET DR="[PSBO "_PSBTYPE_"]"
SET DDSFILE=53.69
DO ^DDS
+5 WRITE @IOF
+6 IF 'PSBSAVE
WRITE !,"Cancelling Request..."
SET DIK="^PSB(53.69,"
DO ^DIK
WRITE "Cancelled!"
+7 if PSBSAVE
Begin DoDot:1
+8 ;Check Drug to Patient Relationship.
+9 IF (PSBTYPE="BL")!(PSBTYPE="BZ")
SET PSBANS=""
DO CHECK^PSBO1
IF PSBANS=0!($DATA(DIRUT))
WRITE !,"Cancelling Request..."
SET DIK="^PSB(53.69,"
DO ^DIK
WRITE "Cancelled!"
QUIT
+10 ;
+11 ;*70 (CCR #1459 begin)
+12 IF $ORDER(PSBCL(""))]""
Begin DoDot:2
+13 NEW PSBI
+14 SET PSBCL=""
FOR PSBI=0:1
SET PSBCL=$ORDER(PSBCL(PSBCL))
if PSBCL=""
QUIT
+15 IF PSBI=1
Begin DoDot:3
+16 SET PSBCL=$ORDER(PSBCL(PSBCL))
SET $PIECE(^PSB(53.69,DA,4),U,3)=$ORDER(^SC("B",PSBCL,""))
End DoDot:3
QUIT
+17 ;
+18 KILL DIR,Y
+19 ;
+20 SET PSBCL=""
FOR PSBCNT=3:1
SET PSBCL=$ORDER(PSBCL(PSBCL))
if PSBCL=""
QUIT
Begin DoDot:3
+21 SET DIR("A",PSBCNT)=(PSBCNT-2)_". "_PSBCL
SET PSBCL(PSBCL)=(PSBCNT-2)
End DoDot:3
+22 ;
+23 ;,DIR("B")=(PSBCNT-3)
SET DIR(0)="NAO^1:"_(PSBCNT-3)
+24 SET DIR("A",1)="Select the appropriate clinic:"
+25 SET DIR("A",2)=""
+26 SET DIR("A",(PSBCNT+1))=""
+27 SET DIR("A")="Enter a number 1 thru "_(PSBCNT-3)_": "
+28 SET DIR("?")="Select a number from 1 - "_(PSBCNT-3)_" or <Return> to exit"
+29 ;
+30 DO ^DIR
+31 IF Y=""!(Y=-1)!(Y=U)
SET PSBANS=0
QUIT
+32 SET PSBCL=""
FOR
SET PSBCL=$ORDER(PSBCL(PSBCL))
if PSBCL=""
QUIT
Begin DoDot:3
+33 IF PSBCL[" (Ward)"
QUIT
+34 IF Y=PSBCL(PSBCL)
SET $PIECE(^PSB(53.69,DA,4),U,3)=$ORDER(^SC("B",PSBCL,""))
End DoDot:3
End DoDot:2
+35 KILL PSBCL
+36 IF $GET(PSBANS)=0
Begin DoDot:2
+37 WRITE !,"Cancelling Request..."
SET DIK="^PSB(53.69,"
DO ^DIK
WRITE "Cancelled!"
End DoDot:2
QUIT
+38 ;*70 (CCR #-1459 end)
+39 ;
+40 ;Allow "'BROWSER" Device
+41 SET IOP=$$GET1^DIQ(53.69,DA_",",.06,"I")
SET PSBSIO=0
IF IOP]""
Begin DoDot:2
+42 SET IOP="`"_IOP
SET %ZIS="N"
+43 DO ^%ZIS
+44 IF IO=IO(0)
SET PSBSIO=1
+45 DO HOME^%ZIS
KILL IOP
End DoDot:2
+46 IF $$GET1^DIQ(53.69,DA_",",.06)["BROWSER"!(PSBSIO=1)
SET IOP=$$GET1^DIQ(53.69,DA_",",.06)_";132"
DO ^%ZIS
USE IO
DO DQ(DA)
DO ^%ZISC
KILL IOP
QUIT
+47 ;
+48 WRITE @IOF,"Submitting Your Report Request to TaskMan..."
+49 SET ZTIO=$$GET1^DIQ(53.69,DA_",",.06)
+50 SET ZTDTH=$PIECE(^PSB(53.69,DA,0),U,7)
+51 SET ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
+52 SET ZTRTN="DQ^PSBO("_DA_")"
+53 DO ^%ZTLOAD
+54 WRITE "Submitted!",!,"Your Task Number Is: ",$GET(ZTSK),!
End DoDot:1
+55 KILL ^TMP("PSBO",$JOB)
+56 QUIT
+57 ;
DQ(PSBRPT) ; Dequeue report from Taskman
+1 NEW PSBDFN
+2 ; No Such Report
if '$DATA(^PSB(53.69,PSBRPT,0))
QUIT
+3 SET $PIECE(^PSB(53.69,PSBRPT,0),U,8)=$GET(ZTSK,"RPC")
+4 DO SETUP
DO @("EN^PSBO"_$PIECE(PSBRPT(0),U,5))
+5 KILL ^TMP("PSBO",$JOB),PSBSIFLG
+6 SET ZTREQ="@"
+7 ;*83 cleanup all PSB* variables for all reports called
DO CLEAN^PSBVT
+8 QUIT
+9 ;
IOM() ; Returns good margin or not
+1 if IOM'<132
QUIT 1
+2 WRITE !,"**************************************************************"
+3 WRITE !,"* SORRY, Your selected DEVICE does not print 132 columns. *"
+4 WRITE !,"**************************************************************"
+5 WRITE !
+6 QUIT 0
+7 ;
VAL(PSBFLDS) ; Validate that fields in PSBFLDS are filled in
+1 NEW PSB,PSBFLD,PSBMSG,PSBSTOP,PSBST,PSBDAYS
SET PSBSTRT=""
+2 FOR PSB=1:1
if $PIECE(PSBFLDS,";",PSB)=""
QUIT
SET PSBFLD=$PIECE(PSBFLDS,";",PSB)
SET PSBFLD(PSBFLD)=$$GET^DDSVAL(53.69,DA,PSBFLD)
+3 IF $DATA(PSBFLD(.11))
if $EXTRACT(PSBFLD(.11))="P"
KILL PSBFLD(.13),PSBFLD(.15)
if $EXTRACT(PSBFLD(.11))="W"
KILL PSBFLD(.12)
+4 SET PSB=""
FOR
SET PSB=$ORDER(PSBFLD(PSB))
if PSB=""
QUIT
if PSBFLD(PSB)=""
Begin DoDot:1
+5 IF '$DATA(PSBMSG)
SET PSBMSG(0)="UNABLE TO FILE REQUEST"
SET PSBMSG(1)=" "
SET PSBMSG(2)="ERROR: MISSING DATA - ALL FIELDS ARE REQUIRED"
SET PSBMSG(3)=" "
+6 DO FIELD^DID(53.69,PSB,"","TITLE;LABEL","PSB")
+7 SET Z=" Missing Field: "_$SELECT(PSB("TITLE")]"":PSB("TITLE"),1:PSB("LABEL"))
+8 SET PSBMSG($ORDER(PSBMSG(""),-1)+1)=Z
End DoDot:1
+9 ; Check Times
+10 if $GET(PSBFLD(.16))
Begin DoDot:1
+11 SET PSBSTRT=PSBFLD(.16)+$GET(PSBFLD(.17))
+12 if $PIECE($$GET1^DIQ(53.69,DA_",",.01),U)["MH"
Begin DoDot:2
+13 ;check maxdays
SET PSBDAYS=$$GET1^DIQ(101.24,$$FIND1^DIC(101.24,"","X","ORRP BCMA MAH","B")_",",.42)
+14 if PSBDAYS=""
SET PSBDAYS=7
+15 ;Determine stop date
SET X=PSBSTRT\1
DO H^%DTC
SET PSBST=%H+PSBDAYS
End DoDot:2
+16 SET PSBSTOP=$SELECT($GET(PSBFLD(.18)):PSBFLD(.18),1:PSBFLD(.16))+$GET(PSBFLD(.19))
+17 IF PSBSTOP<PSBSTRT
SET Y=$ORDER(PSBMSG(""),-1)+1
SET PSBMSG(Y)=" Date: Stop Date/Time is before Start Date/Time"
+18 IF $PIECE($$GET1^DIQ(53.69,DA_",",.01),U)["MH"
SET X=PSBSTOP\1
DO H^%DTC
IF %H>PSBST
SET Y=$ORDER(PSBMSG(""),-1)+1
SET PSBMSG(Y)=" The date range cannot exceed "_PSBDAYS_" day(s) as defined in the CPRS 'MAXIMUM DAYS BACK' parameter"
End DoDot:1
+19 ; All is well
if '$DATA(PSBMSG)
QUIT
+20 DO MSG^DDSUTL(.PSBMSG)
+21 SET DDSERROR=1
+22 QUIT
+23 ;
SETUP ; Setup parameters for the report in PSBRPT
+1 NEW PSBWRDL,PSBINDX,PSBWRDA,QQ,PSBSORT,RECS
+2 ;init RECS found to 0 *70
SET RECS=0
+3 KILL ^TMP("PSBO",$JOB)
+4 FOR X=0,.1,.2,.3,.4,.5,1
SET PSBRPT(X)=$GET(^PSB(53.69,PSBRPT,X))
+5 IF $DATA(^PSB(53.69,PSBRPT,2))
MERGE PSBRPT(2)=^PSB(53.69,PSBRPT,2)
+6 IF $DATA(^PSB(53.69,PSBRPT,3))
MERGE PSBRPT(3)=^PSB(53.69,PSBRPT,3)
+7 ;*68
IF $DATA(^PSB(53.69,PSBRPT,4))
MERGE PSBRPT(4)=^PSB(53.69,PSBRPT,4)
+8 ;if null def to I *70
IF $GET(PSBRPT(4))=""
SET PSBRPT(4)="^I^"
+9 SET PSBRPT(.52)=$PIECE($GET(^PSB(53.69,PSBRPT,.5)),U,2)
+10 ;*68
SET PSBSIFLG=$PIECE($GET(PSBRPT(4)),U)
+11 SET PSBCLINORD=$SELECT($PIECE($GET(PSBRPT(4)),U,2)="C":1,1:0)
+12 ;Running a MSF report PSB*3*28
IF $PIECE(PSBRPT(0),"-")="ST"
IF PSBRPT(3)]""
QUIT
+13 ;Running a MSF report PSB*3*28
IF $PIECE(PSBRPT(0),"-")="SF"
IF PSBRPT(.52)]""
QUIT
+14 ;
+15 ;init PSBSORT ;*70
SET PSBSORT=$PIECE(PSBRPT(.1),U,1)
+16 ;
+17 ;* * Patient Mode * *
+18 IF PSBSORT="P"
Begin DoDot:1
+19 SET PSBDFN=+$PIECE(PSBRPT(.1),U,2)
if 'PSBDFN
QUIT
+20 NEW VA,VADM
SET DFN=PSBDFN
DO DEM^VADPT
+21 if (VADM(1)="")!(VA("PID")="")
QUIT
+22 SET ^TMP("PSBO",$JOB,PSBDFN,0)=VADM(1)_U_VA("PID")
SET ^TMP("PSBO",$JOB,"B",VADM(1),PSBDFN)=""
+23 SET RECS=1
End DoDot:1
IF 'PSBDFN
QUIT RECS
+24 ;
+25 ;* * WARDs per Nurse file group & All patient DFN's * * ;*70
+26 IF PSBSORT="W"
Begin DoDot:1
+27 SET PSBWRD=$PIECE(PSBRPT(.1),U,3)
if 'PSBWRD
QUIT
+28 DO WARD^NURSUT5("L^"_PSBWRD,.PSBWRDA)
+29 if $ORDER(PSBWRDA(""))=""
QUIT
+30 SET QQ=""
FOR
SET QQ=$ORDER(PSBWRDA(PSBWRD,2,QQ))
if QQ=""
QUIT
SET PSBWRDL=$PIECE(PSBWRDA(PSBWRD,2,QQ,.01),U,2)
Begin DoDot:2
+31 FOR PSBDFN=0:0
SET PSBDFN=$ORDER(^DPT("CN",PSBWRDL,PSBDFN))
if 'PSBDFN
QUIT
Begin DoDot:3
+32 SET DFN=PSBDFN
DO DEM^VADPT
+33 if (VADM(1)="")!(VA("PID")="")
QUIT
+34 SET ^TMP("PSBO",$JOB,PSBDFN,0)=VADM(1)_U_VA("PID")
+35 ; Determine Sort or default to Pt Name...
+36 if $PIECE(PSBRPT(.1),U,5)="P"
SET PSBINDX=VADM(1)
+37 IF $PIECE(PSBRPT(.1),U,5)="B"
SET PSBINDX=$PIECE($GET(^DPT(PSBDFN,.101)),U)
if PSBINDX=""
SET PSBINDX="** NO ROOM BED **"
+38 if $PIECE(PSBRPT(.1),U,5)=""
SET PSBINDX=VADM(1)
+39 if $GET(PSBINDX)=""
SET PSBINDX=VADM(1)
+40 SET ^TMP("PSBO",$JOB,"B",PSBINDX,PSBDFN)=""
End DoDot:3
End DoDot:2
+41 if $DATA(^TMP("PSBO",$JOB))
SET RECS=1
End DoDot:1
+42 ;
+43 ;* * Clinics selected & All patient DFN's * * ;*70
+44 IF PSBSORT="C"
Begin DoDot:1
+45 ;no Clinics selected
if '$DATA(PSBRPT(2))
QUIT
+46 DO CLIN(.PSBRPT)
+47 MERGE ^TMP("PSBO",$JOB)=^TMP("PSJCL",$JOB)
KILL ^TMP("PSJCL",$JOB)
+48 if $DATA(^TMP("PSBO",$JOB))
SET RECS=1
End DoDot:1
+49 ;
+50 QUIT
+51 ;Q RECS
+52 ;
WRAP(X,Y,Z) ; Quick text wrap
+1 ;
+2 ; Input Parameters Description:
+3 ; X: Left Column of display [Optional]
+4 ; Y: Cols to wrap in [Optional]
+5 ; Z: Text to wrap [Optional]
+6 ;
+7 NEW PSB
+8 FOR
if '$LENGTH(Z)
QUIT
Begin DoDot:1
+9 if $X>X
WRITE !
+10 if $X<X
WRITE ?X
+11 IF $LENGTH(Z)<Y
WRITE Z
SET Z=""
QUIT
+12 FOR PSB=Y:-1:0
if $EXTRACT(Z,PSB)=" "
QUIT
+13 if PSB<1
SET PSB=Y
+14 WRITE $EXTRACT(Z,1,PSB)
+15 SET Z=$EXTRACT(Z,PSB+1,$LENGTH(Z))
End DoDot:1
+16 QUIT ""
+17 ;
PRNEFF(PSBEIECMT,PSBIEN) ;Check for PRN Error comment
+1 NEW PSBCMTCH
+2 IF $PIECE($GET(PSBRPT(.2)),U,8)=0
SET PSBCMTCH=0
FOR
SET PSBCMTCH=$ORDER(^PSB(53.79,PSBIEN,.3,PSBCMTCH))
if PSBCMTCH=""
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^PSB(53.79,PSBIEN,.3,PSBCMTCH,0)),U)["**Pain Score of"
SET PSBEIECMT=" **This Pain Score may have been Entered in Error. See Vitals Package.**"
End DoDot:1
+4 QUIT PSBEIECMT
+5 ;
FILTERCO ; rebuild TMP using needed recs and remove clinics not wanted
+1 NEW QQ,COCNT,CLNAM
+2 IF '$GET(PSBIENS)
NEW PSBIENS
SET PSBIENS=PSBRPT
+3 SET COCNT=0
KILL ^TMP("PSJTMP",$JOB)
+4 KILL ^TMP("PSJTMP",$JOB)
+5 FOR QQ=0:0
SET QQ=$ORDER(^TMP("PSJ",$JOB,QQ))
if 'QQ
QUIT
Begin DoDot:1
+6 if $PIECE($GET(^TMP("PSJ",$JOB,QQ,0)),U,3)["P"
QUIT
+7 ;Not a CO
SET CLNAM=$PIECE($GET(^TMP("PSJ",$JOB,QQ,0)),U,11)
if CLNAM=""
QUIT
+8 ;ignore orders that are CO and for a Clinic not asked for
+9 IF CLNAM]""
IF '$DATA(^PSB(53.69,+PSBIENS,2,"B",CLNAM))
QUIT
+10 SET COCNT=COCNT+1
+11 MERGE ^TMP("PSJTMP",$JOB,COCNT)=^TMP("PSJ",$JOB,QQ)
End DoDot:1
+12 KILL ^TMP("PSJ",$JOB)
MERGE ^TMP("PSJ",$JOB)=^TMP("PSJTMP",$JOB)
+13 KILL ^TMP("PSJTMP",$JOB)
+14 if '$DATA(^TMP("PSJ",$JOB))
SET ^TMP("PSJ",$JOB,1,0)=-1
+15 QUIT
+16 ;
CLIN(RPTARR,DFNLST) ;Build DFN list of patient orders per Clinics selected
+1 ; Input: RPTARR - Report request array from file 53.69. (required)
+2 ; DFNLST - pass by ref array name if array needed and not
+3 ; a tmp global pass a 1. (optional)
+4 ; default is TMP global
+5 ; DFNLST - array of DFN's only
+6 ;
+7 NEW DFNARR,GLB,ROOT,STARTDT
+8 KILL ^TMP("PSJCL",$JOB)
+9 SET STARTDT=$PIECE($GET(RPTARR(.1)),U,6)
+10 if STARTDT=""
SET STARTDT=$PIECE($$NOW^XLFDT,".")
+11 ;
+12 ;Begin query read with Unit Dose xref and report start date range
+13 SET GLB=$NAME(^PS(55,"AUDC",STARTDT))
SET ROOT=$EXTRACT(GLB,1,13)
+14 DO QUERY(GLB,ROOT,9999999,.RPTARR,.DFNARR)
+15 ;
+16 ;Now do query read for IV xref and report start date range
+17 SET GLB=$NAME(^PS(55,"AIVC",STARTDT))
SET ROOT=$EXTRACT(GLB,1,13)
+18 DO QUERY(GLB,ROOT,9999999,.RPTARR,.DFNARR)
+19 ;
+20 ;if DFNLST then return array and quit
IF $GET(DFNLST)
MERGE DFNLST=DFNARR
QUIT
+21 DO BLDTMP(.DFNARR)
+22 QUIT
+23 ;
QUERY(GLB,ROOT,RPSTOPDT,RPTAR,DFNAR) ;Loops thru global xref via $Query
+1 ; for qualifying recs to find DFN's
+2 NEW CLN,CLNNAM,DFN,STPDT,NOD1,NOD2
+3 IF GLB["UD"
Begin DoDot:1
+4 SET NOD1=5
SET NOD2=8
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 SET NOD1="IV"
SET NOD2="DSS"
End DoDot:1
+7 ;
+8 FOR
SET GLB=$QUERY(@GLB)
if $EXTRACT(GLB,1,13)'=ROOT
QUIT
Begin DoDot:1
+9 SET STPDT=$PIECE($QSUBSCRIPT(GLB,3),".")
SET CLN=$QSUBSCRIPT(GLB,4)
SET DFN=$QSUBSCRIPT(GLB,5)
SET OR=$QSUBSCRIPT(GLB,6)
+10 ;quit if DFN already on ARR
if $DATA(DFNAR(DFN))
QUIT
+11 SET CLNODE=$GET(^PS(55,DFN,NOD1,OR,NOD2))
+12 ;not active bcma clin order
if '$$CLINIC(CLNODE)
QUIT
+13 ;get clinic name
SET CLNNAM=$$GET1^DIQ(44,CLN,.01)
+14 ;quit if rec beyond stop date
if STPDT>RPSTOPDT
QUIT
+15 ;quit if Not on Cln sel list
if '$DATA(RPTAR(2,"B",CLNNAM))
QUIT
+16 ;
+17 ;Keep - Set DFN in array
SET DFNAR(DFN)=""
End DoDot:1
+18 QUIT
+19 ;
BLDTMP(ARR) ;Build Tmp global for DFN's to be included on the report
+1 NEW VA,VADM,PSJINDX
+2 FOR DFN=0:0
SET DFN=$ORDER(ARR(DFN))
if 'DFN
QUIT
Begin DoDot:1
+3 KILL VA,VADM
DO DEM^VADPT
+4 if (VADM(1)="")!(VA("PID")="")
QUIT
+5 SET ^TMP("PSJCL",$JOB,DFN,0)=VADM(1)_U_VA("PID")
+6 SET PSJINDX=VADM(1)
+7 SET ^TMP("PSJCL",$JOB,"B",PSJINDX,DFN)=""
+8 SET RECS=1
End DoDot:1
+9 QUIT
+10 ;
CLINIC(CL) ;Is this a Clinic order that would show on the VDL in CO mode also?
+1 ;no appt date, IM ord
if '($PIECE(CL,"^",2)?7N!($PIECE(CL,"^",2)?7N1".".N))
QUIT 0
+2 ;no PTR to 44, IM ord
if '$DATA(^PS(53.46,"B",+CL))
QUIT 0
+3 ;no 53.46 ien, IM ord
NEW A
SET A=$ORDER(^PS(53.46,"B",+CL,""))
if 'A
QUIT 0
+4 ;Send to BCMA? flag
QUIT $PIECE(^PS(53.46,A,0),"^",4)
