PSBMLLKU ;BIRMINGHAM/TEJ - BCMA RPC LOOKUP UTLILITIES ;03/06/16 3:06pm
;;3.0;BAR CODE MED ADMIN;**3,9,11,20,13,38,32,56,42,70,72,83,99**;Mar 2004;Build 9
;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
; $$UP^XLFSTR/10104
;
;*70 - create a lookup for Clinics that returns all patients per
; clinic selected for Client to then pass one at a time for
; coversheet reports and enable the NEXT button for user
; selection to process the next DFN for a coversheet report.
;*83 - return Injection/Dermal site encoded in piece 10. |I or |D
; also set 16th piece if MRRs given on order.
; return HR & MRR flags pieces 7 & 8 on DD string.
;
RPC(RESULTS,PSBREC) ; Remote Procedure Call Entry Point.
;
;*70 piece out mode if exists & reset 0 node for bkwds compatability
N PSBCLINORD
S PSBCLINORD=$P(PSBREC(0),U,2),PSBREC(0)=$P(PSBREC(0),U)
;
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)=$$GETINIT^PSBCSUTX(PSBIEN,"I") ;Get initials of who took action, PSB*3*72
..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)
;
;
N PSBNRSWD,PSBINDX,PSBRPT
K RESULTS,PSBDATA
K PSBPT S PSBPT(0)=0
S PSBINDX="" K ^TMP("DILIST",$J)
I PSBCLINORD'="C" D
.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
.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 $$UP^XLFSTR(PSBNRSWD)=PSBDATA S PSBY=PSBZ Q ;Update API, PSB*3*72
..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 PSBCLINORD="C" D
.;Clinic mode report - get and return array of all DFN's that belong
.; to clinics passed in by user.
.F QQ=0:0 S QQ=$O(PSBREC(QQ)) Q:'QQ D
..S PSBRPT(2,QQ,0)=PSBREC(QQ)
..S PSBRPT(2,"B",PSBREC(QQ),QQ)=""
.S PSBDATA=1 D CLIN^PSBO(.PSBRPT,.PSBDATA)
.I $D(PSBDATA)=11 D
..N DFNXX S PSBCNT=0
..F DFNXX=0:0 S DFNXX=$O(PSBDATA(DFNXX)) Q:'DFNXX D
...S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$$PTREC(DFNXX)
.; check if any data found
.I '$D(RESULTS) D
..S RESULTS(0)=1
..S RESULTS(1)="-1^No patients matching Clinic Search List"
.E D
..S RESULTS(0)=+$O(RESULTS(""),-1)
..S PSBINDX="CN"
I PSBCLINORD="C",+RESULTS(1)=-1 Q
;
I PSBINDX="" S PSBINDX=$S(PSBDATA?9N.1P:"SSN",PSBDATA?4N.1P:"BS5^BS",1:"B^BS5^SSN^CN^RM")
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 ISIT,DSIT,PSBMRRX ;*83
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")
.;Inj vs Derm site *83
.S ISIT=$$GET1^DIQ(53.79,PSBIEN_",",.16)
.S DSIT=$$GET1^DIQ(53.79,PSBIEN_",",.18)
.S $P(RESULTS(1),U,10)=$S(ISIT]"":ISIT_"|I",DSIT]"":DSIT_"|D",1:"")
.;
.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 MRRs/IVs/Patches per order
.; MRRs - check MRRs first *83
.D:$G(PSBMRRX)
..S PSBX="",PSBX="^PSB(53.79,""AMRR"","_$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
.;
.; Patches - check if flag not already set
.D:$G(PSBPTCHX)&('($P(RESULTS(1),U,16))) ;*83
..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
.;
.; IV's - check if flag not already set
.D:$G(PSBXIV)&('($P(RESULTS(1),U,16))) ;*83
..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)
..; send HR & MRR flags in DD pce 7 & 8 to insure returned
..; for Edit Transaction calls
..S $P(RESULTS(PSBCNT),U,7)=$P(^PSB(53.79,PSBIEN,.5,PSBX,0),U,5) ;*83
..S $P(RESULTS(PSBCNT),U,8)=$P(^PSB(53.79,PSBIEN,.5,PSBX,0),U,6) ;*83
.; 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,CNT
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
.F CNT=0:0 S CNT=$O(^TMP("PSJ1",$J,700,CNT)) Q:'CNT D
..S PSBMRRX=$P(^TMP("PSJ1",$J,700,CNT,0),U,7) ;*83
.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 errant 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBMLLKU 13230 printed Sep 23, 2025@19:16:12 Page 2
PSBMLLKU ;BIRMINGHAM/TEJ - BCMA RPC LOOKUP UTLILITIES ;03/06/16 3:06pm
+1 ;;3.0;BAR CODE MED ADMIN;**3,9,11,20,13,38,32,56,42,70,72,83,99**;Mar 2004;Build 9
+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 ; $$UP^XLFSTR/10104
+15 ;
+16 ;*70 - create a lookup for Clinics that returns all patients per
+17 ; clinic selected for Client to then pass one at a time for
+18 ; coversheet reports and enable the NEXT button for user
+19 ; selection to process the next DFN for a coversheet report.
+20 ;*83 - return Injection/Dermal site encoded in piece 10. |I or |D
+21 ; also set 16th piece if MRRs given on order.
+22 ; return HR & MRR flags pieces 7 & 8 on DD string.
+23 ;
RPC(RESULTS,PSBREC) ; Remote Procedure Call Entry Point.
+1 ;
+2 ;*70 piece out mode if exists & reset 0 node for bkwds compatability
+3 NEW PSBCLINORD
+4 SET PSBCLINORD=$PIECE(PSBREC(0),U,2)
SET PSBREC(0)=$PIECE(PSBREC(0),U)
+5 ;
+6 SET RESULTS=""
DO @(PSBREC(0)_"(.RESULTS,.PSBREC)")
QUIT
+7 QUIT
+8 ;
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 ;Get initials of who took action, PSB*3*72
SET $PIECE(RESULTS(PSBCNT),U,8)=$$GETINIT^PSBCSUTX(PSBIEN,"I")
+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 NEW PSBNRSWD,PSBINDX,PSBRPT
+8 KILL RESULTS,PSBDATA
+9 KILL PSBPT
SET PSBPT(0)=0
+10 SET PSBINDX=""
KILL ^TMP("DILIST",$JOB)
+11 IF PSBCLINORD'="C"
Begin DoDot:1
+12 SET PSBDATA=$EXTRACT(PSBREC(1),1,60)
+13 ; HRN/ASUFAC code
IF PSBDATA?12N!(PSBDATA?1.6N)&(DUZ("AG")="I")
Begin DoDot:2
+14 NEW X
+15 SET X=$$HRCNF^APSPFUNC($SELECT($LENGTH(PSBDATA)=12:PSBDATA,1:$$PAD($$GET1^DIQ(9999999.06,+DUZ(2),.12))_$$PAD(PSBDATA)))
+16 IF X<0
Begin DoDot:3
+17 SET RESULTS(0)=1
SET RESULTS(1)="-1^No patients matching '"_PSBDATA_"'."
End DoDot:3
QUIT
+18 SET RESULTS(0)=1
+19 SET RESULTS(1)=$$PTREC(X)
End DoDot:2
QUIT
+20 SET PSBDATA1=PSBDATA
+21 IF $EXTRACT(PSBDATA,$LENGTH(PSBDATA)-10,60)=" [MAS WARD]"
SET PSBINDX="CN"
SET PSBDATA=$PIECE(PSBDATA," [MAS WARD]")
+22 IF $EXTRACT(PSBDATA,$LENGTH(PSBDATA)-11,60)=" [NURS UNIT]"
SET PSBINDX="CN"
SET PSBDATA=$PIECE(PSBDATA," [NURS UNIT]")
Begin DoDot:2
+23 KILL PSBPT
SET PSBPT(0)=0
+24 ;Update API, PSB*3*72
SET PSBZ=0
FOR
SET PSBZ=$ORDER(^NURSF(211.4,PSBZ))
if PSBZ'?.N
QUIT
SET PSBNRSWD=$$GET1^DIQ(211.4,PSBZ_",",.01)
IF $$UP^XLFSTR(PSBNRSWD)=PSBDATA
SET PSBY=PSBZ
QUIT
+25 KILL PSBDATA
SET PSBDATA=""
+26 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:2
End DoDot:1
+27 ;
+28 IF PSBCLINORD="C"
Begin DoDot:1
+29 ;Clinic mode report - get and return array of all DFN's that belong
+30 ; to clinics passed in by user.
+31 FOR QQ=0:0
SET QQ=$ORDER(PSBREC(QQ))
if 'QQ
QUIT
Begin DoDot:2
+32 SET PSBRPT(2,QQ,0)=PSBREC(QQ)
+33 SET PSBRPT(2,"B",PSBREC(QQ),QQ)=""
End DoDot:2
+34 SET PSBDATA=1
DO CLIN^PSBO(.PSBRPT,.PSBDATA)
+35 IF $DATA(PSBDATA)=11
Begin DoDot:2
+36 NEW DFNXX
SET PSBCNT=0
+37 FOR DFNXX=0:0
SET DFNXX=$ORDER(PSBDATA(DFNXX))
if 'DFNXX
QUIT
Begin DoDot:3
+38 SET PSBCNT=PSBCNT+1
SET RESULTS(PSBCNT)=$$PTREC(DFNXX)
End DoDot:3
End DoDot:2
+39 ; check if any data found
+40 IF '$DATA(RESULTS)
Begin DoDot:2
+41 SET RESULTS(0)=1
+42 SET RESULTS(1)="-1^No patients matching Clinic Search List"
End DoDot:2
+43 IF '$TEST
Begin DoDot:2
+44 SET RESULTS(0)=+$ORDER(RESULTS(""),-1)
+45 SET PSBINDX="CN"
End DoDot:2
End DoDot:1
+46 IF PSBCLINORD="C"
IF +RESULTS(1)=-1
QUIT
+47 ;
+48 IF PSBINDX=""
SET PSBINDX=$SELECT(PSBDATA?9N.1P:"SSN",PSBDATA?4N.1P:"BS5^BS",1:"B^BS5^SSN^CN^RM")
+49 IF ($ORDER(PSBDATA(""))'>0)
DO FIND^DIC(2,"","@;.01;.02;.03;.09","MP",PSBDATA,200,PSBINDX)
+50 IF ($ORDER(PSBDATA(""))>0)
Begin DoDot:1
+51 SET PSBX=""
SET PSBY=1
FOR
SET PSBX=$ORDER(PSBDATA(PSBX))
if PSBX=""
QUIT
Begin DoDot:2
+52 DO FIND^DIC(2,"","@;.01;.02;.03;.09","MPO",PSBDATA(PSBX),200,PSBINDX)
+53 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
+54 if +$GET(PSBPT(0))=0
KILL PSBPT
+55 IF $DATA(PSBPT)
MERGE ^TMP("DILIST",$JOB)=PSBPT
+56 IF $PIECE($GET(^TMP("DILIST",$JOB,0)),U,3)
Begin DoDot:1
+57 SET RESULTS(0)=1
SET RESULTS(1)="-1^Too many patients found matching '"_PSBDATA1_"'. Please be more specific."
End DoDot:1
QUIT
+58 IF $DATA(^TMP("DILIST",$JOB,0))
Begin DoDot:1
+59 FOR PSBXX=0:0
SET PSBXX=$ORDER(^TMP("DILIST",$JOB,PSBXX))
if 'PSBXX
QUIT
Begin DoDot:2
+60 SET RESULTS(PSBXX)=$$PTREC(+^TMP("DILIST",$JOB,PSBXX,0))
End DoDot:2
End DoDot:1
+61 IF '$DATA(RESULTS)
SET RESULTS(0)=1
SET RESULTS(1)="-1^No patients matching '"_PSBDATA1_"'"
+62 IF '$TEST
SET RESULTS(0)=+$ORDER(RESULTS(""),-1)
+63 QUIT
+64 ;
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 ;*83
NEW ISIT,DSIT,PSBMRRX
+12 NEW PSBIEN,PSBCNT,PSBX
SET PSBIEN=PSBREC(1)
SET PSBCNT=2
+13 ; Construct form data Patient^SSN^Med^BagID^AdminStat^AdminD/T^InjctSt^PRNReas^PRNEff^DisDrg^UntsGiven^Unt^
+14 SET RESULTS(0)=0
+15 if $$CHKKEY(PSBIEN)
Begin DoDot:1
+16 LOCK +^PSB(53.79,PSBIEN):1
+17 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
+18 SET $PIECE(RESULTS(1),U)=PSBIEN
+19 SET $PIECE(RESULTS(1),U,2)=$$GET1^DIQ(53.79,PSBIEN_",",.01,"I")
+20 SET $PIECE(RESULTS(1),U,3)=$$GET1^DIQ(53.79,PSBIEN_",",.01)
+21 SET $PIECE(RESULTS(1),U,4)=$$GET1^DIQ(2,$PIECE(RESULTS(1),U,2)_",",.09)
+22 SET $PIECE(RESULTS(1),U,5)=$$GET1^DIQ(53.79,PSBIEN_",",.08,"I")_"~"_$$GET1^DIQ(53.79,PSBIEN_",",.08)
+23 SET $PIECE(RESULTS(1),U,6)=$$GET1^DIQ(53.79,PSBIEN_",",.26)
+24 SET $PIECE(RESULTS(1),U,7)=$SELECT($$GET1^DIQ(53.79,PSBIEN_",",.09,"I")']"":"U",1:$$GET1^DIQ(53.79,PSBIEN_",",.09,"I"))
+25 ;
+26 ; Amend RESULTS(1) data...
if ($PIECE(RESULTS(1),U,7)'="N")&($PIECE(RESULTS(1),U,7)]"")
DO SELSTTUS(.RESULTS)
+27 SET Y=$EXTRACT($$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),1,12)
DO DD^%DT
+28 SET $PIECE(RESULTS(1),U,8)=Y
+29 SET $PIECE(RESULTS(1),U,9)=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I")
+30 ;Inj vs Derm site *83
+31 SET ISIT=$$GET1^DIQ(53.79,PSBIEN_",",.16)
+32 SET DSIT=$$GET1^DIQ(53.79,PSBIEN_",",.18)
+33 SET $PIECE(RESULTS(1),U,10)=$SELECT(ISIT]"":ISIT_"|I",DSIT]"":DSIT_"|D",1:"")
+34 ;
+35 SET $PIECE(RESULTS(1),U,16)=0
+36 SET $PIECE(RESULTS(2),U)=$$GET1^DIQ(53.79,PSBIEN_",",.21)
SET $PIECE(RESULTS(2),U,2)=$$GET1^DIQ(53.79,PSBIEN_",",.22)
+37 ;
+38 ;Determine if there are any active MRRs/IVs/Patches per order
+39 ; MRRs - check MRRs first *83
+40 if $GET(PSBMRRX)
Begin DoDot:2
+41 SET PSBX=""
SET PSBX="^PSB(53.79,""AMRR"","_$PIECE(RESULTS(1),U,2)_")"
+42 FOR
SET PSBX=$QUERY(@PSBX)
if PSBX=""
QUIT
if $QSUBSCRIPT(PSBX,3)'=$PIECE(RESULTS(1),U,2)
QUIT
Begin DoDot:3
+43 SET PSBXX=$QSUBSCRIPT(PSBX,5)
SET PSBXXX=$SELECT(($PIECE(^PSB(53.79,PSBXX,0),U,9)="G")&(PSBXX'=PSBIEN):1,1:0)
+44 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
+45 ;
+46 ; Patches - check if flag not already set
+47 ;*83
if $GET(PSBPTCHX)&('($PIECE(RESULTS(1),U,16)))
Begin DoDot:2
+48 SET PSBX=""
SET PSBX="^PSB(53.79,""APATCH"","_$PIECE(RESULTS(1),U,2)_")"
+49 FOR
SET PSBX=$QUERY(@PSBX)
if PSBX=""
QUIT
if $QSUBSCRIPT(PSBX,3)'=$PIECE(RESULTS(1),U,2)
QUIT
Begin DoDot:3
+50 SET PSBXX=$QSUBSCRIPT(PSBX,5)
SET PSBXXX=$SELECT(($PIECE(^PSB(53.79,PSBXX,0),U,9)="G")&(PSBXX'=PSBIEN):1,1:0)
+51 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
+52 ;
+53 ; IV's - check if flag not already set
+54 ;*83
if $GET(PSBXIV)&('($PIECE(RESULTS(1),U,16)))
Begin DoDot:2
+55 SET PSBX=""
SET PSBX="^PSB(53.79,""AUID"","_$PIECE(RESULTS(1),U,2)_")"
+56 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
+57 if $QSUBSCRIPT(PSBX,4)'=$PIECE(RESULTS(1),U,15)
QUIT
+58 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
+59 ;
+60 ; LOOP - Place DD in RESULTS
+61 SET PSBX=0
FOR
SET PSBX=$ORDER(^PSB(53.79,PSBIEN,.5,PSBX))
if '(+PSBX)
QUIT
Begin DoDot:2
+62 SET PSBCNT=PSBCNT+1
+63 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)
+64 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)
+65 if $PIECE(RESULTS(PSBCNT),U,4)?1"."1.N
SET $PIECE(RESULTS(PSBCNT),U,4)=0_+$PIECE(RESULTS(PSBCNT),U,4)
+66 if $PIECE(RESULTS(PSBCNT),U,5)?1"."1.N
SET $PIECE(RESULTS(PSBCNT),U,5)=0_+$PIECE(RESULTS(PSBCNT),U,5)
+67 ; send HR & MRR flags in DD pce 7 & 8 to insure returned
+68 ; for Edit Transaction calls
+69 ;*83
SET $PIECE(RESULTS(PSBCNT),U,7)=$PIECE(^PSB(53.79,PSBIEN,.5,PSBX,0),U,5)
+70 ;*83
SET $PIECE(RESULTS(PSBCNT),U,8)=$PIECE(^PSB(53.79,PSBIEN,.5,PSBX,0),U,6)
End DoDot:2
+71 ; LOOP - Place ADD in RESULTS
+72 SET PSBX=0
FOR
SET PSBX=$ORDER(^PSB(53.79,PSBIEN,.6,PSBX))
if '(+PSBX)
QUIT
Begin DoDot:2
+73 SET PSBCNT=PSBCNT+1
+74 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)
+75 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
+76 ; LOOP - Place SOL in RESULTS
+77 SET PSBX=0
FOR
SET PSBX=$ORDER(^PSB(53.79,PSBIEN,.7,PSBX))
if '(+PSBX)
QUIT
Begin DoDot:2
+78 SET PSBCNT=PSBCNT+1
+79 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)
+80 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
+81 LOCK -^PSB(53.79,PSBIEN)
End DoDot:1
+82 if PSBCNT>0
SET RESULTS(0)=PSBCNT
+83 QUIT
+84 ;
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,CNT
+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 FOR CNT=0:0
SET CNT=$ORDER(^TMP("PSJ1",$JOB,700,CNT))
if 'CNT
QUIT
Begin DoDot:2
+20 ;*83
SET PSBMRRX=$PIECE(^TMP("PSJ1",$JOB,700,CNT,0),U,7)
End DoDot:2
+21 IF PSBXTAB="IV"
SET PSBXIV=1
+22 if $GET(PSBXTAB)]""
SET $PIECE(RESULTS(1),U,11)=$GET(PSBXTAB)
End DoDot:1
+23 KILL ^TMP("PSJ1",$JOB)
+24 QUIT
+25 ;
KILLAADT ;
+1 ; Here because there is an errant 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
