- 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 Jan 18, 2025@02:41:31 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)