- 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 Feb 18, 2025@23:07:33 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