source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBRPCMO.m

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