PSBO ;BIRMINGHAM/EFC - BCMA OUTPUTS ;8/20/10 8:25am
;;3.0;BAR CODE MED ADMIN;**13,32,2,25,28,51,50,42**;Mar 2004;Build 23
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
; Reference/IA
; EN^PSJBCMA/2828
; ^ORD(101.24/3429
; ^PSDRUG(/221
;
RPC(RESULTS,PSBTYPE,PSBDFN,PSBSTRT,PSBSTOP,PSBINCL,PSBDEV,PSBSORT,PSBOI,PSBWLOC,PSBWSORT,PSBFUTR,PSBORDNM,PSBRCRI,PSBLIST,PSBPST,PSBTR,PSBDIV) ;
;
; 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
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")
D FILE^DIE("","PSBFDA")
I "^SF"'[("^"_PSBTYPE) I $G(PSBLIST(0),"")]"" D LIST^PSBO1(.PSBLIST)
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
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 I PSBANS=0!($D(DIRUT)) W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!" Q
.;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)
S ZTREQ="@"
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
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)
S PSBRPT(.52)=$P($G(^PSB(53.69,PSBRPT,.5)),U,2)
I $P(PSBRPT(0),"-")="ST",PSBRPT(3)]"" Q 1 ;Running a MSF report PSB*3*28
I $P(PSBRPT(0),"-")="SF",PSBRPT(.52)]"" Q 1 ;Running a MSF report PSB*3*28
I $P(PSBRPT(.1),U,1)="P" D I 'PSBDFN Q 0
.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)=""
I $P(PSBRPT(.1),U,1)="W" D I 'PSBWRD Q 0
.S PSBWRD=$P(PSBRPT(.1),U,3) Q:'PSBWRD D WARD^NURSUT5("L^"_PSBWRD,.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
...Q:($G(PSBDFN)="")!($G(PSBDFN)'>0)
...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)=""
Q 1
;
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,250)
Q ""
;
CHECK ;Beginning of PSB*1*10
K ^TMP("PSJ",$J)
N PSBDFN,PSBBAR,PSBDRUG,PSBFLAG,PSBPNM,PSBNDX,PSBX
S PSBFLAG="",PSBBAR=$P($P($G(^PSB(53.69,DA,.3)),U,1),"~",2)
S PSBDRUG=$$GET1^DIQ(53.69,DA_",",.31)
S PSBDFN=$$GET1^DIQ(53.69,DA_",",.12,"I") S:$G(PSBDFN) PSBFLAG=1
D EN^PSJBCMA(PSBDFN)
F PSBX=0:0 S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:'PSBX D
.K Y,PSBORD,PSBPNM,PSBNDX
.M PSBORD=^TMP("PSJ",$J,PSBX)
.F PSBNDX=700,850,950 D
..F Y=0:0 S Y=$O(PSBORD(PSBNDX,Y)) Q:'Y D
...I $P($G(PSBORD(1)),U,7)'="A" Q
...S PSBPNM=$P(PSBORD(PSBNDX,Y,0),U,1)
...I PSBNDX=700,PSBPNM=PSBBAR S PSBFLAG=0 Q
...I PSBNDX=850,$D(^PSDRUG("A526",PSBBAR,PSBPNM)) S PSBFLAG=0 Q
...I PSBNDX=950,$D(^PSDRUG("A527",PSBBAR,PSBPNM)) S PSBFLAG=0
I PSBFLAG=1 D
.W !,"Patient is not currently on medication: ",PSBDRUG
.K DIRUT,DIR
.S DIR("A")="Do you want to continue"
.S DIR(0)="Y"
.D ^DIR
.S PSBANS=+Y W !
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
;
PSBO ;BIRMINGHAM/EFC - BCMA OUTPUTS ;8/20/10 8:25am
+1 ;;3.0;BAR CODE MED ADMIN;**13,32,2,25,28,51,50,42**;Mar 2004;Build 23
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; EN^PSJBCMA/2828
+6 ; ^ORD(101.24/3429
+7 ; ^PSDRUG(/221
+8 ;
RPC(RESULTS,PSBTYPE,PSBDFN,PSBSTRT,PSBSTOP,PSBINCL,PSBDEV,PSBSORT,PSBOI,PSBWLOC,PSBWSORT,PSBFUTR,PSBORDNM,PSBRCRI,PSBLIST,PSBPST,PSBTR,PSBDIV) ;
+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 SET RESULTS=$NAME(^TMP("PSBO",$JOB))
+9 NEW PSBIENS,PSBRPT,PSBFDA,DIC,PSBANS
+10 KILL ^TMP("PSBO",$JOB)
SET ^TMP("PSBO",$JOB,1)="-1^"
+11 SET DFN=PSBDFN
+12 DO NEW^PSBO1(.PSBRPT,PSBTYPE)
+13 ;;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)
+14 IF +PSBRPT(0)<1
SET ^TMP("PSBO",$JOB,1)="-1^Error: "_$PIECE(PSBRPT(0),U,2)
QUIT
+15 SET PSBIENS=+PSBRPT(0)_","
+16 SET PSBSTRT(0)=$EXTRACT($PIECE(PSBSTRT,".",2)_"0000",1,4)
SET PSBSTRT=PSBSTRT\1
+17 SET PSBSTOP(0)=$EXTRACT($PIECE(PSBSTOP,".",2)_"0000",1,4)
SET PSBSTOP=PSBSTOP\1
+18 IF $GET(PSBDEV)]""
Begin DoDot:1
+19 DO NOW^%DTC
+20 IF $PIECE(PSBDEV,U,2)=""
DO VAL^DIE(53.69,PSBIENS,.06,"F",PSBDEV,"PSBRET","PSBFDA")
+21 IF $PIECE(PSBDEV,U,2)'=""
DO VAL^DIE(53.69,PSBIENS,.06,"F","`"_$PIECE(PSBDEV,U,2),"PSBRET","PSBFDA")
+22 DO VAL^DIE(53.69,PSBIENS,.07,"F",$SELECT($PIECE(PSBRCRI,U)="QD":$PIECE(PSBRCRI,U,2),1:%),"PSBRET","PSBFDA")
End DoDot:1
+23 IF $GET(PSBOI)]""
DO VAL^DIE(53.69,PSBIENS,.09,"F",PSBOI,"PSBRET","PSBFDA")
+24 IF ($GET(PSBSORT)']"")&(PSBTYPE'="XA")
SET PSBSORT="P"
DO VAL^DIE(53.69,PSBIENS,.11,"F",PSBSORT,"PSBRET","PSBFDA")
+25 IF "^SF"[("^"_PSBTYPE)
DO VAL^DIE(53.69,PSBIENS,.51,"F",PSBSORT,"PSBRET","PSBFDA")
+26 SET PSBPST=$TRANSLATE($GET(PSBPST),"^",",")
+27 DO VAL^DIE(53.69,PSBIENS,.52,"F",PSBPST,"PSBRET","PSBFDA")
+28 SET PSBTR=$TRANSLATE($GET(PSBTR),"^",",")
+29 IF $GET(PSBDIV)]""
DO VAL^DIE(53.69,PSBIENS,.04,"F",$GET(PSBDIV),"PSBRET","PSBFDA")
+30 DO VAL^DIE(53.69,PSBIENS,2,"F",PSBTR,"PSBRET","PSBFDA")
+31 DO VAL^DIE(53.69,PSBIENS,.12,"F","`"_PSBDFN,"PSBRET","PSBFDA")
+32 IF $GET(PSBWLOC)]""
SET PSBFDA(53.69,PSBIENS,.13)=PSBWLOC
+33 IF $GET(PSBWSORT)]""
DO VAL^DIE(53.69,PSBIENS,.15,"F",PSBWSORT,"PSBRET","PSBFDA")
+34 DO VAL^DIE(53.69,PSBIENS,.16,"F",PSBSTRT,"PSBRET","PSBFDA")
+35 DO VAL^DIE(53.69,PSBIENS,.17,"F",PSBSTRT(0),"PSBRET","PSBFDA")
+36 DO VAL^DIE(53.69,PSBIENS,.18,"F",PSBSTOP,"PSBRET","PSBFDA")
+37 DO VAL^DIE(53.69,PSBIENS,.19,"F",PSBSTOP(0),"PSBRET","PSBFDA")
+38 IF $GET(PSBINCL)]""
Begin DoDot:1
+39 DO VAL^DIE(53.69,PSBIENS,.21,"F",+$PIECE(PSBINCL,"^",1),"PSBRET","PSBFDA")
+40 DO VAL^DIE(53.69,PSBIENS,.22,"F",+$PIECE(PSBINCL,"^",2),"PSBRET","PSBFDA")
+41 DO VAL^DIE(53.69,PSBIENS,.23,"F",+$PIECE(PSBINCL,"^",3),"PSBRET","PSBFDA")
+42 DO VAL^DIE(53.69,PSBIENS,.24,"F",+$PIECE(PSBINCL,"^",4),"PSBRET","PSBFDA")
+43 DO VAL^DIE(53.69,PSBIENS,.28,"F",+$PIECE(PSBINCL,"^",5),"PSBRET","PSBFDA")
+44 DO VAL^DIE(53.69,PSBIENS,.29,"F",+$PIECE(PSBINCL,"^",6),"PSBRET","PSBFDA")
End DoDot:1
+45 IF $GET(PSBFUTR)]""
Begin DoDot:1
+46 DO VAL^DIE(53.69,PSBIENS,.25,"F",+$PIECE(PSBFUTR,"^",1),"PSBRET","PSBFDA")
+47 DO VAL^DIE(53.69,PSBIENS,.26,"F",+$PIECE(PSBFUTR,"^",2),"PSBRET","PSBFDA")
+48 DO VAL^DIE(53.69,PSBIENS,.27,"F",+$PIECE(PSBFUTR,"^",3),"PSBRET","PSBFDA")
+49 DO VAL^DIE(53.69,PSBIENS,.41,"F",+$PIECE(PSBFUTR,"^",4),"PSBRET","PSBFDA")
+50 DO VAL^DIE(53.69,PSBIENS,.61,"F",$TRANSLATE(PSBFUTR,"^ ","~"),"PSBRET","PSBFDA")
End DoDot:1
+51 DO FILE^DIE("","PSBFDA")
+52 IF "^SF"'[("^"_PSBTYPE)
IF $GET(PSBLIST(0),"")]""
DO LIST^PSBO1(.PSBLIST)
+53 IF $GET(PSBDEV)]""
DO PRINT^PSBO1
SET RESULTS=$NAME(^TMP("PSBO",$JOB))
QUIT
+54 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
+55 USE IO
DO DQ(+PSBIENS)
+56 DO HFSCLOSE^PSBUTL("RPC")
+57 SET RESULTS=$NAME(^TMP("PSBO",$JOB))
+58 IF $GET(PSBDEV)]""
DO PRINT^PSBO1
+59 QUIT
+60 ;
XQ(PSBTYPE) ; Called via Kernel Menus
+1 NEW PSBANS,PSBANS1,PSBRPT,PSBSAVE,DA,DIK,DR,DDSFILE
+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
IF PSBANS=0!($DATA(DIRUT))
WRITE !,"Cancelling Request..."
SET DIK="^PSB(53.69,"
DO ^DIK
WRITE "Cancelled!"
QUIT
+10 ;Allow "'BROWSER" Device
+11 SET IOP=$$GET1^DIQ(53.69,DA_",",.06,"I")
SET PSBSIO=0
IF IOP]""
Begin DoDot:2
+12 SET IOP="`"_IOP
SET %ZIS="N"
+13 DO ^%ZIS
+14 IF IO=IO(0)
SET PSBSIO=1
+15 DO HOME^%ZIS
KILL IOP
End DoDot:2
+16 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
+17 WRITE @IOF,"Submitting Your Report Request to TaskMan..."
+18 SET ZTIO=$$GET1^DIQ(53.69,DA_",",.06)
+19 SET ZTDTH=$PIECE(^PSB(53.69,DA,0),U,7)
+20 SET ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
+21 SET ZTRTN="DQ^PSBO("_DA_")"
+22 DO ^%ZTLOAD
+23 WRITE "Submitted!",!,"Your Task Number Is: ",$GET(ZTSK),!
End DoDot:1
+24 KILL ^TMP("PSBO",$JOB)
+25 QUIT
+26 ;
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 IF $$SETUP
DO @("EN^PSBO"_$PIECE(PSBRPT(0),U,5))
+5 KILL ^TMP("PSBO",$JOB)
+6 SET ZTREQ="@"
+7 QUIT
+8 ;
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
+2 KILL ^TMP("PSBO",$JOB)
+3 FOR X=0,.1,.2,.3,.4,.5,1
SET PSBRPT(X)=$GET(^PSB(53.69,PSBRPT,X))
+4 IF $DATA(^PSB(53.69,PSBRPT,2))
MERGE PSBRPT(2)=^PSB(53.69,PSBRPT,2)
+5 IF $DATA(^PSB(53.69,PSBRPT,3))
MERGE PSBRPT(3)=^PSB(53.69,PSBRPT,3)
+6 SET PSBRPT(.52)=$PIECE($GET(^PSB(53.69,PSBRPT,.5)),U,2)
+7 ;Running a MSF report PSB*3*28
IF $PIECE(PSBRPT(0),"-")="ST"
IF PSBRPT(3)]""
QUIT 1
+8 ;Running a MSF report PSB*3*28
IF $PIECE(PSBRPT(0),"-")="SF"
IF PSBRPT(.52)]""
QUIT 1
+9 IF $PIECE(PSBRPT(.1),U,1)="P"
Begin DoDot:1
+10 SET PSBDFN=+$PIECE(PSBRPT(.1),U,2)
IF 'PSBDFN
QUIT
+11 NEW VA,VADM
SET DFN=PSBDFN
DO DEM^VADPT
+12 IF (VADM(1)="")!(VA("PID")="")
QUIT
+13 SET ^TMP("PSBO",$JOB,PSBDFN,0)=VADM(1)_U_VA("PID")
SET ^TMP("PSBO",$JOB,"B",VADM(1),PSBDFN)=""
End DoDot:1
IF 'PSBDFN
QUIT 0
+14 IF $PIECE(PSBRPT(.1),U,1)="W"
Begin DoDot:1
+15 SET PSBWRD=$PIECE(PSBRPT(.1),U,3)
IF 'PSBWRD
QUIT
DO WARD^NURSUT5("L^"_PSBWRD,.PSBWRDA)
+16 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
+17 FOR PSBDFN=0:0
SET PSBDFN=$ORDER(^DPT("CN",PSBWRDL,PSBDFN))
IF PSBDFN=""
QUIT
Begin DoDot:3
+18 IF ($GET(PSBDFN)="")!($GET(PSBDFN)'>0)
QUIT
+19 SET DFN=PSBDFN
DO DEM^VADPT
+20 IF (VADM(1)="")!(VA("PID")="")
QUIT
+21 SET ^TMP("PSBO",$JOB,PSBDFN,0)=VADM(1)_U_VA("PID")
+22 ; Determine Sort or default to Pt Name...
+23 IF $PIECE(PSBRPT(.1),U,5)="P"
SET PSBINDX=VADM(1)
+24 IF $PIECE(PSBRPT(.1),U,5)="B"
SET PSBINDX=$PIECE($GET(^DPT(PSBDFN,.101)),U)
IF PSBINDX=""
SET PSBINDX="** NO ROOM BED **"
+25 IF $PIECE(PSBRPT(.1),U,5)=""
SET PSBINDX=VADM(1)
+26 IF $GET(PSBINDX)=""
SET PSBINDX=VADM(1)
+27 SET ^TMP("PSBO",$JOB,"B",PSBINDX,PSBDFN)=""
End DoDot:3
End DoDot:2
End DoDot:1
IF 'PSBWRD
QUIT 0
+28 QUIT 1
+29 ;
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,250)
End DoDot:1
+16 QUIT ""
+17 ;
CHECK ;Beginning of PSB*1*10
+1 KILL ^TMP("PSJ",$JOB)
+2 NEW PSBDFN,PSBBAR,PSBDRUG,PSBFLAG,PSBPNM,PSBNDX,PSBX
+3 SET PSBFLAG=""
SET PSBBAR=$PIECE($PIECE($GET(^PSB(53.69,DA,.3)),U,1),"~",2)
+4 SET PSBDRUG=$$GET1^DIQ(53.69,DA_",",.31)
+5 SET PSBDFN=$$GET1^DIQ(53.69,DA_",",.12,"I")
IF $GET(PSBDFN)
SET PSBFLAG=1
+6 DO EN^PSJBCMA(PSBDFN)
+7 FOR PSBX=0:0
SET PSBX=$ORDER(^TMP("PSJ",$JOB,PSBX))
IF 'PSBX
QUIT
Begin DoDot:1
+8 KILL Y,PSBORD,PSBPNM,PSBNDX
+9 MERGE PSBORD=^TMP("PSJ",$JOB,PSBX)
+10 FOR PSBNDX=700,850,950
Begin DoDot:2
+11 FOR Y=0:0
SET Y=$ORDER(PSBORD(PSBNDX,Y))
IF 'Y
QUIT
Begin DoDot:3
+12 IF $PIECE($GET(PSBORD(1)),U,7)'="A"
QUIT
+13 SET PSBPNM=$PIECE(PSBORD(PSBNDX,Y,0),U,1)
+14 IF PSBNDX=700
IF PSBPNM=PSBBAR
SET PSBFLAG=0
QUIT
+15 IF PSBNDX=850
IF $DATA(^PSDRUG("A526",PSBBAR,PSBPNM))
SET PSBFLAG=0
QUIT
+16 IF PSBNDX=950
IF $DATA(^PSDRUG("A527",PSBBAR,PSBPNM))
SET PSBFLAG=0
End DoDot:3
End DoDot:2
End DoDot:1
+17 IF PSBFLAG=1
Begin DoDot:1
+18 WRITE !,"Patient is not currently on medication: ",PSBDRUG
+19 KILL DIRUT,DIR
+20 SET DIR("A")="Do you want to continue"
+21 SET DIR(0)="Y"
+22 DO ^DIR
+23 SET PSBANS=+Y
WRITE !
End DoDot:1
+24 QUIT
+25 ;
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 ;
