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

PSBRPC2.m

Go to the documentation of this file.
  1. PSBRPC2 ;BIRMINGHAM/EFC-BCMA RPC BROKER CALLS ;28-Mar-2014 10:59;DU
  1. ;;3.0;BAR CODE MED ADMIN;**6,3,16,32,1017**;Mar 2004;Build 40
  1. ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
  1. ;
  1. ; Reference/IA
  1. ; File 50/221
  1. ; File 52.6/436
  1. ; File 52.7/437
  1. ; File 200/10060
  1. ; Modified - IHS/MSC/MGH - 12/10/13 - SCANMED+23
  1. GETOHIST(RESULTS,DFN,PSBORD) ;
  1. S RESULTS=$NAME(^TMP("PSB",$J)),PSB=0 K ^TMP("PSB",$J)
  1. S ^TMP("PSB",$J,0)=1,^TMP("PSB",$J,1)="-1^No History On File"
  1. D NOW^%DTC S PSBNOW=$P(%,".",1),PSBNOWZ=%
  1. D EN^PSBPOIV(DFN,PSBORD)
  1. S PSBUID=DFN_"V"_99999 F S PSBUID=$O(^TMP("PSBAR",$J,PSBUID),-1) Q:PSBUID="" D
  1. .S PSBUIDS=^TMP("PSBAR",$J,PSBUID)
  1. .I ((PSBOSTS="D")!(PSBOSTS="E")),$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q ; only want the infusing bag on a dc'ed order
  1. .I (PSBOSTS="A"),(PSBOSP<PSBNOWZ),$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" S PSBOSTS="E" Q ; only want the infusing bag on an expired order
  1. .I $P(PSBUIDS,U,2)'="" D Q ; get orders from med log (53.79)
  1. ..S PSBMLOR=$P(PSBUIDS,U,4),PSBIEN=$O(^PSB(53.79,"AUID",DFN,PSBMLOR,PSBUID,""))
  1. ..S PSBLADT=$P(^PSB(53.79,PSBIEN,0),U,6)
  1. ..S PSBLASTS=$P(^PSB(53.79,PSBIEN,0),U,9)
  1. ..I PSBLASTS="M",$P(PSBUIDS,U,8)'="" Q
  1. ..S PSBINJS=$P(^PSB(53.79,PSBIEN,.1),U,6)
  1. ..S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBORD_U_PSBUID_U_PSBIEN_U_PSBLADT_U_PSBLASTS_U_PSBINJS
  1. ..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.6,PSBL,0)) S PSB=PSB+1,^TMP("PSB",$J,PSB)="ADD^"_^PSB(53.79,PSBIEN,.6,PSBL,0)
  1. ..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.7,PSBL,0)) S PSB=PSB+1,^TMP("PSB",$J,PSB)="SOL^"_^PSB(53.79,PSBIEN,.7,PSBL,0)
  1. ..S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
  1. .I $P(PSBUIDS,U,1)="I" Q ; IV parameters say bag is invalid
  1. .I $P(PSBUIDS,U,8)'="",$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q ; label has been reprinted/distroyed etc. - bag is not infusing or stopped
  1. .S PSB=PSB+1,^TMP("PSB",$J,PSB)=$P(PSBUIDS,U,5)_U_PSBUID_U_U_PSBNOW_U_"A"
  1. .S PSBUIDP=$P(PSBUIDS,U,10,999)
  1. .F Y=3:1 S PSBMEDTY=$P(PSBUIDP,U,Y) Q:PSBMEDTY="" D
  1. ..D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBUIDS,U,5))
  1. ..I $P(PSBMEDTY,";",1)="ADD" F Z=1:1 S PSBAD=$G(PSBADA(Z)) Q:PSBAD="" I $P(PSBADA(Z),U,2)=$P(PSBMEDTY,";",2) S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBADA(Z) Q
  1. ..I $P(PSBMEDTY,";",1)="SOL" F Z=1:1 S PSBSOL=$G(PSBSOLA(Z)) Q:PSBSOL="" I $P(PSBSOLA(Z),U,2)=$P(PSBMEDTY,";",2) S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBSOLA(Z) Q
  1. .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
  1. .S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
  1. F II=1:1 S I=$P(PSBONXS,U,II) Q:I="" D ; get ward stocks
  1. .S PSBUID="" F S PSBUID=$O(^PSB(53.79,"AUID",DFN,I,PSBUID)) Q:PSBUID="" D
  1. ..I PSBUID'["WS" Q ; not a ward stock
  1. ..S PSBIEN=$O(^PSB(53.79,"AUID",DFN,I,PSBUID,""))
  1. ..S PSBLADT=$P(^PSB(53.79,PSBIEN,0),U,6)
  1. ..S PSBLASTS=$P(^PSB(53.79,PSBIEN,0),U,9)
  1. ..I PSBOSTS="D",PSBLASTS'="I",PSBLASTS'="S" Q ; want "not completed" on DC'ed orders
  1. ..I (PSBOSTS="A"),(PSBOSP<PSBNOWZ),PSBLASTS'="I",PSBLASTS'="S" Q
  1. ..S PSBINJS=$P(^PSB(53.79,PSBIEN,.1),U,6)
  1. ..S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBORD_U_PSBUID_U_PSBIEN_U_PSBLADT_U_PSBLASTS_U_PSBINJS
  1. ..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.6,PSBL,0)) S PSB=PSB+1,^TMP("PSB",$J,PSB)="ADD^"_^PSB(53.79,PSBIEN,.6,PSBL,0)
  1. ..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.7,PSBL,0)) S PSB=PSB+1,^TMP("PSB",$J,PSB)="SOL^"_^PSB(53.79,PSBIEN,.7,PSBL,0)
  1. ..S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
  1. S ^TMP("PSB",$J,0)=PSB
  1. K ^TMP("PSBAR",$J)
  1. Q
  1. ;
  1. BAGDTL(RESULTS,PSBUID,PSBORD) ; bag detail
  1. I $G(DFN)="" S DFN=+PSBUID
  1. S (PSBIEN,X)="" F S X=$O(^PSB(53.79,"AUID",DFN,X)) Q:X="" S:$D(^PSB(53.79,"AUID",DFN,X,PSBUID)) PSBIEN=$O(^PSB(53.79,"AUID",DFN,X,PSBUID,"")) Q:PSBIEN]""
  1. I PSBIEN'>0 S RESULTS(0)=1,RESULTS(1)="-1^No History On File" Q
  1. M PSBMLA=^PSB(53.79,PSBIEN)
  1. S X=$P(^PSB(53.79,PSBIEN,0),U,9)
  1. S PSBLAC=$S(X="I":"INFUSING",X="G":"GIVEN",X="C":"COMPLETE",X="H":"HELD",X="R":"REFUSED",X="RM":"REMOVED",X="S":"STOPPED",X="M":"MISSING",1:"NO ACTION")
  1. ; comments
  1. S PSBX="0" F S PSBX=$O(PSBMLA(.3,PSBX)) Q:PSBX="" S PSBTMP(10000000-$P(PSBMLA(.3,PSBX,0),U,3),"C")=$P(PSBMLA(.3,PSBX,0),U,3)_U_$$INITIAL($P(PSBMLA(.3,PSBX,0),U,2))_U_U_$P(PSBMLA(.3,PSBX,0),U,1)
  1. ; audit
  1. S PSBGA="" I $D(PSBMLA(.9,0)) D
  1. .S PSBX="0" F S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX="" I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D Q
  1. ..S PSBDATE=$P(PSBMLA(0),U,4) I (PSBX-2)>0 D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
  1. ..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
  1. ..S PSBGA=1
  1. .S PSBX="0" F S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX="" I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D
  1. ..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2)
  1. ..S PSBGA=1
  1. I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL($P(PSBMLA(0),U,7))_U_PSBLAC
  1. S PSBQRY="PSBTMP",PSBCNT=1 F S PSBQRY=$Q(@PSBQRY) Q:PSBQRY="" D ; does comment go with action
  1. .S PSBPQRY=$Q(@PSBQRY,-1)
  1. .I PSBPQRY="" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; no previous action
  1. .I $QS(PSBPQRY,2)="C" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; previous line is a comment
  1. .I $QS(PSBQRY,2)="C",$E($P(@$Q(@PSBQRY,-1),U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@$Q(@PSBQRY,-1),U,2)=$P(@PSBQRY,U,2) S X=$P(@PSBQRY,U,4),$P(RESULTS(PSBCNT-1),U,4)=X Q
  1. .S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
  1. S RESULTS(0)=PSBCNT-1
  1. K PSBMLA,PSBIEN,PSBTMP,PSBQRY
  1. Q
  1. ;
  1. INITIAL(PSBDUZ) ;
  1. Q $$GET1^DIQ(200,PSBDUZ,"INITIAL")
  1. SCANMED(RESULTS,PSBDIEN,PSBTAB,DFN) ; Lookup Medication
  1. ;
  1. ; RPC: PSB SCANMED
  1. ;
  1. ; Description:
  1. ; Does a lookup on file 50 returns -1 on invalid lookup or
  1. ; IEN^DrugName on success
  1. ;
  1. N SAVDIEN
  1. D NOW^%DTC S PSBDT=%
  1. S PSBCNT=0
  1. S SAVDIEN=PSBDIEN
  1. I $L(PSBDIEN)>40 S PSBDIEN=$E(PSBDIEN,1,40)
  1. S RESULTS(PSBCNT)=1
  1. S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)="-1^Invalid Medication Lookup"
  1. I $$GET^XPAR("DIV","PSB ROBOT RX"),PSBDIEN?1"3"15N!(PSBDIEN?1"3"17N),123[$E(PSBDIEN,12) S PSBDIEN=$E(PSBDIEN,2,11)
  1. I PSBTAB="UDTAB" D Q
  1. .S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")
  1. .I X<1 Q
  1. .E S RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01)
  1. ;
  1. ; IV/IVPB ward stock scan
  1. ;
  1. ;IHS/MSC/MGH Added IV check for patch 1017
  1. S PSBDIEN=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C") I PSBDIEN<1 D Q
  1. .I $G(DUZ("AG"))="I" D IVCHK^PSBZVSD(.RESULTS,PSBCNT,SAVDIEN,PSBTAB,DFN)
  1. S PSBOIT=$$GET1^DIQ(50,PSBDIEN,"PHARMACY ORDERABLE ITEM","I")
  1. I $D(^PSDRUG("A527",PSBDIEN)) S X="" F S X=$O(^PSDRUG("A527",PSBDIEN,X)) Q:X="" D
  1. .S PSBINACT=$$GET1^DIQ(52.7,X,8,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
  1. .S RESULTS(PSBCNT)="SOL"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
  1. I $D(^PSDRUG("A526",PSBDIEN)) S X="" F S X=$O(^PSDRUG("A526",PSBDIEN,X)) Q:X="" D
  1. .S PSBINACT=$$GET1^DIQ(52.6,X,12,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
  1. .S RESULTS(PSBCNT)="ADD"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
  1. ;
  1. I PSBTAB="PBTAB",$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")'<1 S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C"),RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
  1. Q
  1. ;