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