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

PSBMLLKU.m

Go to the documentation of this file. 
  1. PSBMLLKU ;BIRMINGHAM/TEJ - BCMA RPC LOOKUP UTLILITIES ;10/5/10 9:16am
  1.  ;;3.0;BAR CODE MED ADMIN;**3,9,11,20,13,38,32,56,42**;Mar 2004;Build 62
  1.  ;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1.  ; Reference/IA
  1.  ; EN^PSJBCMA1/2829
  1.  ; $$DOB^DPTLK1/3266
  1.  ; $$SSN^DPTLK1/3267
  1.  ; ^DPT/10035
  1.  ; ^XUSEC/10076
  1.  ; File 52.6/436
  1.  ; File 52.7/437
  1.  ; File 50/221
  1.  ; File 211.4/1409
  1.  ;
  1. RPC(RESULTS,PSBREC) ; Remote Procedure Call Entry Point.
  1.  ;
  1.  S RESULTS="" D @(PSBREC(0)_"(.RESULTS,.PSBREC)") Q
  1.  Q
  1.  ;
  1. ADMLKUP(RESULTS,PSBREC) ;
  1.  ;  Lookup ADMinistrations per DFN and search DATE
  1.  ;   input - PSBREC(1)  DFN
  1.  ;           PSBREC(2)  Search DATE
  1.  ;
  1.  ;   outpt - RESULTS (array)
  1.  ;          (Administrations returned will be dated  = to Search Date
  1.  ;
  1.  ;
  1.  K RESULTS
  1.  S DFN=PSBREC(1),PSBSRCH=$G(PSBREC(2)) I $G(PSBSRCH)']"" D NOW^%DTC S PSBSRCH=$P(%,".")
  1.  S PSBDT=PSBSRCH,PSBCNT=0 S:PSBSRCH'["." PSBSRCH=PSBSRCH+.9
  1.  S RESULTS(0)=1,RESULTS(1)="-1^No Meds Found!"
  1.  F  S PSBSRCH=$O(^PSB(53.79,"AADT",DFN,PSBSRCH),-1) Q:'PSBSRCH!(PSBSRCH<PSBDT)  D
  1.  .S PSBIEN=""
  1.  .F  S PSBIEN=$O(^PSB(53.79,"AADT",DFN,PSBSRCH,PSBIEN),-1) Q:'PSBIEN  D:'$D(^PSB(53.79,PSBIEN)) KILLAADT  Q:'$D(^PSB(53.79,PSBIEN))  D:$$CHKKEY(PSBIEN)
  1.  ..L +^PSB(53.79,PSBIEN):1
  1.  ..I  L -^PSB(53.79,PSBIEN)
  1.  ..E  Q
  1.  ..S PSBXORDN=$$GET1^DIQ(53.79,PSBIEN_",",.11) Q:'$D(^PSB(53.79,"AORDX",DFN,PSBXORDN,PSBSRCH))
  1.  ..Q:($$GET1^DIQ(53.79,PSBIEN_",",.06,"I")>PSBSRCH)
  1.  ..Q:($$GET1^DIQ(53.79,PSBIEN_",",.09,"I")="N")
  1.  ..S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=PSBIEN
  1.  ..S $P(RESULTS(PSBCNT),U,2)=PSBSRCH
  1.  ..S $P(RESULTS(PSBCNT),U,3)=$$GET1^DIQ(53.79,PSBIEN_",",.08)
  1.  ..S:$$GET1^DIQ(53.79,PSBIEN_",",.26) $P(RESULTS(PSBCNT),U,4)=$$GET1^DIQ(53.79,PSBIEN_",",.26)
  1.  ..S $P(RESULTS(PSBCNT),U,5)=$S($$GET1^DIQ(53.79,PSBIEN_",",.09,"I")']"":"U",1:$$GET1^DIQ(53.79,PSBIEN_",",.09,"I"))
  1.  ..D  ; Get order information
  1.  ...K ^TMP("PSJ1",$J) D EN^PSJBCMA1(DFN,PSBXORDN,1)
  1.  ...S $P(RESULTS(PSBCNT),U,3)=$P(^TMP("PSJ1",$J,2),U,2)  ;OItem_" "_Dosage Form
  1.  ...S $P(RESULTS(PSBCNT),U,6)=$P(^TMP("PSJ1",$J,4),U)    ;Sched Type
  1.  ...K ^TMP("PSJ1",$J)
  1.  ..S $P(RESULTS(PSBCNT),U,7)=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I")
  1.  ..S $P(RESULTS(PSBCNT),U,8)=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
  1.  ..S:$D(^PSB(53.79,PSBIEN,.2)) $P(RESULTS(PSBCNT),U,9)=$P(^PSB(53.79,PSBIEN,.2),U),$P(RESULTS(PSBCNT),U,10)=$P(^PSB(53.79,PSBIEN,.2),U,2)
  1.  S:+$G(RESULTS(1))>0 $P(RESULTS(0),U)=PSBCNT
  1.  Q
  1.  ;
  1. CHKKEY(PSBIENX) ;
  1.  I '(($D(^XUSEC("PSB MANAGER",DUZ)))!($$GET1^DIQ(53.79,+PSBIENX,.07,"I")=DUZ)) Q 0
  1.  Q 1
  1.  ;
  1. PTLKUP(RESULTS,PSBREC) ; Patient lookup handled separately for security
  1.  ;   input - PSBREC (array)  User entered patient lookup data
  1.  ;
  1.  ;   outpt - RESULTS (array)
  1.  ;          (Person(s) in PATIENT File (#2) meeting search criteria)
  1.  ;
  1.  ;
  1.  K RESULTS
  1.  N PSBNRSWD
  1.  S PSBDATA=$E(PSBREC(1),1,60)
  1.  I PSBDATA?12N!(PSBDATA?1.6N)&(DUZ("AG")="I") D  Q  ; HRN/ASUFAC code
  1.  .N X
  1.  .S X=$$HRCNF^APSPFUNC($S($L(PSBDATA)=12:PSBDATA,1:$$PAD($$GET1^DIQ(9999999.06,+DUZ(2),.12))_$$PAD(PSBDATA)))
  1.  .I X<0 D  Q
  1.  ..S RESULTS(0)=1,RESULTS(1)="-1^No patients matching '"_PSBDATA_"'."
  1.  .S RESULTS(0)=1
  1.  .S RESULTS(1)=$$PTREC(X)
  1.  S PSBDATA1=PSBDATA
  1.  N PSBINDX S PSBINDX="" K ^TMP("DILIST",$J)
  1.  I $E(PSBDATA,$L(PSBDATA)-10,60)=" [MAS WARD]" S PSBINDX="CN" S PSBDATA=$P(PSBDATA," [MAS WARD]")
  1.  I $E(PSBDATA,$L(PSBDATA)-11,60)=" [NURS UNIT]" S PSBINDX="CN" S PSBDATA=$P(PSBDATA," [NURS UNIT]") D
  1.  .K PSBPT S PSBPT(0)=0
  1.  .S PSBZ=0 F  S PSBZ=$O(^NURSF(211.4,PSBZ)) Q:PSBZ'?.N  S PSBNRSWD=$$GET1^DIQ(211.4,PSBZ_",",.01) I $$UCASE^XUSG(PSBNRSWD)=PSBDATA S PSBY=PSBZ Q
  1.  .K PSBDATA S PSBDATA=""
  1.  .S PSBX=0 F  S PSBX=$O(^NURSF(211.4,PSBY,3,PSBX)) Q:PSBX=""  S PSBDATA(PSBX)=$$GET1^DIQ(42,$P(^NURSF(211.4,PSBY,3,PSBX,0),U)_",",.01)
  1.  I PSBINDX="" S PSBINDX=$S(PSBDATA?9N.1P:"SSN",PSBDATA?4N.1P:"BS5^BS",1:PSBINDX)
  1.  I ($O(PSBDATA(""))'>0) D FIND^DIC(2,"","@;.01;.02;.03;.09","MP",PSBDATA,200,PSBINDX)
  1.  I ($O(PSBDATA(""))>0) D
  1.  .S PSBX="",PSBY=1 F  S PSBX=$O(PSBDATA(PSBX)) Q:PSBX=""  D  K ^TMP("DILIST",$J) Q:$P(PSBPT(0),U,3)=1
  1.  ..D FIND^DIC(2,"","@;.01;.02;.03;.09","MPO",PSBDATA(PSBX),200,PSBINDX)
  1.  ..S PSBZ=0 F  S PSBZ=$O(^TMP("DILIST",$J,PSBZ)) Q:PSBZ=""  S PSBPT(PSBY,0)=^TMP("DILIST",$J,PSBZ,0),PSBPT(0)=PSBY,PSBY=PSBY+1 I PSBY>200 S $P(PSBPT(0),U,3)=1
  1.  K:+$G(PSBPT(0))=0 PSBPT
  1.  I $D(PSBPT) M ^TMP("DILIST",$J)=PSBPT
  1.  I $P($G(^TMP("DILIST",$J,0)),U,3) D  Q
  1.  .S RESULTS(0)=1,RESULTS(1)="-1^Too many patients found matching '"_PSBDATA1_"'. Please be more specific."
  1.  I $D(^TMP("DILIST",$J,0)) D
  1.  .F PSBXX=0:0 S PSBXX=$O(^TMP("DILIST",$J,PSBXX)) Q:'PSBXX  D
  1.  ..S RESULTS(PSBXX)=$$PTREC(+^TMP("DILIST",$J,PSBXX,0))
  1.  I '$D(RESULTS) S RESULTS(0)=1,RESULTS(1)="-1^No patients matching '"_PSBDATA1_"'"
  1.  E  S RESULTS(0)=+$O(RESULTS(""),-1)
  1.  Q
  1.  ;
  1. PTREC(DFN) ;
  1.  ; Extrinsic to return a Pt Rec  in standard list format
  1.  N PSBXX
  1.  S PSBXX=$G(^DPT(DFN,0))
  1.  S PSBXX=DFN_U_$P(PSBXX,U,1)_U_$P(PSBXX,U,2)_U_$P(PSBXX,U,3)_U_$S(DUZ("AG")="I":$$HRCNF^BDGF2(DFN,DUZ(2)),1:$P(PSBXX,U,9))
  1.  S $P(PSBXX,U,6)=$$GET1^DIQ(2,DFN_",",.1)
  1.  S $P(PSBXX,U,7)=$$GET1^DIQ(2,DFN_",",.101)
  1.  S $P(PSBXX,U,10)=$$DOB^DPTLK1(DFN)
  1.  S $P(PSBXX,U,11)=$S(DUZ("AG")="I":$$HRN^AUPNPAT(DFN,DUZ(2)),1:$$SSN^DPTLK1(DFN))
  1.  Q PSBXX
  1.  ;
  1. SELECTAD(RESULTS,PSBREC) ; Select Administration
  1.  ;
  1.  ;  Process the SELECTed ADministration
  1.  ;   input - PSBREC(1) = PSB Med Log File (#53.79) IEN
  1.  ;
  1.  ;
  1.  ;   outpt - RESULTS (array)
  1.  ;          (Administration data that can be subsequently updated via GUI MED LOG EDIT)
  1.  ;
  1.  ;
  1.  K RESULTS,PSBXIV,PSBPTCHX
  1.  N PSBIEN,PSBCNT,PSBX S PSBIEN=PSBREC(1),PSBCNT=2
  1.  ; Construct form data    Patient^SSN^Med^BagID^AdminStat^AdminD/T^InjctSt^PRNReas^PRNEff^DisDrg^UntsGiven^Unt^
  1.  S RESULTS(0)=0
  1.  D:$$CHKKEY(PSBIEN)
  1.  .L +^PSB(53.79,PSBIEN):1
  1.  .E  I $P(^PSB(53.79,PSBIEN,0),U,9)]"" S PSBCNT=1,RESULTS(1)="-1^ This administration is being modified by another process at this moment." L -^PSB(53.79,PSBIEN) Q
  1.  .S $P(RESULTS(1),U)=PSBIEN
  1.  .S $P(RESULTS(1),U,2)=$$GET1^DIQ(53.79,PSBIEN_",",.01,"I")
  1.  .S $P(RESULTS(1),U,3)=$$GET1^DIQ(53.79,PSBIEN_",",.01)
  1.  .S $P(RESULTS(1),U,4)=$$GET1^DIQ(2,$P(RESULTS(1),U,2)_",",.09)
  1.  .S $P(RESULTS(1),U,5)=$$GET1^DIQ(53.79,PSBIEN_",",.08,"I")_"~"_$$GET1^DIQ(53.79,PSBIEN_",",.08)
  1.  .S $P(RESULTS(1),U,6)=$$GET1^DIQ(53.79,PSBIEN_",",.26)
  1.  .S $P(RESULTS(1),U,7)=$S($$GET1^DIQ(53.79,PSBIEN_",",.09,"I")']"":"U",1:$$GET1^DIQ(53.79,PSBIEN_",",.09,"I"))
  1.  .;
  1.  .D:($P(RESULTS(1),U,7)'="N")&($P(RESULTS(1),U,7)]"") SELSTTUS(.RESULTS)  ; Amend RESULTS(1) data...
  1.  .S Y=$E($$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),1,12) D DD^%DT
  1.  .S $P(RESULTS(1),U,8)=Y
  1.  .S $P(RESULTS(1),U,9)=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I")
  1.  .S $P(RESULTS(1),U,10)=$$GET1^DIQ(53.79,PSBIEN_",",.16)
  1.  .S $P(RESULTS(1),U,16)=0
  1.  .S $P(RESULTS(2),U)=$$GET1^DIQ(53.79,PSBIEN_",",.21),$P(RESULTS(2),U,2)=$$GET1^DIQ(53.79,PSBIEN_",",.22)
  1.  .; Determine if there are any active IVs/Patchs per order
  1.  .D:$G(PSBPTCHX)
  1.  ..S PSBX="",PSBX="^PSB(53.79,""APATCH"","_$P(RESULTS(1),U,2)_")"
  1.  ..F  S PSBX=$Q(@PSBX) Q:PSBX=""  Q:$QS(PSBX,3)'=$P(RESULTS(1),U,2)  D  Q:$P(RESULTS(1),U,16)
  1.  ...S PSBXX=$QS(PSBX,5),PSBXXX=$S(($P(^PSB(53.79,PSBXX,0),U,9)="G")&(PSBXX'=PSBIEN):1,1:0)
  1.  ...I PSBXXX&($P(^PSB(53.79,PSBXX,.1),U)=$P(RESULTS(1),U,15)) S $P(RESULTS(1),U,16)=1
  1.  .D:$G(PSBXIV)
  1.  ..S PSBX="",PSBX="^PSB(53.79,""AUID"","_$P(RESULTS(1),U,2)_")"
  1.  ..F  S PSBX=$Q(@PSBX) Q:PSBX=""  Q:$QS(PSBX,3)'=$P(RESULTS(1),U,2)  Q:$QS(PSBX,4)>$P(RESULTS(1),U,15)  D  Q:$P(RESULTS(1),U,16)
  1.  ...Q:$QS(PSBX,4)'=$P(RESULTS(1),U,15)
  1.  ...S PSBXX=$QS(PSBX,6) S:(PSBXX'=PSBIEN) $P(RESULTS(1),U,16)=$S($P(^PSB(53.79,PSBXX,0),U,9)="I":1,$P(^PSB(53.79,PSBXX,0),U,9)="S":1,1:0)
  1.  .;
  1.  .; LOOP - Place DD in RESULTS
  1.  .S PSBX=0 F  S PSBX=$O(^PSB(53.79,PSBIEN,.5,PSBX)) Q:'(+PSBX)  D
  1.  ..S PSBCNT=PSBCNT+1
  1.  ..S RESULTS(PSBCNT)="DD^"_$P(^PSB(53.79,PSBIEN,.5,PSBX,0),U)_"^"_$$GET1^DIQ(50,$P(^PSB(53.79,PSBIEN,.5,PSBX,0),U)_",",.01)
  1.  ..S $P(RESULTS(PSBCNT),U,4)=$P(^PSB(53.79,PSBIEN,.5,PSBX,0),U,2)_"^"_$P(^PSB(53.79,PSBIEN,.5,PSBX,0),U,3)_"^"_$P(^PSB(53.79,PSBIEN,.5,PSBX,0),U,4)
  1.  ..S:$P(RESULTS(PSBCNT),U,4)?1"."1.N $P(RESULTS(PSBCNT),U,4)=0_+$P(RESULTS(PSBCNT),U,4)
  1.  ..S:$P(RESULTS(PSBCNT),U,5)?1"."1.N $P(RESULTS(PSBCNT),U,5)=0_+$P(RESULTS(PSBCNT),U,5)
  1.  .; LOOP - Place ADD in RESULTS
  1.  .S PSBX=0 F  S PSBX=$O(^PSB(53.79,PSBIEN,.6,PSBX)) Q:'(+PSBX)  D
  1.  ..S PSBCNT=PSBCNT+1
  1.  ..S RESULTS(PSBCNT)="ADD^"_$P(^PSB(53.79,PSBIEN,.6,PSBX,0),U)_"^"_$$GET1^DIQ(52.6,$P(^PSB(53.79,PSBIEN,.6,PSBX,0),U)_",",.01)
  1.  ..S $P(RESULTS(PSBCNT),U,4)=$P(^PSB(53.79,PSBIEN,.6,PSBX,0),U,2)_"^"_$P(^PSB(53.79,PSBIEN,.6,PSBX,0),U,3)_"^"_$P(^PSB(53.79,PSBIEN,.6,PSBX,0),U,4)
  1.  .; LOOP - Place SOL in RESULTS
  1.  .S PSBX=0 F  S PSBX=$O(^PSB(53.79,PSBIEN,.7,PSBX)) Q:'(+PSBX)  D
  1.  ..S PSBCNT=PSBCNT+1
  1.  ..S RESULTS(PSBCNT)="SOL^"_$P(^PSB(53.79,PSBIEN,.7,PSBX,0),U)_"^"_$$GET1^DIQ(52.7,$P(^PSB(53.79,PSBIEN,.7,PSBX,0),U)_",",.01)
  1.  ..S $P(RESULTS(PSBCNT),U,4)=$P(^PSB(53.79,PSBIEN,.7,PSBX,0),U,2)_"^"_$P(^PSB(53.79,PSBIEN,.7,PSBX,0),U,3)_"^"_$P(^PSB(53.79,PSBIEN,.7,PSBX,0),U,4)
  1.  .L -^PSB(53.79,PSBIEN)
  1.  S:PSBCNT>0 RESULTS(0)=PSBCNT
  1.  Q
  1.  ;
  1. SELSTTUS(RESULTS) ;
  1.  ; Provide the SELectable STaTUS
  1.  ;
  1.  ; Get TAB, ScheduleType, Current Status, provide Selectable Staus(s) in ^8
  1.  N PSBORTYP,PSBIVTYP,PSBINTSY,PSBCHMTY,PSBIVPSH,PSBXTAB
  1.  K ^TMP("PSJ1",$J) D EN^PSJBCMA1($$GET1^DIQ(53.79,PSBIEN_",",.01,"I"),$$GET1^DIQ(53.79,PSBIEN_",",.11),1)
  1.  I ^TMP("PSJ1",$J,0)>0 D
  1.  .S PSBORTYP=$TR($P(^TMP("PSJ1",$J,0),U,3),"1234567890"),PSBIVTYP=$P(^TMP("PSJ1",$J,0),U,6)
  1.  .S PSBINTSY=$P(^TMP("PSJ1",$J,0),U,7),PSBCHMTY=$P(^TMP("PSJ1",$J,0),U,8),PSBIVPSH=+$P($G(^TMP("PSJ1",$J,1,0)),U,2)
  1.  .S:$$IVPTAB^PSBVDLU3(PSBORTYP,PSBIVTYP,PSBINTSY,PSBCHMTY,PSBIVPSH) PSBXTAB="PB"
  1.  .D:'$D(PSBXTAB)
  1.  ..I PSBORTYP="U" S PSBXTAB="UD"
  1.  ..I PSBORTYP="V" S PSBXTAB="IV"
  1.  ; Set Results(1) and other flags...
  1.  I ^TMP("PSJ1",$J,0)>0 D
  1.  .S $P(RESULTS(1),U,13)=$P(^TMP("PSJ1",$J,4),U)
  1.  .S $P(RESULTS(1),U,14)=$P(^TMP("PSJ1",$J,1),U,10)
  1.  .S $P(RESULTS(1),U,15)=$P(^TMP("PSJ1",$J,0),U,3)
  1.  .I (PSBXTAB="UD"),($P(^TMP("PSJ1",$J,2),U,6)="PATCH") S PSBPTCHX=1
  1.  .I PSBXTAB="IV" S PSBXIV=1
  1.  .S:$G(PSBXTAB)]"" $P(RESULTS(1),U,11)=$G(PSBXTAB)
  1.  K ^TMP("PSJ1",$J)
  1.  Q
  1.  ;
  1. KILLAADT ;
  1.  ;   Here because there is an errorant index entry via version 1.0/2.0
  1.  ;   Cleansing!
  1.  ;
  1.  K ^PSB(53.79,"AADT",DFN,PSBSRCH,PSBIEN)
  1.  Q
  1.  ;
  1. PAD(VAL) ; Return VAL with leading zeroes padded to 6 characters
  1.  Q $E("000000",1,6-$L(VAL))_VAL