PSBRPCMO ;BIRMINGHAM/EFC-MED ORDER BUTTON FUNCTIONS ;Mar 2004
;;3.0;BAR CODE MED ADMIN;**6,32**;Mar 2004;Build 32
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
; Reference/IA
; ^XUSEC("PROVIDER")/10076
; ^%DTC/10000
; ^XPAR/2263
; File 50/221
; File 50.7/2880
; File 200/10060
; File 52.6/436
; File 52.7/437
; $$EN^ORBCMA2/3616
; C^PSN50P65/4543
OILST(RESULTS,PSBSCAN,PSBOTYP) ;
I PSBOTYP="VAC" D VACLKU Q
I $L(PSBSCAN?.N)>31 S PSBSCAN=$E(PSBSCAN,1,31)
S PSBSCAN=$TR(PSBSCAN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
D NOW^%DTC S PSBDT=%
I $$GET^XPAR("DIV","PSB ROBOT RX"),PSBSCAN?1"3"15N!(PSBSCAN?1"3"17N),123[$E(PSBSCAN,12) S PSBSCAN=$E(PSBSCAN,2,11)
S PSBCNT=0
I PSBSCAN?.N I PSBOTYP'="OIT" D ;is a scanned bar code
.I '$D(^PSDRUG(PSBSCAN)) S PSBSCAN=$$FIND1^DIC(50,"","AX",PSBSCAN,"B^C") I PSBSCAN<1 Q ; not in the drug file
.Q:PSBOTYP="UD"&($P($G(^PSDRUG(PSBSCAN,2)),U,3)'["U")
.Q:PSBOTYP="UD"&($G(^PSDRUG(PSBSCAN,"I"))&(+$G(^("I"))'>PSBDT))
.S PSBOIEN=$$GET1^DIQ(50,PSBSCAN,"PHARMACY ORDERABLE ITEM","I") Q:PSBOIEN="" ;orderable item ien
.D CPRS
.Q:PSBCPRS]""&(PSBCPRS'>PSBDT)
.;cprs orderable inact dt?
.I $P(A,U,4)="" Q
.I +$P(A,U,4)=0 Q ;not inpat pharm item
.S PSBPOI=$$GET1^DIQ(50.7,PSBOIEN,.01)
.S PSBDD=$$GET1^DIQ(50,PSBSCAN,.01)
.I PSBOTYP="UD" D Q
..S PSBDRUG="DD"_U_PSBSCAN_U_PSBDD_U_PSBOIEN_U_PSBPOI_U_PSBORIEN_U_PSBORNM
..S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=PSBDRUG,RESULTS(0)=PSBCNT
.I PSBOTYP="IV" D Q
..S PSBCNT=0
..I $P(A,U,4)=2 D
...I $D(^PSDRUG("A527",PSBSCAN)) D SOLN
...I $D(^PSDRUG("A526",PSBSCAN)) D ADD
.S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)="-1^Medication does not match ordertype",RESULTS(0)=PSBCNT Q
I PSBSCAN?.N I PSBOTYP="OIT" D ;scanned?
.I '$D(^PS(50.7,PSBSCAN)) S PSBSCAN=$$FIND1^DIC(50.7,"","AX",PSBSCAN,"B^C") I PSBSCAN<1 Q ; not in the OItem file
.S PSBOIEN=PSBSCAN Q:PSBOIEN="" ;ord item ien
.D CPRS
.Q:PSBCPRS]""&(PSBCPRS'>PSBDT)
.;cprs orderable inact dt?
.I $P(A,U,4)="" Q
.I +$P(A,U,4)=0 Q ;not inpat pharm item
.S PSBPOI=$$GET1^DIQ(50.7,PSBOIEN,.01)
.S PSBDIEN=$$GETDRN^PSBOMT(PSBPOI)
.S PSBDD=$$GET1^DIQ(50,PSBDIEN,.01)
.S PSBDRUG="OIT"_U_PSBSCAN_U_PSBPOI_U_PSBDIEN_U_PSBDD_U_PSBORIEN_U_PSBORNM
.S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=PSBDRUG,RESULTS(0)=PSBCNT
.;
I PSBSCAN'?.N D
.I PSBOTYP="OIT" D OITMB
.I PSBOTYP'="OIT" K PSBMSG D LIST^DIC(50,"","2.1I;2.1","P","","",PSBSCAN,"B","","","^TMP(""PSBLST"",$J)","PSBMSG")
.;alpha-numerc look up "B" index drug file
.S X=0 F S X=$O(^TMP("PSBLST",$J,"DILIST",X)) Q:X="" D
..Q:$P(^TMP("PSBLST",$J,"DILIST",X,0),U,3)=""
..Q:$P(^TMP("PSBLST",$J,"DILIST",X,0),U,4)=""
..I PSBOTYP'="OIT" D
...I $P(^TMP("PSBLST",$J,"DILIST",X,0),U,3)'?.N S $P(^TMP("PSBLST",$J,"DILIST",X,0),U,3,99)=$P(^TMP("PSBLST",$J,"DILIST",X,0),U,4,99) Q
...S ^TMP("PSB",$J,$P(^TMP("PSBLST",$J,"DILIST",X,0),U))=^TMP("PSBLST",$J,"DILIST",X,0)
..I PSBOTYP="OIT" S ^TMP("PSB",$J,$P(^TMP("PSBLST",$J,"DILIST",X,0),U))=^TMP("PSBLST",$J,"DILIST",X,0)
.I PSBOTYP="OIT" D OITMC
.I PSBOTYP'="OIT" K ^TMP("PSBLST",$J,"DILIST"),PSBMSG D LIST^DIC(50,"","2.1I;2.1","P","","",PSBSCAN,"C","","","^TMP(""PSBLST"",$J)","PSBMSG")
.;alpha-numerc look up "C" index drug file
.S X=0 F S X=$O(^TMP("PSBLST",$J,"DILIST",X)) Q:X="" D
..Q:$P(^TMP("PSBLST",$J,"DILIST",X,0),U,3)=""
..Q:$P(^TMP("PSBLST",$J,"DILIST",X,0),U,4)=""
..I PSBOTYP'="OIT" D
...I $P(^TMP("PSBLST",$J,"DILIST",X,0),U,3)'?.N S $P(^TMP("PSBLST",$J,"DILIST",X,0),U,3,99)=$P(^TMP("PSBLST",$J,"DILIST",X,0),U,4,99) Q
...S ^TMP("PSB",$J,$P(^TMP("PSBLST",$J,"DILIST",X,0),U))=$P(^TMP("PSBLST",$J,"DILIST",X,0),U)_U_$P($G(^PSDRUG($P(^TMP("PSBLST",$J,"DILIST",X,0),U),0)),U)_U_$P(^TMP("PSBLST",$J,"DILIST",X,0),U,3,99)
..I PSBOTYP="OIT" S ^TMP("PSB",$J,$P(^TMP("PSBLST",$J,"DILIST",X,0),U))=$P(^TMP("PSBLST",$J,"DILIST",X,0),U)_U_$P($G(^PSDRUG($P(^TMP("PSBLST",$J,"DILIST",X,0),U),0)),U)_U_$P(^TMP("PSBLST",$J,"DILIST",X,0),U,3,99)
.S PSBCNT=0,RESULTS(0)=0,PSBTLNG=0
.S X="" K PSBGOT F S X=$O(^TMP("PSB",$J,X)) Q:((+X=0)!(PSBTLNG=1)) D
..I PSBOTYP'="OIT" D
...I $P(^TMP("PSB",$J,X),U,3)'?.N S $P(^TMP("PSB",$J,X),U,3,99)=$P(^TMP("PSB",$J,X),U,4,99)
...S PSBOIEN=$P(^TMP("PSB",$J,X),U,3)
...S PSBSCIEN=$P(^TMP("PSB",$J,X),U,1)
..I PSBOTYP'="OIT" Q:PSBOTYP="UD"&($P($G(^PSDRUG(PSBSCIEN,2)),U,3)'["U")
..I PSBOTYP'="OIT" Q:PSBOTYP="UD"&($G(^PSDRUG(PSBSCIEN,"I"))&(+$G(^("I"))'>PSBDT))
..I PSBOTYP="OIT" D
...S PSBOIEN=$P(^TMP("PSB",$J,X),U)
..D CPRS
..Q:PSBCPRS]""&(PSBCPRS'>PSBDT)
..;cprs orderable inact dt?
..I $P(A,U,4)="" Q
..I +$P(A,U,4)=0 Q ;not inpat pharm item
..I PSBOTYP="OIT" D Q
...I $D(PSBGOT($P(^TMP("PSB",$J,X),U,4))) S $P(RESULTS(PSBCNT),U,2)=$P(RESULTS(PSBCNT),U,2)_","_$P(^TMP("PSB",$J,X),U) Q
...S PSBDRUG="OIT"_U_$P(^TMP("PSB",$J,X),U)_U_$P(^TMP("PSB",$J,X),U,3,4)_U_PSBORIEN_U_PSBORNM,PSBGOT($P(^TMP("PSB",$J,X),U,4))=""
...S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=PSBDRUG,RESULTS(0)=PSBCNT
..I PSBOTYP="UD" D Q
...S PSBDRUG="DD"_U_$P(^TMP("PSB",$J,X),U,1,2)_U_$P(^TMP("PSB",$J,X),U,3,4)_U_PSBORIEN_U_PSBORNM
...S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=PSBDRUG,RESULTS(0)=PSBCNT
..I PSBOTYP="IV" D Q
...I $P(A,U,4)=2 D
....I $D(^PSDRUG("A527",PSBSCIEN)) D SOLNAL
....I $D(^PSDRUG("A526",PSBSCIEN)) D ADDAL
..I RESULTS(0)>100 K RESULTS S RESULTS(0)=1,RESULTS(1)=-2,PSBTLNG=1 Q
I $G(RESULTS(1))="" S RESULTS(0)=1,RESULTS(1)="-1^Invalid Medication Lookup"
K PSBDD,PSBDRUG,PSBDT,PSBDTYP,PSBSCIEN,PSBOIEN,PSBORNM,PSBORIEN,PSBPOI,PSBSCAN,PSBTLNG,PSBID,PSBCPRS,^TMP("PSB",$J),^TMP("PSBLST",$J)
Q
CPRS ;
S PSBID=PSBOIEN_";99PSP"
S A=$$EN^ORBCMA2(PSBID)
S PSBORNM=$P(A,U,2)
S PSBORIEN=$P(A,U,1)
S PSBCPRS=$P(A,U,3)
Q
SOLN ;
S X="" F S X=$O(^PSDRUG("A527",PSBSCAN,X)) Q:X="" D
.S PSBINACT=$$GET1^DIQ(52.7,X,8,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
.S PSBDRUG="SOL"_U_PSBSCAN_U_PSBDD_U_PSBOIEN_U_PSBPOI_U_PSBORIEN_U_PSBORNM
.S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=PSBDRUG_U_X_U_$$GET1^DIQ(52.7,X_",",.01)_U_$$GET1^DIQ(52.7,X_",",2),RESULTS(0)=PSBCNT
Q
ADD ;
S X="" F S X=$O(^PSDRUG("A526",PSBSCAN,X)) Q:X="" D
.S PSBINACT=$$GET1^DIQ(52.6,X,12,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
.S PSBDRUG="ADD"_U_PSBSCAN_U_PSBDD_U_PSBOIEN_U_PSBPOI_U_PSBORIEN_U_PSBORNM
.S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=PSBDRUG_U_X_U_$$GET1^DIQ(52.6,X_",",.01),RESULTS(0)=PSBCNT
Q
OITMB ;
K PSBMSG D LIST^DIC(50.7,"",".01I;.01","P","","",PSBSCAN,"B","","","^TMP(""PSBLST"",$J)","PSBMSG")
Q
OITMC ;
K PSBMSG D LIST^DIC(50.7,"",".01I;.01","P","","",PSBSCAN,"C","","","^TMP(""PSBLST"",$J)","PSBMSG")
Q
SOLNAL ;
S Y="" F S Y=$O(^PSDRUG("A527",PSBSCIEN,Y)) Q:Y="" D
.S PSBINACT=$$GET1^DIQ(52.7,Y,8,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
.S PSBDRUG="SOL"_U_$P(^TMP("PSB",$J,X),U,1,2)_U_$P(^TMP("PSB",$J,X),U,3,4)_U_PSBORIEN_U_PSBORNM
.S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=PSBDRUG_U_Y_U_$$GET1^DIQ(52.7,Y_",",.01)_U_$$GET1^DIQ(52.7,Y_",",2),RESULTS(0)=PSBCNT
Q
ADDAL ;
S Y="" F S Y=$O(^PSDRUG("A526",PSBSCIEN,Y)) Q:Y="" D
.S PSBINACT=$$GET1^DIQ(52.6,Y,12,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
.S PSBDRUG="ADD"_U_$P(^TMP("PSB",$J,X),U,1,2)_U_$P(^TMP("PSB",$J,X),U,3,4)_U_PSBORIEN_U_PSBORNM
.S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=PSBDRUG_U_Y_U_$$GET1^DIQ(52.6,Y_",",.01),RESULTS(0)=PSBCNT
Q
PROVLST(RESULTS,PSBIN) ;
K ^TMP("PSB",$J) D NOW^%DTC
S PSBIN=$TR(PSBIN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
S RESULTS(0)=1,RESULTS(1)="-1^No provider matching input.",PSBTLNG=0
D LIST^DIC(200,"","","P","","",PSBIN,"B","","","^TMP(""PSB"",$J)","PSBMSG")
S X=0 F S X=$O(^TMP("PSB",$J,"DILIST",X)) Q:((X="")!(PSBTLNG=1)) D
.S PSBIEN=$P(^TMP("PSB",$J,"DILIST",X,0),U,1)
.I '$D(^XUSEC("PROVIDER",PSBIEN)) Q
.S PSBIACT=$$GET1^DIQ(200,PSBIEN_",",53.4,"I")
.Q:PSBIACT'=""&(+PSBIACT'>%) ;if Inactive date and date is less than now Q
.S PSBTERM=$$GET1^DIQ(200,PSBIEN_",",9.2,"I")
.Q:PSBTERM'=""&(+PSBTERM'>%) ;if termination date and date is less than now Q
.S PSBAUTH=$$GET1^DIQ(200,PSBIEN_",",53.1,"I") I PSBAUTH'=1 Q ;is AUTHORIZED TO WRITE MED ORDERS
.I RESULTS(1)["-1" S RESULTS(0)=0
.S RESULTS(0)=RESULTS(0)+1,RESULTS(RESULTS(0))=$P(^TMP("PSB",$J,"DILIST",X,0),U,1,2)
.I RESULTS(0)>100 K RESULTS S RESULTS(0)=1,RESULTS(1)=-2,PSBTLNG=1
K ^TMP("PSB",$J),PSBIN,PSBTLNG,PSBIACT,PSBIEN,PSBTERM,PSBAUTH
Q
ORDER(RESULTS,PSBHDR,PSBREC) ;
S RESULTS(0)=1,RESULTS(1)="-1^Data not filed"
S PSBDFN=$P(PSBHDR,U,1),PSBMON=$P(PSBHDR,U,2),PSBSCH=$P(PSBHDR,U,3)
S ^TMP("PSBMO",$J,PSBDFN,PSBMON,0)=PSBDFN_U_PSBMON_U_PSBREC(0)_U_PSBREC(1)_U_PSBREC(2)_U_PSBSCH
S ^TMP("PSBMO",$J,PSBDFN,PSBMON,700,0)=0,^TMP("PSBMO",$J,PSBDFN,PSBMON,800,0)=0,^TMP("PSBMO",$J,PSBDFN,PSBMON,900,0)=0
I PSBREC(3)>0 D
.S ^TMP("PSBMO",$J,PSBDFN,PSBMON,700,0)=PSBREC(3)
.F I=1:1:PSBREC(3) D
..S ^TMP("PSBMO",$J,PSBDFN,PSBMON,700,I,0)=$P(PSBREC(4),U,1)_U_$P(PSBREC(4),U,2)
..S PSBREC(4)=$P(PSBREC(4),U,3,99)
I PSBREC(5)>0 D
.S ^TMP("PSBMO",$J,PSBDFN,PSBMON,800,0)=PSBREC(5)
.F I=1:1:PSBREC(5) S ^TMP("PSBMO",$J,PSBDFN,PSBMON,800,I,0)=$P(PSBREC(6),U,I)
I PSBREC(7)>0 D
.S ^TMP("PSBMO",$J,PSBDFN,PSBMON,900,0)=PSBREC(7)
.F I=1:1:PSBREC(7) S ^TMP("PSBMO",$J,PSBDFN,PSBMON,900,I,0)=$P(PSBREC(8),U,I)
S ^TMP("PSBMO",$J,PSBDFN,PSBMON,"PSB")=DUZ_U_DUZ(2)_U_PSBREC(9)_U_$G(PSBREC(10))
S RESULTS(0)=1,RESULTS(1)="1^Data successfully filed"
Q
VACLKU ;
D C^PSN50P65(,PSBSCAN,"PSBLST")
S PSBCNT=0,RESULTS(0)=0,PSBTLNG=0
S X=0 F S X=$O(^TMP($J,"PSBLST",X)) Q:((+X=0)!(PSBTLNG=1)) D
.S PSBVAC="VAC"_U_X_U_^TMP($J,"PSBLST",X,1)_U_^TMP($J,"PSBLST",X,.01)
.S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=PSBVAC,RESULTS(0)=PSBCNT
.I RESULTS(0)>100 K RESULTS S RESULTS(0)=1,RESULTS(1)=-2,PSBTLNG=1 Q
I $G(RESULTS(1))="" S RESULTS(0)=1,RESULTS(1)="-1^Invalid Medication Lookup"
K ^TMP($J,"PSBLST"),PSBVAC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBRPCMO 9959 printed Oct 16, 2024@17:42:02 Page 2
PSBRPCMO ;BIRMINGHAM/EFC-MED ORDER BUTTON FUNCTIONS ;Mar 2004
+1 ;;3.0;BAR CODE MED ADMIN;**6,32**;Mar 2004;Build 32
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ; Reference/IA
+4 ; ^XUSEC("PROVIDER")/10076
+5 ; ^%DTC/10000
+6 ; ^XPAR/2263
+7 ; File 50/221
+8 ; File 50.7/2880
+9 ; File 200/10060
+10 ; File 52.6/436
+11 ; File 52.7/437
+12 ; $$EN^ORBCMA2/3616
+13 ; C^PSN50P65/4543
OILST(RESULTS,PSBSCAN,PSBOTYP) ;
+1 IF PSBOTYP="VAC"
DO VACLKU
QUIT
+2 IF $LENGTH(PSBSCAN?.N)>31
SET PSBSCAN=$EXTRACT(PSBSCAN,1,31)
+3 SET PSBSCAN=$TRANSLATE(PSBSCAN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+4 DO NOW^%DTC
SET PSBDT=%
+5 IF $$GET^XPAR("DIV","PSB ROBOT RX")
IF PSBSCAN?1"3"15N!(PSBSCAN?1"3"17N)
IF 123[$EXTRACT(PSBSCAN,12)
SET PSBSCAN=$EXTRACT(PSBSCAN,2,11)
+6 SET PSBCNT=0
+7 ;is a scanned bar code
IF PSBSCAN?.N
IF PSBOTYP'="OIT"
Begin DoDot:1
+8 ; not in the drug file
IF '$DATA(^PSDRUG(PSBSCAN))
SET PSBSCAN=$$FIND1^DIC(50,"","AX",PSBSCAN,"B^C")
IF PSBSCAN<1
QUIT
+9 if PSBOTYP="UD"&($PIECE($GET(^PSDRUG(PSBSCAN,2)),U,3)'["U")
QUIT
+10 if PSBOTYP="UD"&($GET(^PSDRUG(PSBSCAN,"I"))&(+$GET(^("I"))'>PSBDT))
QUIT
+11 ;orderable item ien
SET PSBOIEN=$$GET1^DIQ(50,PSBSCAN,"PHARMACY ORDERABLE ITEM","I")
if PSBOIEN=""
QUIT
+12 DO CPRS
+13 if PSBCPRS]""&(PSBCPRS'>PSBDT)
QUIT
+14 ;cprs orderable inact dt?
+15 IF $PIECE(A,U,4)=""
QUIT
+16 ;not inpat pharm item
IF +$PIECE(A,U,4)=0
QUIT
+17 SET PSBPOI=$$GET1^DIQ(50.7,PSBOIEN,.01)
+18 SET PSBDD=$$GET1^DIQ(50,PSBSCAN,.01)
+19 IF PSBOTYP="UD"
Begin DoDot:2
+20 SET PSBDRUG="DD"_U_PSBSCAN_U_PSBDD_U_PSBOIEN_U_PSBPOI_U_PSBORIEN_U_PSBORNM
+21 SET PSBCNT=PSBCNT+1
SET RESULTS(PSBCNT)=PSBDRUG
SET RESULTS(0)=PSBCNT
End DoDot:2
QUIT
+22 IF PSBOTYP="IV"
Begin DoDot:2
+23 SET PSBCNT=0
+24 IF $PIECE(A,U,4)=2
Begin DoDot:3
+25 IF $DATA(^PSDRUG("A527",PSBSCAN))
DO SOLN
+26 IF $DATA(^PSDRUG("A526",PSBSCAN))
DO ADD
End DoDot:3
End DoDot:2
QUIT
+27 SET PSBCNT=PSBCNT+1
SET RESULTS(PSBCNT)="-1^Medication does not match ordertype"
SET RESULTS(0)=PSBCNT
QUIT
End DoDot:1
+28 ;scanned?
IF PSBSCAN?.N
IF PSBOTYP="OIT"
Begin DoDot:1
+29 ; not in the OItem file
IF '$DATA(^PS(50.7,PSBSCAN))
SET PSBSCAN=$$FIND1^DIC(50.7,"","AX",PSBSCAN,"B^C")
IF PSBSCAN<1
QUIT
+30 ;ord item ien
SET PSBOIEN=PSBSCAN
if PSBOIEN=""
QUIT
+31 DO CPRS
+32 if PSBCPRS]""&(PSBCPRS'>PSBDT)
QUIT
+33 ;cprs orderable inact dt?
+34 IF $PIECE(A,U,4)=""
QUIT
+35 ;not inpat pharm item
IF +$PIECE(A,U,4)=0
QUIT
+36 SET PSBPOI=$$GET1^DIQ(50.7,PSBOIEN,.01)
+37 SET PSBDIEN=$$GETDRN^PSBOMT(PSBPOI)
+38 SET PSBDD=$$GET1^DIQ(50,PSBDIEN,.01)
+39 SET PSBDRUG="OIT"_U_PSBSCAN_U_PSBPOI_U_PSBDIEN_U_PSBDD_U_PSBORIEN_U_PSBORNM
+40 SET PSBCNT=PSBCNT+1
SET RESULTS(PSBCNT)=PSBDRUG
SET RESULTS(0)=PSBCNT
+41 ;
End DoDot:1
+42 IF PSBSCAN'?.N
Begin DoDot:1
+43 IF PSBOTYP="OIT"
DO OITMB
+44 IF PSBOTYP'="OIT"
KILL PSBMSG
DO LIST^DIC(50,"","2.1I;2.1","P","","",PSBSCAN,"B","","","^TMP(""PSBLST"",$J)","PSBMSG")
+45 ;alpha-numerc look up "B" index drug file
+46 SET X=0
FOR
SET X=$ORDER(^TMP("PSBLST",$JOB,"DILIST",X))
if X=""
QUIT
Begin DoDot:2
+47 if $PIECE(^TMP("PSBLST",$JOB,"DILIST",X,0),U,3)=""
QUIT
+48 if $PIECE(^TMP("PSBLST",$JOB,"DILIST",X,0),U,4)=""
QUIT
+49 IF PSBOTYP'="OIT"
Begin DoDot:3
+50 IF $PIECE(^TMP("PSBLST",$JOB,"DILIST",X,0),U,3)'?.N
SET $PIECE(^TMP("PSBLST",$JOB,"DILIST",X,0),U,3,99)=$PIECE(^TMP("PSBLST",$JOB,"DILIST",X,0),U,4,99)
QUIT
+51 SET ^TMP("PSB",$JOB,$PIECE(^TMP("PSBLST",$JOB,"DILIST",X,0),U))=^TMP("PSBLST",$JOB,"DILIST",X,0)
End DoDot:3
+52 IF PSBOTYP="OIT"
SET ^TMP("PSB",$JOB,$PIECE(^TMP("PSBLST",$JOB,"DILIST",X,0),U))=^TMP("PSBLST",$JOB,"DILIST",X,0)
End DoDot:2
+53 IF PSBOTYP="OIT"
DO OITMC
+54 IF PSBOTYP'="OIT"
KILL ^TMP("PSBLST",$JOB,"DILIST"),PSBMSG
DO LIST^DIC(50,"","2.1I;2.1","P","","",PSBSCAN,"C","","","^TMP(""PSBLST"",$J)","PSBMSG")
+55 ;alpha-numerc look up "C" index drug file
+56 SET X=0
FOR
SET X=$ORDER(^TMP("PSBLST",$JOB,"DILIST",X))
if X=""
QUIT
Begin DoDot:2
+57 if $PIECE(^TMP("PSBLST",$JOB,"DILIST",X,0),U,3)=""
QUIT
+58 if $PIECE(^TMP("PSBLST",$JOB,"DILIST",X,0),U,4)=""
QUIT
+59 IF PSBOTYP'="OIT"
Begin DoDot:3
+60 IF $PIECE(^TMP("PSBLST",$JOB,"DILIST",X,0),U,3)'?.N
SET $PIECE(^TMP("PSBLST",$JOB,"DILIST",X,0),U,3,99)=$PIECE(^TMP("PSBLST",$JOB,"DILIST",X,0),U,4,99)
QUIT
+61 SET ^TMP("PSB",$JOB,$PIECE(^TMP("PSBLST",$JOB,"DILIST",X,0),U))=$PIECE(^TMP("PSBLST",$JOB,"DILIST",X,0),U)_U_$PIECE($GET(^PSDRUG($PIECE(^TMP("PSBLST",$JOB,"DILIST",X,0),U),0)),U)_U_$PIECE(^TMP("PSBLST",$JOB,"DILIST",X,0)
,U,3,99)
End DoDot:3
+62 IF PSBOTYP="OIT"
SET ^TMP("PSB",$JOB,$PIECE(^TMP("PSBLST",$JOB,"DILIST",X,0),U))=$PIECE(^TMP("PSBLST",$JOB,"DILIST",X,0),U)_U_$PIECE($GET(^PSDRUG($PIECE(^TMP("PSBLST",$JOB,"DILIST",X,0),U),0)),U)_U_$PIECE(^TMP("PSBLST",$JOB,"DILIST",X,0),U,3
,99)
End DoDot:2
+63 SET PSBCNT=0
SET RESULTS(0)=0
SET PSBTLNG=0
+64 SET X=""
KILL PSBGOT
FOR
SET X=$ORDER(^TMP("PSB",$JOB,X))
if ((+X=0)!(PSBTLNG=1))
QUIT
Begin DoDot:2
+65 IF PSBOTYP'="OIT"
Begin DoDot:3
+66 IF $PIECE(^TMP("PSB",$JOB,X),U,3)'?.N
SET $PIECE(^TMP("PSB",$JOB,X),U,3,99)=$PIECE(^TMP("PSB",$JOB,X),U,4,99)
+67 SET PSBOIEN=$PIECE(^TMP("PSB",$JOB,X),U,3)
+68 SET PSBSCIEN=$PIECE(^TMP("PSB",$JOB,X),U,1)
End DoDot:3
+69 IF PSBOTYP'="OIT"
if PSBOTYP="UD"&($PIECE($GET(^PSDRUG(PSBSCIEN,2)),U,3)'["U")
QUIT
+70 IF PSBOTYP'="OIT"
if PSBOTYP="UD"&($GET(^PSDRUG(PSBSCIEN,"I"))&(+$GET(^("I"))'>PSBDT))
QUIT
+71 IF PSBOTYP="OIT"
Begin DoDot:3
+72 SET PSBOIEN=$PIECE(^TMP("PSB",$JOB,X),U)
End DoDot:3
+73 DO CPRS
+74 if PSBCPRS]""&(PSBCPRS'>PSBDT)
QUIT
+75 ;cprs orderable inact dt?
+76 IF $PIECE(A,U,4)=""
QUIT
+77 ;not inpat pharm item
IF +$PIECE(A,U,4)=0
QUIT
+78 IF PSBOTYP="OIT"
Begin DoDot:3
+79 IF $DATA(PSBGOT($PIECE(^TMP("PSB",$JOB,X),U,4)))
SET $PIECE(RESULTS(PSBCNT),U,2)=$PIECE(RESULTS(PSBCNT),U,2)_","_$PIECE(^TMP("PSB",$JOB,X),U)
QUIT
+80 SET PSBDRUG="OIT"_U_$PIECE(^TMP("PSB",$JOB,X),U)_U_$PIECE(^TMP("PSB",$JOB,X),U,3,4)_U_PSBORIEN_U_PSBORNM
SET PSBGOT($PIECE(^TMP("PSB",$JOB,X),U,4))=""
+81 SET PSBCNT=PSBCNT+1
SET RESULTS(PSBCNT)=PSBDRUG
SET RESULTS(0)=PSBCNT
End DoDot:3
QUIT
+82 IF PSBOTYP="UD"
Begin DoDot:3
+83 SET PSBDRUG="DD"_U_$PIECE(^TMP("PSB",$JOB,X),U,1,2)_U_$PIECE(^TMP("PSB",$JOB,X),U,3,4)_U_PSBORIEN_U_PSBORNM
+84 SET PSBCNT=PSBCNT+1
SET RESULTS(PSBCNT)=PSBDRUG
SET RESULTS(0)=PSBCNT
End DoDot:3
QUIT
+85 IF PSBOTYP="IV"
Begin DoDot:3
+86 IF $PIECE(A,U,4)=2
Begin DoDot:4
+87 IF $DATA(^PSDRUG("A527",PSBSCIEN))
DO SOLNAL
+88 IF $DATA(^PSDRUG("A526",PSBSCIEN))
DO ADDAL
End DoDot:4
End DoDot:3
QUIT
+89 IF RESULTS(0)>100
KILL RESULTS
SET RESULTS(0)=1
SET RESULTS(1)=-2
SET PSBTLNG=1
QUIT
End DoDot:2
End DoDot:1
+90 IF $GET(RESULTS(1))=""
SET RESULTS(0)=1
SET RESULTS(1)="-1^Invalid Medication Lookup"
+91 KILL PSBDD,PSBDRUG,PSBDT,PSBDTYP,PSBSCIEN,PSBOIEN,PSBORNM,PSBORIEN,PSBPOI,PSBSCAN,PSBTLNG,PSBID,PSBCPRS,^TMP("PSB",$JOB),^TMP("PSBLST",$JOB)
+92 QUIT
CPRS ;
+1 SET PSBID=PSBOIEN_";99PSP"
+2 SET A=$$EN^ORBCMA2(PSBID)
+3 SET PSBORNM=$PIECE(A,U,2)
+4 SET PSBORIEN=$PIECE(A,U,1)
+5 SET PSBCPRS=$PIECE(A,U,3)
+6 QUIT
SOLN ;
+1 SET X=""
FOR
SET X=$ORDER(^PSDRUG("A527",PSBSCAN,X))
if X=""
QUIT
Begin DoDot:1
+2 SET PSBINACT=$$GET1^DIQ(52.7,X,8,"I")
IF PSBINACT]""
IF PSBINACT'>PSBDT
QUIT
+3 SET PSBDRUG="SOL"_U_PSBSCAN_U_PSBDD_U_PSBOIEN_U_PSBPOI_U_PSBORIEN_U_PSBORNM
+4 SET PSBCNT=PSBCNT+1
SET RESULTS(PSBCNT)=PSBDRUG_U_X_U_$$GET1^DIQ(52.7,X_",",.01)_U_$$GET1^DIQ(52.7,X_",",2)
SET RESULTS(0)=PSBCNT
End DoDot:1
+5 QUIT
ADD ;
+1 SET X=""
FOR
SET X=$ORDER(^PSDRUG("A526",PSBSCAN,X))
if X=""
QUIT
Begin DoDot:1
+2 SET PSBINACT=$$GET1^DIQ(52.6,X,12,"I")
IF PSBINACT]""
IF PSBINACT'>PSBDT
QUIT
+3 SET PSBDRUG="ADD"_U_PSBSCAN_U_PSBDD_U_PSBOIEN_U_PSBPOI_U_PSBORIEN_U_PSBORNM
+4 SET PSBCNT=PSBCNT+1
SET RESULTS(PSBCNT)=PSBDRUG_U_X_U_$$GET1^DIQ(52.6,X_",",.01)
SET RESULTS(0)=PSBCNT
End DoDot:1
+5 QUIT
OITMB ;
+1 KILL PSBMSG
DO LIST^DIC(50.7,"",".01I;.01","P","","",PSBSCAN,"B","","","^TMP(""PSBLST"",$J)","PSBMSG")
+2 QUIT
OITMC ;
+1 KILL PSBMSG
DO LIST^DIC(50.7,"",".01I;.01","P","","",PSBSCAN,"C","","","^TMP(""PSBLST"",$J)","PSBMSG")
+2 QUIT
SOLNAL ;
+1 SET Y=""
FOR
SET Y=$ORDER(^PSDRUG("A527",PSBSCIEN,Y))
if Y=""
QUIT
Begin DoDot:1
+2 SET PSBINACT=$$GET1^DIQ(52.7,Y,8,"I")
IF PSBINACT]""
IF PSBINACT'>PSBDT
QUIT
+3 SET PSBDRUG="SOL"_U_$PIECE(^TMP("PSB",$JOB,X),U,1,2)_U_$PIECE(^TMP("PSB",$JOB,X),U,3,4)_U_PSBORIEN_U_PSBORNM
+4 SET PSBCNT=PSBCNT+1
SET RESULTS(PSBCNT)=PSBDRUG_U_Y_U_$$GET1^DIQ(52.7,Y_",",.01)_U_$$GET1^DIQ(52.7,Y_",",2)
SET RESULTS(0)=PSBCNT
End DoDot:1
+5 QUIT
ADDAL ;
+1 SET Y=""
FOR
SET Y=$ORDER(^PSDRUG("A526",PSBSCIEN,Y))
if Y=""
QUIT
Begin DoDot:1
+2 SET PSBINACT=$$GET1^DIQ(52.6,Y,12,"I")
IF PSBINACT]""
IF PSBINACT'>PSBDT
QUIT
+3 SET PSBDRUG="ADD"_U_$PIECE(^TMP("PSB",$JOB,X),U,1,2)_U_$PIECE(^TMP("PSB",$JOB,X),U,3,4)_U_PSBORIEN_U_PSBORNM
+4 SET PSBCNT=PSBCNT+1
SET RESULTS(PSBCNT)=PSBDRUG_U_Y_U_$$GET1^DIQ(52.6,Y_",",.01)
SET RESULTS(0)=PSBCNT
End DoDot:1
+5 QUIT
PROVLST(RESULTS,PSBIN) ;
+1 KILL ^TMP("PSB",$JOB)
DO NOW^%DTC
+2 SET PSBIN=$TRANSLATE(PSBIN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+3 SET RESULTS(0)=1
SET RESULTS(1)="-1^No provider matching input."
SET PSBTLNG=0
+4 DO LIST^DIC(200,"","","P","","",PSBIN,"B","","","^TMP(""PSB"",$J)","PSBMSG")
+5 SET X=0
FOR
SET X=$ORDER(^TMP("PSB",$JOB,"DILIST",X))
if ((X="")!(PSBTLNG=1))
QUIT
Begin DoDot:1
+6 SET PSBIEN=$PIECE(^TMP("PSB",$JOB,"DILIST",X,0),U,1)
+7 IF '$DATA(^XUSEC("PROVIDER",PSBIEN))
QUIT
+8 SET PSBIACT=$$GET1^DIQ(200,PSBIEN_",",53.4,"I")
+9 ;if Inactive date and date is less than now Q
if PSBIACT'=""&(+PSBIACT'>%)
QUIT
+10 SET PSBTERM=$$GET1^DIQ(200,PSBIEN_",",9.2,"I")
+11 ;if termination date and date is less than now Q
if PSBTERM'=""&(+PSBTERM'>%)
QUIT
+12 ;is AUTHORIZED TO WRITE MED ORDERS
SET PSBAUTH=$$GET1^DIQ(200,PSBIEN_",",53.1,"I")
IF PSBAUTH'=1
QUIT
+13 IF RESULTS(1)["-1"
SET RESULTS(0)=0
+14 SET RESULTS(0)=RESULTS(0)+1
SET RESULTS(RESULTS(0))=$PIECE(^TMP("PSB",$JOB,"DILIST",X,0),U,1,2)
+15 IF RESULTS(0)>100
KILL RESULTS
SET RESULTS(0)=1
SET RESULTS(1)=-2
SET PSBTLNG=1
End DoDot:1
+16 KILL ^TMP("PSB",$JOB),PSBIN,PSBTLNG,PSBIACT,PSBIEN,PSBTERM,PSBAUTH
+17 QUIT
ORDER(RESULTS,PSBHDR,PSBREC) ;
+1 SET RESULTS(0)=1
SET RESULTS(1)="-1^Data not filed"
+2 SET PSBDFN=$PIECE(PSBHDR,U,1)
SET PSBMON=$PIECE(PSBHDR,U,2)
SET PSBSCH=$PIECE(PSBHDR,U,3)
+3 SET ^TMP("PSBMO",$JOB,PSBDFN,PSBMON,0)=PSBDFN_U_PSBMON_U_PSBREC(0)_U_PSBREC(1)_U_PSBREC(2)_U_PSBSCH
+4 SET ^TMP("PSBMO",$JOB,PSBDFN,PSBMON,700,0)=0
SET ^TMP("PSBMO",$JOB,PSBDFN,PSBMON,800,0)=0
SET ^TMP("PSBMO",$JOB,PSBDFN,PSBMON,900,0)=0
+5 IF PSBREC(3)>0
Begin DoDot:1
+6 SET ^TMP("PSBMO",$JOB,PSBDFN,PSBMON,700,0)=PSBREC(3)
+7 FOR I=1:1:PSBREC(3)
Begin DoDot:2
+8 SET ^TMP("PSBMO",$JOB,PSBDFN,PSBMON,700,I,0)=$PIECE(PSBREC(4),U,1)_U_$PIECE(PSBREC(4),U,2)
+9 SET PSBREC(4)=$PIECE(PSBREC(4),U,3,99)
End DoDot:2
End DoDot:1
+10 IF PSBREC(5)>0
Begin DoDot:1
+11 SET ^TMP("PSBMO",$JOB,PSBDFN,PSBMON,800,0)=PSBREC(5)
+12 FOR I=1:1:PSBREC(5)
SET ^TMP("PSBMO",$JOB,PSBDFN,PSBMON,800,I,0)=$PIECE(PSBREC(6),U,I)
End DoDot:1
+13 IF PSBREC(7)>0
Begin DoDot:1
+14 SET ^TMP("PSBMO",$JOB,PSBDFN,PSBMON,900,0)=PSBREC(7)
+15 FOR I=1:1:PSBREC(7)
SET ^TMP("PSBMO",$JOB,PSBDFN,PSBMON,900,I,0)=$PIECE(PSBREC(8),U,I)
End DoDot:1
+16 SET ^TMP("PSBMO",$JOB,PSBDFN,PSBMON,"PSB")=DUZ_U_DUZ(2)_U_PSBREC(9)_U_$GET(PSBREC(10))
+17 SET RESULTS(0)=1
SET RESULTS(1)="1^Data successfully filed"
+18 QUIT
VACLKU ;
+1 DO C^PSN50P65(,PSBSCAN,"PSBLST")
+2 SET PSBCNT=0
SET RESULTS(0)=0
SET PSBTLNG=0
+3 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"PSBLST",X))
if ((+X=0)!(PSBTLNG=1))
QUIT
Begin DoDot:1
+4 SET PSBVAC="VAC"_U_X_U_^TMP($JOB,"PSBLST",X,1)_U_^TMP($JOB,"PSBLST",X,.01)
+5 SET PSBCNT=PSBCNT+1
SET RESULTS(PSBCNT)=PSBVAC
SET RESULTS(0)=PSBCNT
+6 IF RESULTS(0)>100
KILL RESULTS
SET RESULTS(0)=1
SET RESULTS(1)=-2
SET PSBTLNG=1
QUIT
End DoDot:1
+7 IF $GET(RESULTS(1))=""
SET RESULTS(0)=1
SET RESULTS(1)="-1^Invalid Medication Lookup"
+8 KILL ^TMP($JOB,"PSBLST"),PSBVAC
+9 QUIT
