Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOBPSU2

PSOBPSU2.m

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