BPSSCRU2 ;BHAM ISC/SS - ECME SCREEN UTILITIES ;05-APR-05
;;1.0;E CLAIMS MGMT ENGINE;**1,3,5,10,11,20**;JUN 2004;Build 27
;;Per VA Directive 6402, this routine should not be modified.
;USER SCREEN
Q
;/**
;Input:
; BP59 - pointer to file #9002313.59
;Output:
;get filling "location" like "WINDOW/LOCALMAIL/CMOP"
GETMWC(BP59) ;*/
N BP1 S BP1=$$RXREF(BP59)
Q:+BP1=0 ""
Q $$MWC($P(BP1,U),$P(BP1,U,2))
;
;initially this was designed to convert numbers to letters to display on the screen
;but later the Pharmacy designed API that returns letters instead of numbers
;so now this function just returns what it receives in its parameter, while it does not
;make any sense, we still keep it in order to prevent changes in other four routines:
; BPSREOP1, BPSSCR02, BPSSCR03, BPSSCR04
MWCNAME(BPMWC) ;
Q BPMWC
;/**
;Input:
; BP59 - pointer to file #9002313.59
;Output:
;get RX pointer in file #52 and refill number in its multiple (0 - original refill)
RXREF(BP59) ;
N BPRX,BPREF
S BPRX=+$P($G(^BPST(BP59,1)),U,11) ;ptr to RX node in #52
S BPREF=+$P($G(^BPST(BP59,1)),U) ;ptr to refill multiple in #52
Q BPRX_U_BPREF
; determines if the refill was MAIL/WINDOW/CMOP
MWC(BPRX,BPREF) ;MAIL/WINDOW/CMOP
;input:
; BPRX ptr to #52 (RX)
; BPREF ptr to #52.1 (refills)
;return value:
; 2-MAIL/3-WINDOW/4-CMOP
Q $$MWC^PSOBPSU2(BPRX,BPREF)
;
;
;/**
;Input:
; BP59 - pointer to file #9002313.59
;Output:
; insurance ien ^ name ^ phone
GETINSUR(BP59) ;get insurance info by the pointer of #9002313.59
N BPHONE,BPINSNM,BPINSID,BP57,BPINSN,BPX
S BPX=$$NAMEPHON^BPSSCRU3(BP59)
S BPINSNM=$P(BPX,U,1)
S BPHONE=$P(BPX,U,2)
;Get a temporary ID for the insurance from ^TMP list of insurances.
;If doesn't exist yet then create a new record in ^TMP list of insurances
; for this insurance and return the ID for the record.
;A lifetime for ^TMP list of insurances is the time period the user is using
; the User Screen menu option
S BPINSID=$$CHKINSUR^BPSSCR(BPINSNM,BPHONE)
I $L(BPHONE)=0 S BPHONE=" "
I $L(BPINSNM)=0 S BPINSNM="?NODATA?"
Q BPINSID_U_BPINSNM_U_BPHONE
;
;/**
;Input:
; BP59 - pointer to file #9002313.59
;Output:
;transaction date
TRANDT(BP59) ;
Q $P($G(^BPST(BP59,0)),U,8)\1
;
;/**
;Input:
; BP59 - pointer to file #9002313.59
;Output:
;ECME pharmacy division (9002313.56)
DIVIS(BP59) ;
Q $P($G(^BPST(BP59,1)),U,7)
;
;/**
;Input:
; BP59 - pointer to file #9002313.59
;Output:
;patient's DFN (file #2)
GETPATID(BP59) ;
Q $P($G(^BPST(BP59,0)),U,6)
;
;return RX status as ACT/DIS/etc
RXST(BP59) ;
N BPRXREF
S BPRXREF=$$RXREF^BPSSCRU2(BP59)
;display status ONLY if the refill is the most recent
;otherwise display blanks (three spaces for sorting purposes)
I +$P(BPRXREF,U,2)'=(+$$LSTRFL^PSOBPSU1(+$P(BPRXREF,U,1))) Q "**"
Q $$RXSTANAM($$RXSTATUS(+$P(BPRXREF,U,1)))
;/**
;RX status
;Input
; RXNUM:
; ien of file #52 (if MODE=0)
; or RX number (if MODE=1)
;----------
;Output:
; 0 if not found
; status set#
RXSTATUS(RXNUM) ;*/
N BPRET
S BPRET=$$RXAPI1^BPSUTIL1(RXNUM,100,"I")
I BPRET="" Q -1
Q BPRET
;/**
;if RX "valid"
RXACTIVE(BPRXSTAT) ;*/
; 0 not valid
; 1 valid (i.e. ACTIVE/NON-VERIFIED/REFILL/HOLD/DRUG INTERACTIONS/SUSPENDED)
; -1 doesn't exist
Q:BPRXSTAT<6 1 ;active
;/**
;RX status text
RXSTANAM(BPRXSTAT) ;*/
Q:BPRXSTAT=0 "AC" ; ACTIVE;
Q:BPRXSTAT=1 "NV" ; NON-VERIFIED;
Q:BPRXSTAT=3 "HL" ; HOLD;
Q:BPRXSTAT=5 "SU" ; SUSPENDED;
Q:BPRXSTAT=11 "EX" ; EXPIRED;
Q:BPRXSTAT=12 "DS" ; DISCONTINUED;
Q:BPRXSTAT=13 "DL" ; DELETED;
Q:BPRXSTAT=14 "DS" ; DISCONTINUED BY PROVIDER;
Q:BPRXSTAT=15 "DS" ; DISCONTINUED (EDIT);
Q:BPRXSTAT=16 "HL" ; PROVIDER HOLD;
Q:BPRXSTAT=-1 "??"
Q ""
;/**
;Input:
; BP59 - pointer to file #9002313.59
;Output:
;returns:
;>0 Released
;0 non released
;-1 error
ISRXREL(BP59) ;
N BP1
S BP1=$$REFILINF(BP59)
Q:BP1<0 -1
Q $P(BP1,U,2) ; i.e. it is non-released if there is no any release date
;
;release status
RL(BP59) ;
Q $S($$ISRXREL(BP59)>0:"R",1:"N")
;/**
;get refill (including original refill) info by BP59
;Input:
; BP59 - pointer to file #9002313.59
;Output:
;returns:
;on error : "-1"
;on success : refill# ^ release date ^label print date ^ fill date ^ issue date
REFILINF(BP59) ;*/
N BP1 S BP1=$$RXREF(BP59)
N BPRX S BPRX=$P(BP1,U,1) ;ptr to #52
N BPREF S BPREF=$P(BP1,U,2) ;ptr in its refill multiple
I BPREF,$$IFREFILL(BPRX,BPREF)=0 Q -1 ;if bad data
;original refill
I BPREF=0 Q "0"_U_$$RXRELDT(BPRX)_U_U_$$RXFILDT(BPRX)_U_$$RXISSDT(BPRX)
;refill's release date
I BPREF>0 Q BPREF_U_$$REFRELDT(BPRX,BPREF)_U_U_$$REFFILDT(BPRX,BPREF)_U_$$REFISSDT(BPRX,BPREF)
Q -1
;
;-Prescriptions-----------------------
;RX issue date
RXISSDT(BPRX) ;
Q +$$RXAPI1^BPSUTIL1(BPRX,1,"I")
;
;RX's release date
RXRELDT(BPRX) ;
Q +$$RXAPI1^BPSUTIL1(BPRX,31,"I")
;
;RX's fill date
RXFILDT(BPRX) ;
Q +$$RXAPI1^BPSUTIL1(BPRX,22,"I")
;
;refill's release date
REFRELDT(BPRX,BPREF) ;
Q +$$RXSUBF1^BPSUTIL1(BPRX,52,52.1,BPREF,17,"I")
;
;refill's refill date
REFFILDT(BPRX,BPREF) ;
Q $$RXSUBF1^BPSUTIL1(BPRX,52,52.1,BPREF,.01,"I")
;
;refill's issue date
REFISSDT(BPRX,BPREF) ;
Q $$REFDISDT(BPRX,BPREF)
;
;refill's dispense date
REFDISDT(BPRX,BPREF) ;
Q $$RXSUBF1^BPSUTIL1(BPRX,52,52.1,BPREF,10.1,"I")
;
;if refill exists
IFREFILL(BPRX,BPREF) ;
Q $$RXSUBF1^BPSUTIL1(BPRX,52,52.1,BPREF,.01,"I")'=""
;/**
;input
;ptr to 9002313.59
;output :
; BB - back billing
; P2 - PRO Option
; RS - ECME user screen resubmission (BPS*1*20)
; RT - all other values in (#1201) RX ACTION field on 9002313.59
RTBB(BP59) ;*/
N BPTRBB
S BPTRBB=$P($G(^BPST(BP59,12)),U)
I BPTRBB="" Q "**"
I BPTRBB="BB" Q "BB"
I BPTRBB="P2" Q "P2"
I BPTRBB="P2S" Q "P2"
I BPTRBB="ERES" Q "RS" ; ECME user screen resubmit (BPS*1*20)
I BPTRBB="ERWV" Q "RS" ; ECME user screen resubmit/without reversal (BPS*1*20)
I BPTRBB="ERNB" Q "RS" ; ECME user screen resubmit TRI/CVA non-billable (BPS*1*20)
Q "RT"
;
;------------ patient's name
PATNAME(BPDFN) ;
Q $E($P($G(^DPT(BPDFN,0)),U),1,15)
;
SSN4(DFN) ;last 4 SSN
N X
S X=$P($G(^DPT(DFN,0)),U,9)
Q "("_$E(X,$L(X)-3,$L(X))_")"
;
;get drug generic name
DRGNAM(BP50) ;
;BP50 - ptr to #50
Q $E($$DRUGDIE^BPSUTIL1(BP50,.01,"E"),1,35)
;get drug
GETDRUG(BP52) ;
;return value:
; 0 - unknown
; n - ptr to DRUG file #50
Q +$$RXAPI1^BPSUTIL1(BP52,6,"I")
;
GETDRG59(BP59) ;
N BPX
S BPX=$$RXREF(BP59)
Q $$GETDRUG(+BPX)
;
;
;review %% for each of claims in the array
;and calculate "overall" "done" status
;input:
; BPARR59 - array of ptr to #9002313.59
;output:
; status
FINISHST(BPARR59) ;
N BPFIN,BP59
S BPFIN=1,BP59=0
F S BP59=$O(BPARR59(BP59)) Q:+BP59=0 D Q:BPFIN=0
. I $$PRCNTG^BPSSCRU3(BP59)<99 S BPFIN=0
I BPFIN=1 Q "**FINISHED**"
Q ""
;
;
;BPRX - ptr to #52
RXNUM(BPRX) ;
Q $$RXAPI1^BPSUTIL1(BPRX,.01,"E")_$S(+$$RXAPI1^BPSUTIL1(BPRX,105,"I"):"$",1:"")
;
;/**
;get NDC
;input
;BPRX - ptr to #52
;BPREF - refill # (0,1,2,3...)
NDC(BPRX,BPREF) ;*/
N X
S X=$TR($$GETNDC^PSONDCUT(BPRX,BPREF),"-","") ;remove dashes
Q X
;
DRGNAME(BP59) ;drug name BP59 -ptr to .59 file
N BPRX
S BPRX=+$P($G(^BPST(BP59,1)),U,11) ;ptr to RX node in #52
Q $E($$DRGNAM($$GETDRUG(BPRX)),1,23)
;
;is the number even?
;1-yes
;0 -no
ISEVEN(BPNUM) ;
Q ((BPNUM/2)-(BPNUM\2))=0
;
;BPSTR - string to format
;BPSMLEN - max lenght
;BPSCHR - char to add
;BPSLFT - 1 - add from the left, 0 - from the right
FORMAT(BPSTR,BPSMLEN,BPSCHR,BPSLFT) ;
N LN S LN=$L(BPSTR)
N ZZ S ZZ=""
I LN=BPSMLEN Q BPSTR
I LN>BPSMLEN Q:BPSLFT $E(BPSTR,LN-BPSMLEN+1,9999) Q $E(BPSTR,1,BPSMLEN)
S $P(ZZ,BPSCHR,BPSMLEN-LN+1)=""
Q:BPSLFT ZZ_BPSTR
Q BPSTR_ZZ
;
;/**
;BP59 - ptr to 9002313.59
;output :
;ECME number from 9002313.02
; 7 or 12 digits of the prescription IEN file 52
; or 12 spaces
N BPST0,BPST4,PC,PF,PR,X
S BPST0=$G(^BPST(BP59,0)),PC=$P(BPST0,U,4),PF=$P(BPST0,U,9)
S BPST4=$G(^BPST(BP59,4)),PR=$P(BPST4,U,1)
I PR]"" S PC=PR ;This is a reversal
I PC=""!(PF="") Q $$FORMAT("",12," ",1)
S X=$P($G(^BPSC(PC,400,PF,400)),U,2)
I X="" Q $$FORMAT(X,12," ",1)
Q $E(X,3,14)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSSCRU2 8478 printed Oct 16, 2024@17:54:08 Page 2
BPSSCRU2 ;BHAM ISC/SS - ECME SCREEN UTILITIES ;05-APR-05
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1,3,5,10,11,20**;JUN 2004;Build 27
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;USER SCREEN
+4 QUIT
+5 ;/**
+6 ;Input:
+7 ; BP59 - pointer to file #9002313.59
+8 ;Output:
+9 ;get filling "location" like "WINDOW/LOCALMAIL/CMOP"
GETMWC(BP59) ;*/
+1 NEW BP1
SET BP1=$$RXREF(BP59)
+2 if +BP1=0
QUIT ""
+3 QUIT $$MWC($PIECE(BP1,U),$PIECE(BP1,U,2))
+4 ;
+5 ;initially this was designed to convert numbers to letters to display on the screen
+6 ;but later the Pharmacy designed API that returns letters instead of numbers
+7 ;so now this function just returns what it receives in its parameter, while it does not
+8 ;make any sense, we still keep it in order to prevent changes in other four routines:
+9 ; BPSREOP1, BPSSCR02, BPSSCR03, BPSSCR04
MWCNAME(BPMWC) ;
+1 QUIT BPMWC
+2 ;/**
+3 ;Input:
+4 ; BP59 - pointer to file #9002313.59
+5 ;Output:
+6 ;get RX pointer in file #52 and refill number in its multiple (0 - original refill)
RXREF(BP59) ;
+1 NEW BPRX,BPREF
+2 ;ptr to RX node in #52
SET BPRX=+$PIECE($GET(^BPST(BP59,1)),U,11)
+3 ;ptr to refill multiple in #52
SET BPREF=+$PIECE($GET(^BPST(BP59,1)),U)
+4 QUIT BPRX_U_BPREF
+5 ; determines if the refill was MAIL/WINDOW/CMOP
MWC(BPRX,BPREF) ;MAIL/WINDOW/CMOP
+1 ;input:
+2 ; BPRX ptr to #52 (RX)
+3 ; BPREF ptr to #52.1 (refills)
+4 ;return value:
+5 ; 2-MAIL/3-WINDOW/4-CMOP
+6 QUIT $$MWC^PSOBPSU2(BPRX,BPREF)
+7 ;
+8 ;
+9 ;/**
+10 ;Input:
+11 ; BP59 - pointer to file #9002313.59
+12 ;Output:
+13 ; insurance ien ^ name ^ phone
GETINSUR(BP59) ;get insurance info by the pointer of #9002313.59
+1 NEW BPHONE,BPINSNM,BPINSID,BP57,BPINSN,BPX
+2 SET BPX=$$NAMEPHON^BPSSCRU3(BP59)
+3 SET BPINSNM=$PIECE(BPX,U,1)
+4 SET BPHONE=$PIECE(BPX,U,2)
+5 ;Get a temporary ID for the insurance from ^TMP list of insurances.
+6 ;If doesn't exist yet then create a new record in ^TMP list of insurances
+7 ; for this insurance and return the ID for the record.
+8 ;A lifetime for ^TMP list of insurances is the time period the user is using
+9 ; the User Screen menu option
+10 SET BPINSID=$$CHKINSUR^BPSSCR(BPINSNM,BPHONE)
+11 IF $LENGTH(BPHONE)=0
SET BPHONE=" "
+12 IF $LENGTH(BPINSNM)=0
SET BPINSNM="?NODATA?"
+13 QUIT BPINSID_U_BPINSNM_U_BPHONE
+14 ;
+15 ;/**
+16 ;Input:
+17 ; BP59 - pointer to file #9002313.59
+18 ;Output:
+19 ;transaction date
TRANDT(BP59) ;
+1 QUIT $PIECE($GET(^BPST(BP59,0)),U,8)\1
+2 ;
+3 ;/**
+4 ;Input:
+5 ; BP59 - pointer to file #9002313.59
+6 ;Output:
+7 ;ECME pharmacy division (9002313.56)
DIVIS(BP59) ;
+1 QUIT $PIECE($GET(^BPST(BP59,1)),U,7)
+2 ;
+3 ;/**
+4 ;Input:
+5 ; BP59 - pointer to file #9002313.59
+6 ;Output:
+7 ;patient's DFN (file #2)
GETPATID(BP59) ;
+1 QUIT $PIECE($GET(^BPST(BP59,0)),U,6)
+2 ;
+3 ;return RX status as ACT/DIS/etc
RXST(BP59) ;
+1 NEW BPRXREF
+2 SET BPRXREF=$$RXREF^BPSSCRU2(BP59)
+3 ;display status ONLY if the refill is the most recent
+4 ;otherwise display blanks (three spaces for sorting purposes)
+5 IF +$PIECE(BPRXREF,U,2)'=(+$$LSTRFL^PSOBPSU1(+$PIECE(BPRXREF,U,1)))
QUIT "**"
+6 QUIT $$RXSTANAM($$RXSTATUS(+$PIECE(BPRXREF,U,1)))
+7 ;/**
+8 ;RX status
+9 ;Input
+10 ; RXNUM:
+11 ; ien of file #52 (if MODE=0)
+12 ; or RX number (if MODE=1)
+13 ;----------
+14 ;Output:
+15 ; 0 if not found
+16 ; status set#
RXSTATUS(RXNUM) ;*/
+1 NEW BPRET
+2 SET BPRET=$$RXAPI1^BPSUTIL1(RXNUM,100,"I")
+3 IF BPRET=""
QUIT -1
+4 QUIT BPRET
+5 ;/**
+6 ;if RX "valid"
RXACTIVE(BPRXSTAT) ;*/
+1 ; 0 not valid
+2 ; 1 valid (i.e. ACTIVE/NON-VERIFIED/REFILL/HOLD/DRUG INTERACTIONS/SUSPENDED)
+3 ; -1 doesn't exist
+4 ;active
if BPRXSTAT<6
QUIT 1
+5 ;/**
+6 ;RX status text
RXSTANAM(BPRXSTAT) ;*/
+1 ; ACTIVE;
if BPRXSTAT=0
QUIT "AC"
+2 ; NON-VERIFIED;
if BPRXSTAT=1
QUIT "NV"
+3 ; HOLD;
if BPRXSTAT=3
QUIT "HL"
+4 ; SUSPENDED;
if BPRXSTAT=5
QUIT "SU"
+5 ; EXPIRED;
if BPRXSTAT=11
QUIT "EX"
+6 ; DISCONTINUED;
if BPRXSTAT=12
QUIT "DS"
+7 ; DELETED;
if BPRXSTAT=13
QUIT "DL"
+8 ; DISCONTINUED BY PROVIDER;
if BPRXSTAT=14
QUIT "DS"
+9 ; DISCONTINUED (EDIT);
if BPRXSTAT=15
QUIT "DS"
+10 ; PROVIDER HOLD;
if BPRXSTAT=16
QUIT "HL"
+11 if BPRXSTAT=-1
QUIT "??"
+12 QUIT ""
+13 ;/**
+14 ;Input:
+15 ; BP59 - pointer to file #9002313.59
+16 ;Output:
+17 ;returns:
+18 ;>0 Released
+19 ;0 non released
+20 ;-1 error
ISRXREL(BP59) ;
+1 NEW BP1
+2 SET BP1=$$REFILINF(BP59)
+3 if BP1<0
QUIT -1
+4 ; i.e. it is non-released if there is no any release date
QUIT $PIECE(BP1,U,2)
+5 ;
+6 ;release status
RL(BP59) ;
+1 QUIT $SELECT($$ISRXREL(BP59)>0:"R",1:"N")
+2 ;/**
+3 ;get refill (including original refill) info by BP59
+4 ;Input:
+5 ; BP59 - pointer to file #9002313.59
+6 ;Output:
+7 ;returns:
+8 ;on error : "-1"
+9 ;on success : refill# ^ release date ^label print date ^ fill date ^ issue date
REFILINF(BP59) ;*/
+1 NEW BP1
SET BP1=$$RXREF(BP59)
+2 ;ptr to #52
NEW BPRX
SET BPRX=$PIECE(BP1,U,1)
+3 ;ptr in its refill multiple
NEW BPREF
SET BPREF=$PIECE(BP1,U,2)
+4 ;if bad data
IF BPREF
IF $$IFREFILL(BPRX,BPREF)=0
QUIT -1
+5 ;original refill
+6 IF BPREF=0
QUIT "0"_U_$$RXRELDT(BPRX)_U_U_$$RXFILDT(BPRX)_U_$$RXISSDT(BPRX)
+7 ;refill's release date
+8 IF BPREF>0
QUIT BPREF_U_$$REFRELDT(BPRX,BPREF)_U_U_$$REFFILDT(BPRX,BPREF)_U_$$REFISSDT(BPRX,BPREF)
+9 QUIT -1
+10 ;
+11 ;-Prescriptions-----------------------
+12 ;RX issue date
RXISSDT(BPRX) ;
+1 QUIT +$$RXAPI1^BPSUTIL1(BPRX,1,"I")
+2 ;
+3 ;RX's release date
RXRELDT(BPRX) ;
+1 QUIT +$$RXAPI1^BPSUTIL1(BPRX,31,"I")
+2 ;
+3 ;RX's fill date
RXFILDT(BPRX) ;
+1 QUIT +$$RXAPI1^BPSUTIL1(BPRX,22,"I")
+2 ;
+3 ;refill's release date
REFRELDT(BPRX,BPREF) ;
+1 QUIT +$$RXSUBF1^BPSUTIL1(BPRX,52,52.1,BPREF,17,"I")
+2 ;
+3 ;refill's refill date
REFFILDT(BPRX,BPREF) ;
+1 QUIT $$RXSUBF1^BPSUTIL1(BPRX,52,52.1,BPREF,.01,"I")
+2 ;
+3 ;refill's issue date
REFISSDT(BPRX,BPREF) ;
+1 QUIT $$REFDISDT(BPRX,BPREF)
+2 ;
+3 ;refill's dispense date
REFDISDT(BPRX,BPREF) ;
+1 QUIT $$RXSUBF1^BPSUTIL1(BPRX,52,52.1,BPREF,10.1,"I")
+2 ;
+3 ;if refill exists
IFREFILL(BPRX,BPREF) ;
+1 QUIT $$RXSUBF1^BPSUTIL1(BPRX,52,52.1,BPREF,.01,"I")'=""
+2 ;/**
+3 ;input
+4 ;ptr to 9002313.59
+5 ;output :
+6 ; BB - back billing
+7 ; P2 - PRO Option
+8 ; RS - ECME user screen resubmission (BPS*1*20)
+9 ; RT - all other values in (#1201) RX ACTION field on 9002313.59
RTBB(BP59) ;*/
+1 NEW BPTRBB
+2 SET BPTRBB=$PIECE($GET(^BPST(BP59,12)),U)
+3 IF BPTRBB=""
QUIT "**"
+4 IF BPTRBB="BB"
QUIT "BB"
+5 IF BPTRBB="P2"
QUIT "P2"
+6 IF BPTRBB="P2S"
QUIT "P2"
+7 ; ECME user screen resubmit (BPS*1*20)
IF BPTRBB="ERES"
QUIT "RS"
+8 ; ECME user screen resubmit/without reversal (BPS*1*20)
IF BPTRBB="ERWV"
QUIT "RS"
+9 ; ECME user screen resubmit TRI/CVA non-billable (BPS*1*20)
IF BPTRBB="ERNB"
QUIT "RS"
+10 QUIT "RT"
+11 ;
+12 ;------------ patient's name
PATNAME(BPDFN) ;
+1 QUIT $EXTRACT($PIECE($GET(^DPT(BPDFN,0)),U),1,15)
+2 ;
SSN4(DFN) ;last 4 SSN
+1 NEW X
+2 SET X=$PIECE($GET(^DPT(DFN,0)),U,9)
+3 QUIT "("_$EXTRACT(X,$LENGTH(X)-3,$LENGTH(X))_")"
+4 ;
+5 ;get drug generic name
DRGNAM(BP50) ;
+1 ;BP50 - ptr to #50
+2 QUIT $EXTRACT($$DRUGDIE^BPSUTIL1(BP50,.01,"E"),1,35)
+3 ;get drug
GETDRUG(BP52) ;
+1 ;return value:
+2 ; 0 - unknown
+3 ; n - ptr to DRUG file #50
+4 QUIT +$$RXAPI1^BPSUTIL1(BP52,6,"I")
+5 ;
GETDRG59(BP59) ;
+1 NEW BPX
+2 SET BPX=$$RXREF(BP59)
+3 QUIT $$GETDRUG(+BPX)
+4 ;
+5 ;
+6 ;review %% for each of claims in the array
+7 ;and calculate "overall" "done" status
+8 ;input:
+9 ; BPARR59 - array of ptr to #9002313.59
+10 ;output:
+11 ; status
FINISHST(BPARR59) ;
+1 NEW BPFIN,BP59
+2 SET BPFIN=1
SET BP59=0
+3 FOR
SET BP59=$ORDER(BPARR59(BP59))
if +BP59=0
QUIT
Begin DoDot:1
+4 IF $$PRCNTG^BPSSCRU3(BP59)<99
SET BPFIN=0
End DoDot:1
if BPFIN=0
QUIT
+5 IF BPFIN=1
QUIT "**FINISHED**"
+6 QUIT ""
+7 ;
+8 ;
+9 ;BPRX - ptr to #52
RXNUM(BPRX) ;
+1 QUIT $$RXAPI1^BPSUTIL1(BPRX,.01,"E")_$SELECT(+$$RXAPI1^BPSUTIL1(BPRX,105,"I"):"$",1:"")
+2 ;
+3 ;/**
+4 ;get NDC
+5 ;input
+6 ;BPRX - ptr to #52
+7 ;BPREF - refill # (0,1,2,3...)
NDC(BPRX,BPREF) ;*/
+1 NEW X
+2 ;remove dashes
SET X=$TRANSLATE($$GETNDC^PSONDCUT(BPRX,BPREF),"-","")
+3 QUIT X
+4 ;
DRGNAME(BP59) ;drug name BP59 -ptr to .59 file
+1 NEW BPRX
+2 ;ptr to RX node in #52
SET BPRX=+$PIECE($GET(^BPST(BP59,1)),U,11)
+3 QUIT $EXTRACT($$DRGNAM($$GETDRUG(BPRX)),1,23)
+4 ;
+5 ;is the number even?
+6 ;1-yes
+7 ;0 -no
ISEVEN(BPNUM) ;
+1 QUIT ((BPNUM/2)-(BPNUM\2))=0
+2 ;
+3 ;BPSTR - string to format
+4 ;BPSMLEN - max lenght
+5 ;BPSCHR - char to add
+6 ;BPSLFT - 1 - add from the left, 0 - from the right
FORMAT(BPSTR,BPSMLEN,BPSCHR,BPSLFT) ;
+1 NEW LN
SET LN=$LENGTH(BPSTR)
+2 NEW ZZ
SET ZZ=""
+3 IF LN=BPSMLEN
QUIT BPSTR
+4 IF LN>BPSMLEN
if BPSLFT
QUIT $EXTRACT(BPSTR,LN-BPSMLEN+1,9999)
QUIT $EXTRACT(BPSTR,1,BPSMLEN)
+5 SET $PIECE(ZZ,BPSCHR,BPSMLEN-LN+1)=""
+6 if BPSLFT
QUIT ZZ_BPSTR
+7 QUIT BPSTR_ZZ
+8 ;
+9 ;/**
+10 ;BP59 - ptr to 9002313.59
+11 ;output :
+12 ;ECME number from 9002313.02
+13 ; 7 or 12 digits of the prescription IEN file 52
+14 ; or 12 spaces
+1 NEW BPST0,BPST4,PC,PF,PR,X
+2 SET BPST0=$GET(^BPST(BP59,0))
SET PC=$PIECE(BPST0,U,4)
SET PF=$PIECE(BPST0,U,9)
+3 SET BPST4=$GET(^BPST(BP59,4))
SET PR=$PIECE(BPST4,U,1)
+4 ;This is a reversal
IF PR]""
SET PC=PR
+5 IF PC=""!(PF="")
QUIT $$FORMAT("",12," ",1)
+6 SET X=$PIECE($GET(^BPSC(PC,400,PF,400)),U,2)
+7 IF X=""
QUIT $$FORMAT(X,12," ",1)
+8 QUIT $EXTRACT(X,3,14)
