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