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

PSBO1.m

Go to the documentation of this file.
  1. PSBO1 ;BIRMINGHAM/EFC-BCMA OUTPUTS ;2/26/21 12:27
  1. ;;3.0;BAR CODE MED ADMIN;**4,13,32,2,43,28,70,83,103,114,106**;Mar 2004;Build 43
  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. ;
  1. ;*70 - add ablility to update List multiple for Clinic names
  1. ;*83 - add Function GETREMOV to find removes for associated MRR Gives
  1. ;*106- add Hazardous Handle & Dispose flags
  1. ;
  1. NEW(RESULTS,PSBRTYP) ; Create a new report request
  1. ; Called interactively and via RPCBroker
  1. K RESULTS
  1. ; Check Type
  1. ; PSB*3*103 - added 'RT' code for Respiratory Therapy report, called from EN1+3^PSBMMRB
  1. I '$F("DL^MD^MH^ML^MM^MV^MT^PE^PM^WA^BL^PI^AL^DO^VT^PF^XA^ST^SF^IV^CM^CP^CE^CI^BZ^RT^",PSBRTYP) S RESULTS(0)="-1^Invalid Report Type" Q
  1. I '+$G(DUZ) S RESULTS(0)="-1^Undefined User" Q
  1. I '$G(DUZ(2)) S RESULTS(0)="-1^Undefined Division" Q
  1. ; Lock Log
  1. L +(^PSB(53.69,0)):$S($G(DILOCKTM)>30:DILOCKTM,1:30)
  1. E S RESULTS(0)="-1^Request Log Locked" Q
  1. ; Generate Unique Entry and Create
  1. F D NOW^%DTC S X=$E(%_"000000",1,14) S X=(1700+$E(X,1,3))_$E(X,4,14),X=PSBRTYP_"-"_$TR(X,".","-") Q:'$D(^PSB(53.69,"B",X))
  1. S DIC="^PSB(53.69,",DIC(0)="L"
  1. S DIC("DR")=".02///N;.03////^S X=DUZ;.04////^S X=DUZ(2);.05///^S X=PSBRTYP"
  1. K DD,DO D FILE^DICN
  1. L -(^PSB(53.69,0))
  1. ; Okay, setup return and Boogie
  1. I +Y<1 S RESULTS(0)="-1^Error Creating Request"
  1. E S RESULTS(0)=Y
  1. K DO
  1. Q
  1. ;
  1. PRINT ;
  1. N ZTDTH,ZTRTN,ZTSK,ZTDESC,ZTSAVE,DA
  1. S DA=+PSBRPT(0)
  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^PSBO(DA) D ^%ZISC K IOP Q
  1. W @IOF,"Submitting Your Report Request to TaskMan..."
  1. S ZTIO=$$GET1^DIQ(53.69,DA_",",.06)_";132"
  1. S ZTDTH=$S($$GET1^DIQ(53.69,DA_",",.07,"I")]"":$$GET1^DIQ(53.69,DA_",",.07,"I"),1:$H)
  1. S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
  1. S ZTRTN="DQ^PSBO("_DA_")"
  1. F I="PSBDFN","PSBTYPE" S ZTSAVE(I)=""
  1. I $G(PSBORDNM)]"" S ZTSAVE("PSBORDNM")=""
  1. D ^%ZTLOAD
  1. I $D(ZTSK) S ^TMP("PSBO",$J,1)="0^Report queued. (Task #"_ZTSK_")"
  1. E S ^TMP("PSBO",$J,1)="-1^Task Rejected."
  1. Q
  1. ;
  1. LIST(XLIST) ; Place List Criteria into subfile #53.692 (multiple)
  1. F XL1=$O(XLIST("")):1:$O(XLIST("B"),-1) Q:+XL1="" D
  1. .;*70 add"MM", "WA" rpts to accept array list of selected clinics
  1. .; build reports that use Clinic search list array
  1. .N PSBCLN
  1. .F CLN="WA","DL","MM","CM","CP","CI","CE" S PSBCLN(CLN)=""
  1. .I ($P(XLIST(XL1),U)=PSBTYPE)!($D(PSBCLN(PSBTYPE))) D
  1. ..K PSBFDA,PSBRET,PSBIENX D CLEAN^DILF
  1. ..S PSBIENX="+"_(XL1+1)_","_PSBIENS
  1. ..D VAL^DIE(53.692,"+"_(XL1+1)_","_PSBIENS,.01,"F",$TR(XLIST(XL1),"^","~"),"PSBRET","PSBFDA")
  1. ..D UPDATE^DIE("","PSBFDA","PSBIENX","PSBRET")
  1. Q
  1. ;
  1. CHECK ;Beginning of PSB*1*10
  1. K ^TMP("PSJ",$J),PSBCL ;[*70-1459]
  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. ;
  1. F PSBX=0:0 S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:'PSBX D
  1. .K Y,PSBORD,PSBPNM,PSBNDX
  1. .S PSBCL=$P(^TMP("PSJ",$J,PSBX,0),U,11) ;[*70-1459]
  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 D Q ;[*70-1459]
  1. ....S PSBFLAG=0 ;[*70-1459]
  1. ....I PSBCL]"" S PSBCL(PSBCL)="" ;[*70-1459]
  1. ....E S PSBCL($$GET1^DIQ(2,$P(PSBORD(0),U),.1)_" (Ward)")="" ;[*70-1459]
  1. ...I PSBNDX=850,$D(^PSDRUG("A526",PSBBAR,PSBPNM)) D Q ;[*70-1459]
  1. ....S PSBFLAG=0 ;[*70-1459]
  1. ....I PSBCL]"" S PSBCL(PSBCL)="" ;[*70-1459]
  1. ....E S PSBCL($$GET1^DIQ(2,$P(PSBORD(0),U),.1)_" (Ward)")="" ;[*70-1459]
  1. ...I PSBNDX=950,$D(^PSDRUG("A527",PSBBAR,PSBPNM)) D Q ;[*70-1459]
  1. ....S PSBFLAG=0 ;[*70-1459]
  1. ....I PSBCL]"" S PSBCL(PSBCL)="" ;[*70-1459]
  1. ....E S PSBCL($$GET1^DIQ(2,$P(PSBORD(0),U),.1)_" (Ward)")="" ;[*70-1459]
  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. GETREMOV(DFN) ;Process removal type XREFS and return any RM's found with key info
  1. N PSBGNODE,PSBIEN,DSPDRG
  1. K ^TMP("PSB",$J,"RM")
  1. ;
  1. ;Xref APATCH search
  1. S PSBGNODE="^PSB(53.79,"_"""APATCH"""_","_DFN_")"
  1. F S PSBGNODE=$Q(@PSBGNODE) Q:PSBGNODE']"" Q:($QS(PSBGNODE,2)'="APATCH")!($QS(PSBGNODE,3)'=DFN) D
  1. .S PSBIEN=$QS(PSBGNODE,5),DSPDRG=$O(^PSB(53.79,PSBIEN,.5,0)) I 'DSPDRG Q
  1. .Q:'$D(^PSB(53.79,PSBIEN,.5,DSPDRG))
  1. .Q:$P(^PSB(53.79,PSBIEN,.5,DSPDRG,0),U,4)'="PATCH"
  1. .Q:$P(^PSB(53.79,PSBIEN,0),U,9)'="G"
  1. .D SETTMP ;get remove info and save to Tmp
  1. ;
  1. ;Xref AMRR search
  1. S PSBGNODE="^PSB(53.79,"_"""AMRR"""_","_DFN_")"
  1. F S PSBGNODE=$Q(@PSBGNODE) Q:PSBGNODE']"" Q:($QS(PSBGNODE,2)'="AMRR")!($QS(PSBGNODE,3)'=DFN) D
  1. .S PSBIEN=$QS(PSBGNODE,5)
  1. .Q:'$D(^PSB(53.79,PSBIEN,.5,1))
  1. .Q:'$P(^PSB(53.79,PSBIEN,.5,1,0),U,6)
  1. .Q:$P(^PSB(53.79,PSBIEN,0),U,9)'="G"
  1. .D SETTMP ;get remove info and save to Tmp
  1. Q
  1. ;
  1. SETTMP(IEN) ;get and set MRR info for printing
  1. N RMDT,ONX
  1. S RMDT=$$GET1^DIQ(53.79,PSBIEN,"SCHEDULED REMOVAL TIME","I")
  1. S ONX=$$GET1^DIQ(53.79,PSBIEN,"ORDER REFERENCE NUMBER")
  1. K ^TMP("PSJ1",$J) D EN^PSJBCMA1(DFN,ONX,1)
  1. Q:$G(^TMP("PSJ1",$J,0))=-1
  1. S $P(^TMP("PSB",$J,"RM",PSBIEN),U,1)=RMDT ;RMDT
  1. S $P(^TMP("PSB",$J,"RM",PSBIEN),U,2)=ONX ;ONX
  1. S $P(^TMP("PSB",$J,"RM",PSBIEN),U,3)=$P(^TMP("PSJ1",$J,2),U,2) ;OITX
  1. S $P(^TMP("PSB",$J,"RM",PSBIEN),U,4)=$P(^TMP("PSJ1",$J,1),U,10) ;OSTS
  1. S $P(^TMP("PSB",$J,"RM",PSBIEN),U,5)=$P(^TMP("PSJ1",$J,4),U,7) ;OSPO
  1. S $P(^TMP("PSB",$J,"RM",PSBIEN),U,6)=$P(^TMP("PSJ1",$J,0),U,11) ;CLOR
  1. S $P(^TMP("PSB",$J,"RM",PSBIEN),U,7)=$P(^TMP("PSJ1",$J,2),U,3) ;DOSE
  1. S $P(^TMP("PSB",$J,"RM",PSBIEN),U,8)=$P(^TMP("PSJ1",$J,1),U,13) ;MRNM
  1. S $P(^TMP("PSB",$J,"RM",PSBIEN),U,9)=$P(^TMP("PSJ1",$J,1),U,5) ;SM
  1. ;*106 Haz pieces
  1. S $P(^TMP("PSB",$J,"RM",PSBIEN),U,10)=$P(^TMP("PSJ1",$J,700,1,0),U,8) ;HAZHAN
  1. S $P(^TMP("PSB",$J,"RM",PSBIEN),U,11)=$P(^TMP("PSJ1",$J,700,1,0),U,9) ;HAZDIS
  1. S ^TMP("PSB",$J,"RM","B",ONX,PSBIEN)="" ;ORDER NUM XREF
  1. Q