PSBMLLKU.m

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 ---PSBMLLKU   13230     printed  Mar 13, 2025@20:44:52                                                                                                                                                                                                   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