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

PSBO.m

Go to the documentation of this file. 
  1. 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
  1.  ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
  1.  ;
  1.  ; Reference/IA
  1.  ; EN^PSJBCMA/2828
  1.  ; ^ORD(101.24/3429
  1.  ; ^PSDRUG(/221
  1.  ;
  1. RPC(RESULTS,PSBTYPE,PSBDFN,PSBSTRT,PSBSTOP,PSBINCL,PSBDEV,PSBSORT,PSBOI,PSBWLOC,PSBWSORT,PSBFUTR,PSBORDNM,PSBRCRI,PSBLIST,PSBPST,PSBTR,PSBDIV) ;
  1.  ;
  1.  ; RPC: PSB REPORT
  1.  ;
  1.  ; Description:
  1.  ; Used by the client to create individual patient extracts of
  1.  ; CHUI report options to display on the client.
  1.  ;
  1.  S RESULTS=$NAME(^TMP("PSBO",$J))
  1.  N PSBIENS,PSBRPT,PSBFDA,DIC,PSBANS
  1.  K ^TMP("PSBO",$J) S ^TMP("PSBO",$J,1)="-1^"
  1.  S DFN=PSBDFN
  1.  D NEW^PSBO1(.PSBRPT,PSBTYPE)
  1.  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.
  1.  I +PSBRPT(0)<1 S ^TMP("PSBO",$J,1)="-1^Error: "_$P(PSBRPT(0),U,2) Q
  1.  S PSBIENS=+PSBRPT(0)_","
  1.  S PSBSTRT(0)=$E($P(PSBSTRT,".",2)_"0000",1,4),PSBSTRT=PSBSTRT\1
  1.  S PSBSTOP(0)=$E($P(PSBSTOP,".",2)_"0000",1,4),PSBSTOP=PSBSTOP\1
  1.  D:$G(PSBDEV)]""
  1.  .D NOW^%DTC
  1.  .I $P(PSBDEV,U,2)="" D VAL^DIE(53.69,PSBIENS,.06,"F",PSBDEV,"PSBRET","PSBFDA")
  1.  .I $P(PSBDEV,U,2)'="" D VAL^DIE(53.69,PSBIENS,.06,"F","`"_$P(PSBDEV,U,2),"PSBRET","PSBFDA")
  1.  .D VAL^DIE(53.69,PSBIENS,.07,"F",$S($P(PSBRCRI,U)="QD":$P(PSBRCRI,U,2),1:%),"PSBRET","PSBFDA")
  1.  D:$G(PSBOI)]"" VAL^DIE(53.69,PSBIENS,.09,"F",PSBOI,"PSBRET","PSBFDA")
  1.  S:($G(PSBSORT)']"")&(PSBTYPE'="XA") PSBSORT="P" D VAL^DIE(53.69,PSBIENS,.11,"F",PSBSORT,"PSBRET","PSBFDA")
  1.  I "^SF"[("^"_PSBTYPE) D VAL^DIE(53.69,PSBIENS,.51,"F",PSBSORT,"PSBRET","PSBFDA")
  1.  S PSBPST=$TR($G(PSBPST),"^",",")
  1.  D VAL^DIE(53.69,PSBIENS,.52,"F",PSBPST,"PSBRET","PSBFDA")
  1.  S PSBTR=$TR($G(PSBTR),"^",",")
  1.  I $G(PSBDIV)]"" D VAL^DIE(53.69,PSBIENS,.04,"F",$G(PSBDIV),"PSBRET","PSBFDA")
  1.  D VAL^DIE(53.69,PSBIENS,2,"F",PSBTR,"PSBRET","PSBFDA")
  1.  D VAL^DIE(53.69,PSBIENS,.12,"F","`"_PSBDFN,"PSBRET","PSBFDA")
  1.  I $G(PSBWLOC)]"" S PSBFDA(53.69,PSBIENS,.13)=PSBWLOC
  1.  D:$G(PSBWSORT)]"" VAL^DIE(53.69,PSBIENS,.15,"F",PSBWSORT,"PSBRET","PSBFDA")
  1.  D VAL^DIE(53.69,PSBIENS,.16,"F",PSBSTRT,"PSBRET","PSBFDA")
  1.  D VAL^DIE(53.69,PSBIENS,.17,"F",PSBSTRT(0),"PSBRET","PSBFDA")
  1.  D VAL^DIE(53.69,PSBIENS,.18,"F",PSBSTOP,"PSBRET","PSBFDA")
  1.  D VAL^DIE(53.69,PSBIENS,.19,"F",PSBSTOP(0),"PSBRET","PSBFDA")
  1.  D:$G(PSBINCL)]""
  1.  .D VAL^DIE(53.69,PSBIENS,.21,"F",+$P(PSBINCL,"^",1),"PSBRET","PSBFDA")
  1.  .D VAL^DIE(53.69,PSBIENS,.22,"F",+$P(PSBINCL,"^",2),"PSBRET","PSBFDA")
  1.  .D VAL^DIE(53.69,PSBIENS,.23,"F",+$P(PSBINCL,"^",3),"PSBRET","PSBFDA")
  1.  .D VAL^DIE(53.69,PSBIENS,.24,"F",+$P(PSBINCL,"^",4),"PSBRET","PSBFDA")
  1.  .D VAL^DIE(53.69,PSBIENS,.28,"F",+$P(PSBINCL,"^",5),"PSBRET","PSBFDA")
  1.  .D VAL^DIE(53.69,PSBIENS,.29,"F",+$P(PSBINCL,"^",6),"PSBRET","PSBFDA")
  1.  D:$G(PSBFUTR)]""
  1.  .D VAL^DIE(53.69,PSBIENS,.25,"F",+$P(PSBFUTR,"^",1),"PSBRET","PSBFDA")
  1.  .D VAL^DIE(53.69,PSBIENS,.26,"F",+$P(PSBFUTR,"^",2),"PSBRET","PSBFDA")
  1.  .D VAL^DIE(53.69,PSBIENS,.27,"F",+$P(PSBFUTR,"^",3),"PSBRET","PSBFDA")
  1.  .D VAL^DIE(53.69,PSBIENS,.41,"F",+$P(PSBFUTR,"^",4),"PSBRET","PSBFDA")
  1.  .D VAL^DIE(53.69,PSBIENS,.61,"F",$TR(PSBFUTR,"^ ","~"),"PSBRET","PSBFDA")
  1.  D FILE^DIE("","PSBFDA")
  1.  I "^SF"'[("^"_PSBTYPE) I $G(PSBLIST(0),"")]"" D LIST^PSBO1(.PSBLIST)
  1.  I $G(PSBDEV)]"" D PRINT^PSBO1 S RESULTS=$NAME(^TMP("PSBO",$J)) Q
  1.  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
  1.  U IO D DQ(+PSBIENS)
  1.  D HFSCLOSE^PSBUTL("RPC")
  1.  S RESULTS=$NAME(^TMP("PSBO",$J))
  1.  D:$G(PSBDEV)]"" PRINT^PSBO1
  1.  Q
  1.  ;
  1. XQ(PSBTYPE) ; Called via Kernel Menus
  1.  N PSBANS,PSBANS1,PSBRPT,PSBSAVE,DA,DIK,DR,DDSFILE
  1.  D NEW^PSBO1(.PSBRPT,PSBTYPE)
  1.  I +PSBRPT(0)<1 W !,"Error: ",$P(PSBRPT(0),U,2) S DIR(0)="E" D ^DIR Q
  1.  S DA=+PSBRPT(0),DR="[PSBO "_PSBTYPE_"]",DDSFILE=53.69 D ^DDS
  1.  W @IOF
  1.  I 'PSBSAVE W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!"
  1.  D:PSBSAVE
  1.  .;Check Drug to Patient Relationship.
  1.  .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
  1.  .;Allow "'BROWSER" Device
  1.  .S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D
  1.  ..S IOP="`"_IOP,%ZIS="N"
  1.  ..D ^%ZIS
  1.  ..I IO=IO(0) S PSBSIO=1
  1.  ..D HOME^%ZIS K IOP
  1.  .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
  1.  .W @IOF,"Submitting Your Report Request to TaskMan..."
  1.  .S ZTIO=$$GET1^DIQ(53.69,DA_",",.06)
  1.  .S ZTDTH=$P(^PSB(53.69,DA,0),U,7)
  1.  .S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
  1.  .S ZTRTN="DQ^PSBO("_DA_")"
  1.  .D ^%ZTLOAD
  1.  .W "Submitted!",!,"Your Task Number Is: ",$G(ZTSK),!
  1.  K ^TMP("PSBO",$J)
  1.  Q
  1.  ;
  1. DQ(PSBRPT) ; Dequeue report from Taskman
  1.  N PSBDFN
  1.  Q:'$D(^PSB(53.69,PSBRPT,0))  ; No Such Report
  1.  S $P(^PSB(53.69,PSBRPT,0),U,8)=$G(ZTSK,"RPC")
  1.  D:$$SETUP @("EN^PSBO"_$P(PSBRPT(0),U,5))
  1.  K ^TMP("PSBO",$J)
  1.  S ZTREQ="@"
  1.  Q
  1.  ;
  1. IOM() ; Returns good margin or not
  1.  Q:IOM'<132 1
  1.  W !,"**************************************************************"
  1.  W !,"* SORRY, Your selected DEVICE does not print 132 columns.    *"
  1.  W !,"**************************************************************"
  1.  W !
  1.  Q 0
  1.  ;
  1. VAL(PSBFLDS) ; Validate that fields in PSBFLDS are filled in
  1.  N PSB,PSBFLD,PSBMSG,PSBSTOP,PSBST,PSBDAYS S PSBSTRT=""
  1.  F PSB=1:1 Q:$P(PSBFLDS,";",PSB)=""  S PSBFLD=$P(PSBFLDS,";",PSB),PSBFLD(PSBFLD)=$$GET^DDSVAL(53.69,DA,PSBFLD)
  1.  I $D(PSBFLD(.11)) K:$E(PSBFLD(.11))="P" PSBFLD(.13),PSBFLD(.15) K:$E(PSBFLD(.11))="W" PSBFLD(.12)
  1.  S PSB=""  F  S PSB=$O(PSBFLD(PSB)) Q:PSB=""  D:PSBFLD(PSB)=""
  1.  .I '$D(PSBMSG) S PSBMSG(0)="UNABLE TO FILE REQUEST",PSBMSG(1)=" ",PSBMSG(2)="ERROR: MISSING DATA - ALL FIELDS ARE REQUIRED",PSBMSG(3)=" "
  1.  .D FIELD^DID(53.69,PSB,"","TITLE;LABEL","PSB")
  1.  .S Z="  Missing Field: "_$S(PSB("TITLE")]"":PSB("TITLE"),1:PSB("LABEL"))
  1.  .S PSBMSG($O(PSBMSG(""),-1)+1)=Z
  1.  ; Check Times
  1.  D:$G(PSBFLD(.16))
  1.  .S PSBSTRT=PSBFLD(.16)+$G(PSBFLD(.17))
  1.  .D:$P($$GET1^DIQ(53.69,DA_",",.01),U)["MH"
  1.  ..S PSBDAYS=$$GET1^DIQ(101.24,$$FIND1^DIC(101.24,"","X","ORRP BCMA MAH","B")_",",.42)  ;check maxdays
  1.  ..S:PSBDAYS="" PSBDAYS=7
  1.  ..S X=PSBSTRT\1 D H^%DTC S PSBST=%H+PSBDAYS    ;Determine stop date
  1.  .S PSBSTOP=$S($G(PSBFLD(.18)):PSBFLD(.18),1:PSBFLD(.16))+$G(PSBFLD(.19))
  1.  .I PSBSTOP<PSBSTRT S Y=$O(PSBMSG(""),-1)+1,PSBMSG(Y)="  Date: Stop Date/Time is before Start Date/Time"
  1.  .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"
  1.  Q:'$D(PSBMSG)  ; All is well
  1.  D MSG^DDSUTL(.PSBMSG)
  1.  S DDSERROR=1
  1.  Q
  1.  ;
  1. SETUP() ; Setup parameters for the report in PSBRPT
  1.  N PSBWRDL,PSBINDX,PSBWRDA,QQ
  1.  K ^TMP("PSBO",$J)
  1.  F X=0,.1,.2,.3,.4,.5,1 S PSBRPT(X)=$G(^PSB(53.69,PSBRPT,X))
  1.  I $D(^PSB(53.69,PSBRPT,2)) M PSBRPT(2)=^PSB(53.69,PSBRPT,2)
  1.  I $D(^PSB(53.69,PSBRPT,3)) M PSBRPT(3)=^PSB(53.69,PSBRPT,3)
  1.  S PSBRPT(.52)=$P($G(^PSB(53.69,PSBRPT,.5)),U,2)
  1.  I $P(PSBRPT(0),"-")="ST",PSBRPT(3)]"" Q 1  ;Running a MSF report PSB*3*28
  1.  I $P(PSBRPT(0),"-")="SF",PSBRPT(.52)]"" Q 1  ;Running a MSF report PSB*3*28
  1.  I $P(PSBRPT(.1),U,1)="P" D  I 'PSBDFN Q 0
  1.  .S PSBDFN=+$P(PSBRPT(.1),U,2) Q:'PSBDFN
  1.  .N VA,VADM S DFN=PSBDFN D DEM^VADPT
  1.  .Q:(VADM(1)="")!(VA("PID")="")
  1.  .S ^TMP("PSBO",$J,PSBDFN,0)=VADM(1)_U_VA("PID"),^TMP("PSBO",$J,"B",VADM(1),PSBDFN)=""
  1.  I $P(PSBRPT(.1),U,1)="W" D  I 'PSBWRD Q 0
  1.  .S PSBWRD=$P(PSBRPT(.1),U,3) Q:'PSBWRD  D WARD^NURSUT5("L^"_PSBWRD,.PSBWRDA)
  1.  .S QQ="" F  S QQ=$O(PSBWRDA(PSBWRD,2,QQ)) Q:QQ=""   S PSBWRDL=$P(PSBWRDA(PSBWRD,2,QQ,.01),U,2) D
  1.  ..F PSBDFN=0:0 S PSBDFN=$O(^DPT("CN",PSBWRDL,PSBDFN)) Q:PSBDFN=""  D
  1.  ...Q:($G(PSBDFN)="")!($G(PSBDFN)'>0)
  1.  ...S DFN=PSBDFN D DEM^VADPT
  1.  ...Q:(VADM(1)="")!(VA("PID")="")
  1.  ...S ^TMP("PSBO",$J,PSBDFN,0)=VADM(1)_U_VA("PID")
  1.  ...; Determine Sort or default to Pt Name...
  1.  ...S:$P(PSBRPT(.1),U,5)="P" PSBINDX=VADM(1)
  1.  ...I $P(PSBRPT(.1),U,5)="B" S PSBINDX=$P($G(^DPT(PSBDFN,.101)),U) S:PSBINDX="" PSBINDX="** NO ROOM BED **"
  1.  ...S:$P(PSBRPT(.1),U,5)="" PSBINDX=VADM(1)
  1.  ...S:$G(PSBINDX)="" PSBINDX=VADM(1)
  1.  ...S ^TMP("PSBO",$J,"B",PSBINDX,PSBDFN)=""
  1.  Q 1
  1.  ;
  1. WRAP(X,Y,Z) ; Quick text wrap
  1.  ;
  1.  ; Input Parameters Description:
  1.  ;  X: Left Column of display [Optional]
  1.  ;  Y: Cols to wrap in [Optional]
  1.  ;  Z: Text to wrap [Optional]
  1.  ;
  1.  N PSB
  1.  F  Q:'$L(Z)  D
  1.  .W:$X>X !
  1.  .W:$X<X ?X
  1.  .I $L(Z)<Y W Z S Z="" Q
  1.  .F PSB=Y:-1:0 Q:$E(Z,PSB)=" "
  1.  .S:PSB<1 PSB=Y
  1.  .W $E(Z,1,PSB)
  1.  .S Z=$E(Z,PSB+1,250)
  1.  Q ""
  1.  ;
  1. CHECK ;Beginning of PSB*1*10
  1.  K ^TMP("PSJ",$J)
  1.  N PSBDFN,PSBBAR,PSBDRUG,PSBFLAG,PSBPNM,PSBNDX,PSBX
  1.  S PSBFLAG="",PSBBAR=$P($P($G(^PSB(53.69,DA,.3)),U,1),"~",2)
  1.  S PSBDRUG=$$GET1^DIQ(53.69,DA_",",.31)
  1.  S PSBDFN=$$GET1^DIQ(53.69,DA_",",.12,"I") S:$G(PSBDFN) PSBFLAG=1
  1.  D EN^PSJBCMA(PSBDFN)
  1.  F PSBX=0:0 S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:'PSBX  D
  1.  .K Y,PSBORD,PSBPNM,PSBNDX
  1.  .M PSBORD=^TMP("PSJ",$J,PSBX)
  1.  .F PSBNDX=700,850,950  D
  1.  ..F Y=0:0 S Y=$O(PSBORD(PSBNDX,Y)) Q:'Y  D
  1.  ...I $P($G(PSBORD(1)),U,7)'="A" Q
  1.  ...S PSBPNM=$P(PSBORD(PSBNDX,Y,0),U,1)
  1.  ...I PSBNDX=700,PSBPNM=PSBBAR S PSBFLAG=0 Q
  1.  ...I PSBNDX=850,$D(^PSDRUG("A526",PSBBAR,PSBPNM)) S PSBFLAG=0 Q
  1.  ...I PSBNDX=950,$D(^PSDRUG("A527",PSBBAR,PSBPNM)) S PSBFLAG=0
  1.  I PSBFLAG=1 D
  1.  .W !,"Patient is not currently on medication: ",PSBDRUG
  1.  .K DIRUT,DIR
  1.  .S DIR("A")="Do you want to continue"
  1.  .S DIR(0)="Y"
  1.  .D ^DIR
  1.  .S PSBANS=+Y W !
  1.  Q
  1.  ;
  1. PRNEFF(PSBEIECMT,PSBIEN) ;Check for PRN Error comment
  1.  N PSBCMTCH
  1.  I $P($G(PSBRPT(.2)),U,8)=0 S PSBCMTCH=0 F  S PSBCMTCH=$O(^PSB(53.79,PSBIEN,.3,PSBCMTCH)) Q:PSBCMTCH=""  D
  1.  .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.**"
  1.  Q PSBEIECMT
  1.  ;