PSOBPSU2 ;BIRM/MFR - BPS (ECME) Utilities 2 ;10/15/04
;;7.0;OUTPATIENT PHARMACY;**260,287,289**;DEC 1997;Build 107
;Reference to File 200 - NEW PERSON supported by IA 10060
;Reference to DUR1^BPSNCPD3 supported by IA 4560
;Reference to $$NCPDPQTY^PSSBPSUT supported by IA 4992
;
MWC(RX,RFL) ; Returns whether a prescription is (M)ail, (W)indow or (C)MOP
;Input: (r) RX - Rx IEN (#52)
; (o) RFL - Refill # (Default: most recent)
;Output: "M": MAIL / "W": WINDOW / "C": CMOP
;
N MWC
;
I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
;
; - MAIL/WINDOW fields (Original and Refill)
I RFL S MWC=$$GET1^DIQ(52.1,RFL_","_RX,2,"I")
E S MWC=$$GET1^DIQ(52,RX,11,"I")
S:MWC="" MWC="W"
;
; - Checking the RX SUSPENSE file (#52.5)
I $$GET1^DIQ(52,RX,100,"I")=5 D
. N RXS S RXS=+$O(^PS(52.5,"B",RX,0)) Q:'RXS
. I $$GET1^DIQ(52.5,RXS,3,"I")'="" S MWC="C" Q
. S MWC="M"
;
; - Checking the CMOP EVENT sub-file (#52.01)
I MWC'="C" D
. N CMP S CMP=0
. F S CMP=$O(^PSRX(RX,4,CMP)) Q:'CMP D I MWC="C" Q
. . I $$GET1^DIQ(52.01,CMP_","_RX,2,"I")=RFL S MWC="C"
;
Q MWC
;
RXACT(RX,RFL,COMM,TYPE,USR) ; - Add an Activity to the ECME Activity Log (PRESCRIPTION file)
;Input: (r) RX - Rx IEN (#52)
; (o) RFL - Refill # (Default: most recent)
; (r) COMM - Comments (up to 75 characters)
; (r) TYPE - Comments type: (M-ECME,E-Edit, etc...) See file #52 DD for all values
; (o) USR - User logging the comments (Default: DUZ)
;
S:'$D(RFL) RFL=$$LSTRFL^PSOBPSU1(RX) S:'$D(USR) USR=DUZ
S:'$D(^VA(200,+USR,0)) USR=DUZ S COMM=$E($G(COMM),1,75)
;
I COMM="" Q
I '$D(^PSRX(RX)) Q
;
N PSOTRIC S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,PSOTRIC)
I $E(COMM,1,7)'="TRICARE",PSOTRIC S COMM=$E("TRICARE-"_COMM,1,75)
N X,DIC,DA,DD,DO,DR,DINUM,Y,DLAYGO
S DA(1)=RX,DIC="^PSRX("_RX_",""A"",",DLAYGO=52.3,DIC(0)="L"
S DIC("DR")=".02///"_TYPE_";.03////"_USR_";.04///"_$S(TYPE'="M"&(RFL>5):RFL+1,1:RFL)_";.05///"_COMM
S X=$$NOW^XLFDT() D FILE^DICN
Q
;
N ECMENUM,STS,RF
S ECMENUM=$E(10000000+RX,2,8)
S STS=$$STATUS^PSOBPSUT(RX,0)
I STS="" D
. S RF=0 F S RF=$O(^PSRX(RX,RF)) Q:'RF D I STS'="" Q
. . S STS=$$STATUS^PSOBPSUT(RX,RF)
I STS="" Q ""
Q ECMENUM
;
RXNUM(ECME) ; Returns the Rx number for a specific ECME number
;
N RXNUM,FOUND,MAX,LFT,RAD,I,DIR,RX
S MAX=$O(^PSRX(999999999999),-1),LFT=0 I $L(MAX)>7 S LFT=$E(MAX,1,$L(MAX)-7)
S FOUND=0
F RAD=LFT:-1:0 D
. S RX=RAD*10000000+ECME I $D(^PSRX(RX,0)),$$ECMENUM(RX)=ECME S FOUND=FOUND+1,FOUND(FOUND)=RX
;
I FOUND<2 D
. I FOUND=0 S FOUND=-1 Q
. S FOUND=FOUND(1)
E D
. W ! F I=1:1:FOUND W !?5,I,". ",$$GET1^DIQ(52,FOUND(I),.01),?25,$$GET1^DIQ(52,FOUND(I),6)
. W ! S DIR(0)="NA^1:"_FOUND,DIR("A")="Select one: ",DIR("B")=1
. D ^DIR I $D(DIRUT) S FOUND=-1 Q
. S FOUND=FOUND(Y)
;
Q FOUND
;
ELIG(RX,RFL,PSOELIG) ;Stores eligibility flag
N DA,DIE,X,Y,PSOTRIC
I RFL=0 S DA=RX,DIE="^PSRX(",DR="85///"_PSOELIG D ^DIE
E S DA=RFL,DA(1)=RX,DIE="^PSRX("_DA(1)_",1,",DR="85///"_PSOELIG D ^DIE
Q
;
;Description:
;Input: RX = Prescription file #52 IEN
; RFL = Refill number
;Returns: A value of 0 (zero) will be returned when reject codes M6, M8,
;NN, and 99 are present OR if on susp hold which means the prescription should not
;be printed from suspense. Otherwise, a value of 1(one) will be returned.
DUR(RX,RFL) ;
N REJ,IDX,TXT,CODE,SHOLD,SHCODE,SHDT
S SHOLD=1,IDX=""
I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
S SHDT=$$SHDT(RX,RFL) ; Get suspense hold date for rx/refill
; Add one day to compare to prevent from running just after midnight problem.
I SHDT>$$FMADD^XLFDT(DT,1) Q 0 ; Quit with 0 since still on hold
D DUR1^BPSNCPD3(RX,RFL,.REJ) ; Get reject list from last submission
F S IDX=$O(REJ(IDX)) Q:IDX="" D Q:'SHOLD
. S TXT=$G(REJ(IDX,"REJ CODE LST"))
. F I=1:1:$L(TXT,",") S CODE=$P(TXT,",",I) D Q:'SHOLD
. . F SHCODE="M6","M8","NN",99 D Q:'SHOLD
. . . I CODE=SHCODE D
. . . . I SHDT="" S SHOLD=0 D SHDTLOG(RX,RFL) Q ; No previous Susp Hold Date or log entry - Create it.
Q SHOLD
;
;Description: This subroutine sets the EPHARMACY SUSPENSE HOLD DATE field
;for the rx or refill to tomorrow and adds an entry to the SUSPENSE Activity Log.
;Input: RX = Prescription File IEN
; RFL = Refill
SHDTLOG(RX,RFL) ;
N DA,DIE,DR,COMM,SHDT
I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
S SHDT=$$FMADD^XLFDT(DT,1)
S COMM="SUSPENSE HOLD until "_$$FMTE^XLFDT(SHDT,"2D")_" due to host reject error."
I RFL=0 S DA=RX,DIE="^PSRX(",DR="86///"_SHDT D ^DIE
E S DA=RFL,DA(1)=RX,DIE="^PSRX("_DA(1)_",1,",DR="86///"_SHDT D ^DIE
D RXACT(RX,RFL,COMM,"S",+$G(DUZ)) ; Create Activity Log entry
Q
;
;Description: This function returns the EPHARMACY SUSPENSE HOLD DATE field
;for the rx or refill
;Input: RX = Prescription File IEN
; RFL = Refill
SHDT(RX,RFL) ;
N FILE,IENS
I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
S FILE=$S(RFL=0:52,1:52.1),IENS=$S(RFL=0:RX_",",1:RFL_","_RX_",")
Q $$GET1^DIQ(FILE,IENS,86,"I")
;
ELOG(RESP) ; - due to size of PSOBPSU1 exceeding limit
; -Logs an ECME Activity Log if Rx Qty is different than Billing Qty
I '$G(RESP),$T(NCPDPQTY^PSSBPSUT)'="" D
. N DRUG,RXQTY,BLQTY,BLDU,Z
. S DRUG=$$GET1^DIQ(52,RX,6,"I")
. S RXQTY=$S('RFL:$$GET1^DIQ(52,RX,7,"I"),1:$$GET1^DIQ(52.1,RFL_","_RX,1))/1
. S Z=$$NCPDPQTY^PSSBPSUT(DRUG,RXQTY),BLQTY=Z/1,BLDU=$P(Z,"^",2)
. I RXQTY'=BLQTY D
. . D RXACT(RX,RFL,"BILLING QUANTITY submitted: "_$J(BLQTY,0,$L($P(BLQTY,".",2)))_" ("_BLDU_")","M",DUZ)
Q
;
UPDFL(RXREC,SUB,INDT) ;update fill date with release date when NDC changes at CMOP and OPAI auto-release
;Input: RXREC = Prescription File IEN
; SUB = Refill
; INDT = Release date
N DA,DIE,DR,PSOX,SFN,DEAD,SUB,XOK,OLD,X,II,EXDAT,OFILLD,COM,CNT,RFCNT,RF
S DEAD=0,SFN=""
S EXDAT=INDT I EXDAT["." S EXDAT=$P(EXDAT,".")
I '$D(SUB) S SUB=0 F II=0:0 S II=$O(^PSRX(RXREC,1,II)) Q:'II S SUB=+II
I 'SUB S OFILLD=$$GET1^DIQ(52,RXREC,22,"I") Q:OFILLD=EXDAT D
.S (X,OLD)=$P(^PSRX(RXREC,2),"^",2),DA=RXREC,DR="22///"_EXDAT_";101///"_EXDAT,DIE=52
.D ^DIE K DIE,DA
I SUB S (OLD,X)=+$P($G(^PSRX(RXREC,1,SUB,0)),"^"),DA(1)=RXREC,DA=SUB,OFILLD=$$GET1^DIQ(52.1,DA_","_RXREC,.01,"I") Q:OFILLD=EXDAT D
. S DIE="^PSRX("_DA(1)_",1,",DR=".01///"_EXDAT D ^DIE K DIE S $P(^PSRX(RXREC,3),"^")=EXDAT
Q:$D(DTOUT)!($D(DUOUT))
S DA=RXREC
D AREC^PSOSUCH1
FIN ;
Q
PSOBPSU2 ;BIRM/MFR - BPS (ECME) Utilities 2 ;10/15/04
+1 ;;7.0;OUTPATIENT PHARMACY;**260,287,289**;DEC 1997;Build 107
+2 ;Reference to File 200 - NEW PERSON supported by IA 10060
+3 ;Reference to DUR1^BPSNCPD3 supported by IA 4560
+4 ;Reference to $$NCPDPQTY^PSSBPSUT supported by IA 4992
+5 ;
MWC(RX,RFL) ; Returns whether a prescription is (M)ail, (W)indow or (C)MOP
+1 ;Input: (r) RX - Rx IEN (#52)
+2 ; (o) RFL - Refill # (Default: most recent)
+3 ;Output: "M": MAIL / "W": WINDOW / "C": CMOP
+4 ;
+5 NEW MWC
+6 ;
+7 IF '$DATA(RFL)
SET RFL=$$LSTRFL^PSOBPSU1(RX)
+8 ;
+9 ; - MAIL/WINDOW fields (Original and Refill)
+10 IF RFL
SET MWC=$$GET1^DIQ(52.1,RFL_","_RX,2,"I")
+11 IF '$TEST
SET MWC=$$GET1^DIQ(52,RX,11,"I")
+12 IF MWC=""
SET MWC="W"
+13 ;
+14 ; - Checking the RX SUSPENSE file (#52.5)
+15 IF $$GET1^DIQ(52,RX,100,"I")=5
Begin DoDot:1
+16 NEW RXS
SET RXS=+$ORDER(^PS(52.5,"B",RX,0))
IF 'RXS
QUIT
+17 IF $$GET1^DIQ(52.5,RXS,3,"I")'=""
SET MWC="C"
QUIT
+18 SET MWC="M"
End DoDot:1
+19 ;
+20 ; - Checking the CMOP EVENT sub-file (#52.01)
+21 IF MWC'="C"
Begin DoDot:1
+22 NEW CMP
SET CMP=0
+23 FOR
SET CMP=$ORDER(^PSRX(RX,4,CMP))
IF 'CMP
QUIT
Begin DoDot:2
+24 IF $$GET1^DIQ(52.01,CMP_","_RX,2,"I")=RFL
SET MWC="C"
End DoDot:2
IF MWC="C"
QUIT
End DoDot:1
+25 ;
+26 QUIT MWC
+27 ;
RXACT(RX,RFL,COMM,TYPE,USR) ; - Add an Activity to the ECME Activity Log (PRESCRIPTION file)
+1 ;Input: (r) RX - Rx IEN (#52)
+2 ; (o) RFL - Refill # (Default: most recent)
+3 ; (r) COMM - Comments (up to 75 characters)
+4 ; (r) TYPE - Comments type: (M-ECME,E-Edit, etc...) See file #52 DD for all values
+5 ; (o) USR - User logging the comments (Default: DUZ)
+6 ;
+7 IF '$DATA(RFL)
SET RFL=$$LSTRFL^PSOBPSU1(RX)
IF '$DATA(USR)
SET USR=DUZ
+8 IF '$DATA(^VA(200,+USR,0))
SET USR=DUZ
SET COMM=$EXTRACT($GET(COMM),1,75)
+9 ;
+10 IF COMM=""
QUIT
+11 IF '$DATA(^PSRX(RX))
QUIT
+12 ;
+13 NEW PSOTRIC
SET PSOTRIC=""
SET PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,PSOTRIC)
+14 IF $EXTRACT(COMM,1,7)'="TRICARE"
IF PSOTRIC
SET COMM=$EXTRACT("TRICARE-"_COMM,1,75)
+15 NEW X,DIC,DA,DD,DO,DR,DINUM,Y,DLAYGO
+16 SET DA(1)=RX
SET DIC="^PSRX("_RX_",""A"","
SET DLAYGO=52.3
SET DIC(0)="L"
+17 SET DIC("DR")=".02///"_TYPE_";.03////"_USR_";.04///"_$SELECT(TYPE'="M"&(RFL>5):RFL+1,1:RFL)_";.05///"_COMM
+18 SET X=$$NOW^XLFDT()
DO FILE^DICN
+19 QUIT
+20 ;
+1 NEW ECMENUM,STS,RF
+2 SET ECMENUM=$EXTRACT(10000000+RX,2,8)
+3 SET STS=$$STATUS^PSOBPSUT(RX,0)
+4 IF STS=""
Begin DoDot:1
+5 SET RF=0
FOR
SET RF=$ORDER(^PSRX(RX,RF))
IF 'RF
QUIT
Begin DoDot:2
+6 SET STS=$$STATUS^PSOBPSUT(RX,RF)
End DoDot:2
IF STS'=""
QUIT
End DoDot:1
+7 IF STS=""
QUIT ""
+8 QUIT ECMENUM
+9 ;
RXNUM(ECME) ; Returns the Rx number for a specific ECME number
+1 ;
+2 NEW RXNUM,FOUND,MAX,LFT,RAD,I,DIR,RX
+3 SET MAX=$ORDER(^PSRX(999999999999),-1)
SET LFT=0
IF $LENGTH(MAX)>7
SET LFT=$EXTRACT(MAX,1,$LENGTH(MAX)-7)
+4 SET FOUND=0
+5 FOR RAD=LFT:-1:0
Begin DoDot:1
+6 SET RX=RAD*10000000+ECME
IF $DATA(^PSRX(RX,0))
IF $$ECMENUM(RX)=ECME
SET FOUND=FOUND+1
SET FOUND(FOUND)=RX
End DoDot:1
+7 ;
+8 IF FOUND<2
Begin DoDot:1
+9 IF FOUND=0
SET FOUND=-1
QUIT
+10 SET FOUND=FOUND(1)
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 WRITE !
FOR I=1:1:FOUND
WRITE !?5,I,". ",$$GET1^DIQ(52,FOUND(I),.01),?25,$$GET1^DIQ(52,FOUND(I),6)
+13 WRITE !
SET DIR(0)="NA^1:"_FOUND
SET DIR("A")="Select one: "
SET DIR("B")=1
+14 DO ^DIR
IF $DATA(DIRUT)
SET FOUND=-1
QUIT
+15 SET FOUND=FOUND(Y)
End DoDot:1
+16 ;
+17 QUIT FOUND
+18 ;
ELIG(RX,RFL,PSOELIG) ;Stores eligibility flag
+1 NEW DA,DIE,X,Y,PSOTRIC
+2 IF RFL=0
SET DA=RX
SET DIE="^PSRX("
SET DR="85///"_PSOELIG
DO ^DIE
+3 IF '$TEST
SET DA=RFL
SET DA(1)=RX
SET DIE="^PSRX("_DA(1)_",1,"
SET DR="85///"_PSOELIG
DO ^DIE
+4 QUIT
+5 ;
+6 ;Description:
+7 ;Input: RX = Prescription file #52 IEN
+8 ; RFL = Refill number
+9 ;Returns: A value of 0 (zero) will be returned when reject codes M6, M8,
+10 ;NN, and 99 are present OR if on susp hold which means the prescription should not
+11 ;be printed from suspense. Otherwise, a value of 1(one) will be returned.
DUR(RX,RFL) ;
+1 NEW REJ,IDX,TXT,CODE,SHOLD,SHCODE,SHDT
+2 SET SHOLD=1
SET IDX=""
+3 IF '$DATA(RFL)
SET RFL=$$LSTRFL^PSOBPSU1(RX)
+4 ; Get suspense hold date for rx/refill
SET SHDT=$$SHDT(RX,RFL)
+5 ; Add one day to compare to prevent from running just after midnight problem.
+6 ; Quit with 0 since still on hold
IF SHDT>$$FMADD^XLFDT(DT,1)
QUIT 0
+7 ; Get reject list from last submission
DO DUR1^BPSNCPD3(RX,RFL,.REJ)
+8 FOR
SET IDX=$ORDER(REJ(IDX))
IF IDX=""
QUIT
Begin DoDot:1
+9 SET TXT=$GET(REJ(IDX,"REJ CODE LST"))
+10 FOR I=1:1:$LENGTH(TXT,",")
SET CODE=$PIECE(TXT,",",I)
Begin DoDot:2
+11 FOR SHCODE="M6","M8","NN",99
Begin DoDot:3
+12 IF CODE=SHCODE
Begin DoDot:4
+13 ; No previous Susp Hold Date or log entry - Create it.
IF SHDT=""
SET SHOLD=0
DO SHDTLOG(RX,RFL)
QUIT
End DoDot:4
End DoDot:3
IF 'SHOLD
QUIT
End DoDot:2
IF 'SHOLD
QUIT
End DoDot:1
IF 'SHOLD
QUIT
+14 QUIT SHOLD
+15 ;
+16 ;Description: This subroutine sets the EPHARMACY SUSPENSE HOLD DATE field
+17 ;for the rx or refill to tomorrow and adds an entry to the SUSPENSE Activity Log.
+18 ;Input: RX = Prescription File IEN
+19 ; RFL = Refill
SHDTLOG(RX,RFL) ;
+1 NEW DA,DIE,DR,COMM,SHDT
+2 IF '$DATA(RFL)
SET RFL=$$LSTRFL^PSOBPSU1(RX)
+3 SET SHDT=$$FMADD^XLFDT(DT,1)
+4 SET COMM="SUSPENSE HOLD until "_$$FMTE^XLFDT(SHDT,"2D")_" due to host reject error."
+5 IF RFL=0
SET DA=RX
SET DIE="^PSRX("
SET DR="86///"_SHDT
DO ^DIE
+6 IF '$TEST
SET DA=RFL
SET DA(1)=RX
SET DIE="^PSRX("_DA(1)_",1,"
SET DR="86///"_SHDT
DO ^DIE
+7 ; Create Activity Log entry
DO RXACT(RX,RFL,COMM,"S",+$GET(DUZ))
+8 QUIT
+9 ;
+10 ;Description: This function returns the EPHARMACY SUSPENSE HOLD DATE field
+11 ;for the rx or refill
+12 ;Input: RX = Prescription File IEN
+13 ; RFL = Refill
SHDT(RX,RFL) ;
+1 NEW FILE,IENS
+2 IF '$DATA(RFL)
SET RFL=$$LSTRFL^PSOBPSU1(RX)
+3 SET FILE=$SELECT(RFL=0:52,1:52.1)
SET IENS=$SELECT(RFL=0:RX_",",1:RFL_","_RX_",")
+4 QUIT $$GET1^DIQ(FILE,IENS,86,"I")
+5 ;
ELOG(RESP) ; - due to size of PSOBPSU1 exceeding limit
+1 ; -Logs an ECME Activity Log if Rx Qty is different than Billing Qty
+2 IF '$GET(RESP)
IF $TEXT(NCPDPQTY^PSSBPSUT)'=""
Begin DoDot:1
+3 NEW DRUG,RXQTY,BLQTY,BLDU,Z
+4 SET DRUG=$$GET1^DIQ(52,RX,6,"I")
+5 SET RXQTY=$SELECT('RFL:$$GET1^DIQ(52,RX,7,"I"),1:$$GET1^DIQ(52.1,RFL_","_RX,1))/1
+6 SET Z=$$NCPDPQTY^PSSBPSUT(DRUG,RXQTY)
SET BLQTY=Z/1
SET BLDU=$PIECE(Z,"^",2)
+7 IF RXQTY'=BLQTY
Begin DoDot:2
+8 DO RXACT(RX,RFL,"BILLING QUANTITY submitted: "_$JUSTIFY(BLQTY,0,$LENGTH($PIECE(BLQTY,".",2)))_" ("_BLDU_")","M",DUZ)
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
UPDFL(RXREC,SUB,INDT) ;update fill date with release date when NDC changes at CMOP and OPAI auto-release
+1 ;Input: RXREC = Prescription File IEN
+2 ; SUB = Refill
+3 ; INDT = Release date
+4 NEW DA,DIE,DR,PSOX,SFN,DEAD,SUB,XOK,OLD,X,II,EXDAT,OFILLD,COM,CNT,RFCNT,RF
+5 SET DEAD=0
SET SFN=""
+6 SET EXDAT=INDT
IF EXDAT["."
SET EXDAT=$PIECE(EXDAT,".")
+7 IF '$DATA(SUB)
SET SUB=0
FOR II=0:0
SET II=$ORDER(^PSRX(RXREC,1,II))
IF 'II
QUIT
SET SUB=+II
+8 IF 'SUB
SET OFILLD=$$GET1^DIQ(52,RXREC,22,"I")
IF OFILLD=EXDAT
QUIT
Begin DoDot:1
+9 SET (X,OLD)=$PIECE(^PSRX(RXREC,2),"^",2)
SET DA=RXREC
SET DR="22///"_EXDAT_";101///"_EXDAT
SET DIE=52
+10 DO ^DIE
KILL DIE,DA
End DoDot:1
+11 IF SUB
SET (OLD,X)=+$PIECE($GET(^PSRX(RXREC,1,SUB,0)),"^")
SET DA(1)=RXREC
SET DA=SUB
SET OFILLD=$$GET1^DIQ(52.1,DA_","_RXREC,.01,"I")
IF OFILLD=EXDAT
QUIT
Begin DoDot:1
+12 SET DIE="^PSRX("_DA(1)_",1,"
SET DR=".01///"_EXDAT
DO ^DIE
KILL DIE
SET $PIECE(^PSRX(RXREC,3),"^")=EXDAT
End DoDot:1
+13 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+14 SET DA=RXREC
+15 DO AREC^PSOSUCH1
FIN ;
+1 QUIT
