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

APSPRIS.m

Go to the documentation of this file. 
  1. APSPRIS ;IHS/MSC/PLS- Support for speed REISSUE ;10-Oct-2017 10:55;DU
  1.  ;;7.0;OUTPATIENT PHARMACY;**1015,1016,1021,1022**;DEC 1997;Build 20
  1. REISSUE ;speed REISSUE
  1.  K LST,PSORX("FILL DATE")
  1.  N APSPVAL
  1.  N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
  1.  K PSONEW,PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DIRUT)!($D(DTOUT))!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" Q
  1.  K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +Y S (SPEED,PSOOELSE)=1 D FULL^VALM1 S LST=Y D  G:$G(PSONEW("DFLG"))!($G(PSONEW("QFLG"))) REISSUEX
  1.  .;D ASKVAL(.APSPVAL)
  1.  .;Q:$G(APSPVAL("DFLG"))
  1.  .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""!($G(PSONEW("QFLG")))  S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52
  1.  ..I '$P($G(^PSRX($P(PSOLST(ORN),U,2),2)),U,15) D  Q
  1.  ...W !!,"This prescription has not been returned to stock and is not available for reissue."
  1.  ...D DIRZ^APSPUTIL("Press ENTER to exit")
  1.  ..I +$G(^PSRX($P(PSOLST(ORN),U,2),"STA"))'=0 D  Q
  1.  ...W !!,"This prescription lacks an Active status and is not available for reissue."
  1.  ...D DIRZ^APSPUTIL("Press ENTER to exit")
  1.  ..D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")),! D PAUSE^VALM1 K PSOMSG Q
  1.  ..I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")=11 D  D ULK Q
  1.  ...W $C(7),!!?5,"RX "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^")_" is in an EXPIRED status." W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR Q
  1.  ...D:$G(PSONEW("QFLG")) ULK
  1.  ..D RIS($P(PSOLST(ORN),U,2))
  1.  ..D ULK
  1.  S:'$G(PSOOELSE) VALMBCK=""
  1.  S PSORXED=1 D ^PSOBUILD,BLD^PSOORUT1
  1. REISSUEX D EX K PSOREF,PSORX("BAR CODE"),PSOLIST,LFD,MAX,MIN,NODE,PS,PSOERR,REF,RF,RXO,RXN,RXP,RXS,SD,VAERR,PSORX("FILL DATE")
  1.  K LST,SPEED,PSORXED,PSOREF,PSOFDR,PSOOELSE S:'$D(VALMBCK) VALMBCK="R"
  1.  K PSORX("FILL DATE"),PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
  1.  Q
  1.  ;
  1. ULK D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
  1.  Q
  1.  ;
  1. ULP D ULP^PSOHLD
  1.  Q
  1. RIS(DA) ;EP-
  1.  D FULL^VALM1 K DIR,DTOUT,DUOUT,DIRUT,PSLST,PSORXED
  1.  N RXREF,UPDATE,FLDS,CHGNDC,AO
  1.  N APSPRCHK,APSPRFLG S APSPRCHK=0,APSPRFLG=0
  1.  ;S DIE="^PSRX("
  1.  ;S DR="22///^S X=APSPVAL(""FILL DATE"");Q;"
  1.  ;D ^DIE
  1.  S PSORXED("IRXN")=DA
  1.  D ASKVAL(.PSORXED,DA)
  1.  Q:$G(PSORXED("DFLG"))
  1.  Q:'$$ESIG^APSPFUNC  ;P1016
  1.  ;S PSORXED("FLD",22)=PSORXED("FILL DATE")
  1.  D NDCCH(PSORXED("IRXN"))
  1.  D BLDFLD(.PSORXED)
  1.  S APSPREIS=1
  1.  ;IHS/MSC/MGH added from PSOORED6
  1.  I $D(^PSRX(PSORXED("IRXN"),1,0))  D
  1.  .S RXREF=$P(^PSRX(PSORXED("IRXN"),0),U,9)-$P(^PSRX(PSORXED("IRXN"),1,0),U,4)
  1.  E  S RXREF=0
  1.  S POERR=1
  1.  D UPDATE1^PSOORED6
  1.  ;P1021 - Call Suspend function if auto suspend is true
  1.  D CHKSUSP
  1.  ;I PSORXED("FILL DATE")>DT,$P(PSOPAR,U,6) D
  1.  ;.N DA,RXFL
  1.  ;.S DA=PSORXED("IRXN")
  1.  ;.S RXFL(DA)=0
  1.  ;.D SUS^PSORXL
  1.  D COSTSAVE(PSORXED("IRXN"),PSORXED("COST"))
  1.  D BCK1^PSORXRPT
  1.  M PSLST=LST
  1.  K ^PSRX(PSORXED("IRXN"),999999911)  ;1015-Remove PCC Link
  1.  ;IHS/MSC/MGH  added from PSODISPS
  1.  I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,?5,"Site Parameters must be defined to use the Release option!",! S VALMBCK="" Q
  1.  S VALMBCK="Q",Y=$G(^PS(59,PSOSITE,"IB")),PSOIBSS=$$SERV^IBARX1(+Y) I 'PSOIBSS D IBSSR^PSOUTL I 'PSOIBFL D  S VALMBCK="" G EX
  1.  .W $C(7),!!,"The IB SERVICE/SECTION defined in your site parameter file is not valid.",!,"You will not be able to release any medication until this is corrected!",!
  1.  W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2),RXP=$P(PSOLST($P(PSLST,",",ORD)),"^",2)
  1.  D OERR1^PSODISPS
  1.  Q
  1. EX ;D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
  1.  D ^PSOBUILD
  1.  K PSOHRL,PSOMSG,PSOPLCK,ST,PSL,PSNP,IR,NOW,DR,NEW1,NEW11,RTN,DA,PPL,RXN,RX0,RXS,DIK,RXP,FLD,ACT,DIE,DIC,DIR,DIE,X,Y,DIRUT,DUOUT,SUSPT,C,D0,LFD,I,PSDA,RFDATE,DI,DQ,%,RFN,XFLAG
  1.  K HRX,PSHLD,PSOLIST,PSORX("FILL DATE"),STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ Q
  1.  K PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
  1.  ;
  1.  ; Ask user for values
  1. ASKVAL(APSPVAL,RXIEN) ;EP-
  1.  N DATAARY,DIR,PSOID,PSOEDIT
  1.  S PSOEDIT=1
  1.  S (DATAARY("DFLG"),DATAARY("QFLG"))=0
  1.  S DATAARY("FIELD")=0
  1.  S DATAARY("DAYS SUPPLY")=$P($G(^PSRX(RXIEN,0)),U,8)
  1.  S DATAARY("# OF REFILLS")=$P($G(^PSRX(RXIEN,0)),U,9)
  1.  S PSOID=$P($G(^PSRX(RXIEN,0)),U,13)
  1.  S DATAARY("CS")=$$ISSCH^APSPFNC2($P($G(^PSRX(RXIEN,0)),U,6),"2345")
  1.  D PHNAME(.APSPVAL)   ;P1016
  1.  Q:APSPVAL("DFLG")=1  ;P1016
  1.  D FILLDT^PSODIR2(.DATAARY)
  1.  I $G(DATAARY("DFLG")) S APSPVAL("DFLG")=1 Q
  1.  S APSPVAL("FILL DATE")=DATAARY("FILL DATE")
  1.  D ASKNEWV(.DATAARY)  ;P1021
  1.  I $G(DATAARY("DFLG")) S APSPVAL("DFLG")=1 Q
  1.  I $D(DATAARY("MAIL/WINDOW")) S APSPVAL("MAIL/WINDOW")=DATAARY("MAIL/WINDOW")
  1.  I $D(DATAARY("EXPIRATION DATE")) S APSPVAL("EXPIRATION DATE")=DATAARY("EXPIRATION DATE")
  1.  I $D(DATAARY("BST")) S APSPVAL("BST")=DATAARY("BST")
  1.  I $D(DATAARY("NDC")) S APSPVAL("NDC")=DATAARY("NDC")
  1.  I $D(DATAARY("AWP")) S APSPVAL("AWP")=DATAARY("AWP")
  1.  I $D(DATAARY("COST")) S APSPVAL("COST")=DATAARY("COST")
  1.  I $D(DATAARY("INSURER")) S APSPVAL("INSURER")=DATAARY("INSURER")
  1.  I $D(DATAARY("DUR")) S APSPVAL("DUR")=DATAARY("DUR")
  1.  I $D(DATAARY("METHOD OF PICK-UP")) S APSPVAL("METHOD OF PICK-UP")=DATAARY("METHOD OF PICK-UP")
  1.  Q
  1.  ;
  1. ASKNEWV(DATAARY) ;EP - 03/28/2016
  1.  S DATAARY("MAIL/WINDOW")=$P($G(^PSRX(RXIEN,0)),U,11)
  1.  D MW^PSODIR2(.DATAARY)
  1.  Q:$G(DATAARY("DFLG"))
  1.  ;D CLERK^PSODIR2(.DATAARY)
  1.  ;Q:$G(DATAARY("DFLG"))
  1.  ;IHS/MSC/PLS - 10/10/2017 P1022 Changed to grab the drug expiration date field
  1.  ;S DATAARY("EXPIRATION DATE")=$P($G(^PSRX(RXIEN,2)),U,6)
  1.  S DATAARY("EXPIRATION DATE")=$P($G(^PSRX(RXIEN,2)),U,11)
  1.  D EXP^PSODIR2(.DATAARY)
  1.  Q:$G(DATAARY("DFLG"))
  1.  I $G(PSOBILST) D
  1.  .D BST^APSPDIR(.DATAARY)
  1.  .Q:$G(DATAARY("DFLG"))
  1.  .S DATAARY("INSURER")=$P($G(^PSRX(RXIEN,9999999)),U,12)
  1.  .S DATAARY("DUR")=$P($G(^PSRX(RXIEN,9999999)),U,13)
  1.  .D INSURER^APSPDIR(.DATAARY)
  1.  Q:$G(DATAARY("DFLG"))
  1.  I $G(PSONDC) D
  1.  .S DATAARY("NDC")=$P($G(^PSRX(RXIEN,2)),U,7)
  1.  .D NDC^APSPDIR(.DATAARY)
  1.  Q:$G(DATAARY("DFLG"))
  1.  S DATAARY("AWP")=$P($G(^PSRX(RXIEN,9999999)),U,6)
  1.  D AWP^APSPDIR(.DATAARY)
  1.  Q:$G(DATAARY("DFLG"))
  1.  S DATAARY("COST")=$P($G(^PSRX(RXIEN,0)),U,17)
  1.  D COST(.DATAARY)
  1.  Q
  1. PHNAME(APSPVAL) ;Get pharmacist
  1. PHNAME1 S APSPVAL("DFLG")=0
  1.  S DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))",DIC("A")="Enter PHARMACIST: ",DIC="^VA(200,",DIC(0)="QEAM"
  1.  D ^DIC G:$L(X)=0 PHNAME1 K DIC
  1.  I X="^"!($D(DTOUT))!($D(DUOUT))!($D(DIRUT))!(Y=-1) S APSPVAL("DFLG")=1
  1.  E  S PSRH=+Y
  1.  Q
  1. RI ;EP- Called from APSP REISSUE protocol
  1.  N POERR,PSORXED
  1.  N RXREF,UPDATE,FLDS,CHGNDC,APSPVAK,APSPVAL
  1.  N APSPRCHK,APSPRFLG S APSPRCHK=0,APSPRFLG=0
  1.  I +PSOLST(ORN)'=52 D  Q
  1.  .W !!,"A prescription entry was not selected."
  1.  .D DIRZ^APSPUTIL("Press ENTER to exit")
  1.  S PSORXED("IRXN")=$P(PSOLST(ORN),U,2)
  1.  I '$P($G(^PSRX(PSORXED("IRXN"),2)),U,15) D  Q
  1.  .W !!,"This order has not been returned to stock and is not available for reissue."
  1.  .D DIRZ^APSPUTIL("Press ENTER to exit")
  1.  I +$G(^PSRX(PSORXED("IRXN"),"STA"))'=0 D  Q
  1.  .W !!,"This prescription lacks an Active status and is not available for reissue."
  1.  .D DIRZ^APSPUTIL("Press ENTER to exit")
  1.  S PSORXED("DFLG")=0
  1.  D ASKVAL(.PSORXED,PSORXED("IRXN"))
  1.  ;D PHNAME(.APSPVAL)   ;p1016
  1.  ;I APSPVAL("DFLG") S VALMBCK="R" Q  ;P1016
  1.  ;D FILLDT^PSODIR2(.PSORXED)
  1.  I PSORXED("DFLG") S VALMBCK="R" Q
  1.  Q:'$$ESIG^APSPFUNC  ;P1016
  1.  D NDCCH($P(PSOLST(ORN),U,2))
  1.  D BLDFLD(.PSORXED)
  1.  S APSPREIS=1
  1.  ;IHS/MSC/MGH  added from PSOORED6
  1.  I $D(^PSRX(PSORXED("IRXN"),1,0))  D
  1.  .S RXREF=$P(^PSRX(PSORXED("IRXN"),0),"^",9)-$P(^PSRX(PSORXED("IRXN"),1,0),"^",4)
  1.  E  S RXREF=0
  1.  D UPDATE1^PSOORED6
  1.  D CHKSUSP
  1.  ;I PSORXED("FILL DATE")>DT,$P(PSOPAR,U,6) D
  1.  ;.N DA,RXFL
  1.  ;.S DA=PSORXED("IRXN")
  1.  ;.S RXFL(DA)=0
  1.  ;.D SUS^PSORXL
  1.  D COSTSAVE(PSORXED("IRXN"),PSORXED("COST"))
  1.  S POERR=1 D BCK1^PSORXRPT       ;P1016
  1.  K ^PSRX(PSORXED("IRXN"),999999911)  ;1015-Remove PCC Link
  1.  ;IHS/MSC/MGH Added from PSODISPS
  1.  I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,?5,"Site Parameters must be defined to use the Release option!",! S VALMBCK="" Q
  1.  S VALMBCK="Q",Y=$G(^PS(59,PSOSITE,"IB")),PSOIBSS=$$SERV^IBARX1(+Y) I 'PSOIBSS D IBSSR^PSOUTL I 'PSOIBFL D  S VALMBCK="" G EX
  1.  .W $C(7),!!,"The IB SERVICE/SECTION defined in your site parameter file is not valid.",!,"You will not be able to release any medication until this is corrected!",!
  1.  W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2),RXP=$P(PSOLST($P(PSLST,",",ORD)),"^",2)
  1.  D OERR1^PSODISPS
  1.  Q
  1. NDCCH(RX) ;Check and see if the NDC changed since RX written
  1.  N RXDRG,RXNDC,DRNDC,AWP,COST,FDA,ERR,MESS
  1.  S DRNDC=""
  1.  S RXDRG=$$GET1^DIQ(52,RX,6,"I")
  1.  S RXNDC=$$GET1^DIQ(52,RX,27,"I")
  1.  I +RXDRG S DRNDC=$$GET1^DIQ(50,RXDRG,31,"I")
  1.  ;NDC code has changed, then update the cost as well.
  1.  I RXNDC'=DRNDC D
  1.  .S AWP=$$AWP^APSQDAWP(DRNDC,RXDRG,.MESS)
  1.  .S COST=$$COST^APSQDAWP(DRNDC,RXDRG,.MESS)
  1.  .S FDA=$NA(FDA(52,RX_","))
  1.  .S @FDA@(27)=DRNDC
  1.  .S @FDA@(17)=COST
  1.  .S @FDA@(9999999.06)=AWP
  1.  .D UPDATE^DIE(,"FDA",,"ERR")
  1.  Q
  1. BLDFLD(ARY) ;EP-
  1.  S:$D(ARY("FILL DATE")) ARY("FLD",22)=ARY("FILL DATE")
  1.  S:$D(ARY("MAIL/WINDOW")) ARY("FLD",11)=ARY("MAIL/WINDOW")
  1.  S:$D(ARY("METHOD OF PICK-UP")) ARY("FLD",35)=ARY("METHOD OF PICK-UP")
  1.  S:$D(ARY("AWP")) ARY("FLD",9999999.06)=ARY("AWP")
  1.  S:$D(ARY("COST")) ARY("FLD",17)=ARY("COST")
  1.  ;IHS/MSC/PLS - 10/2/2017 - P1022
  1.  ;S:$D(ARY("EXPIRATION DATE")) ARY("FLD",26)=ARY("EXPIRATION DATE")
  1.  S:$D(ARY("EXPIRATION DATE")) ARY("FLD",29)=ARY("EXPIRATION DATE")
  1.  S:$D(ARY("NDC")) ARY("FLD",27)=ARY("NDC")
  1.  S:$D(ARY("BST")) ARY("FLD",9999999.07)=ARY("BST")
  1.  S:$D(ARY("DUR")) ARY("FLD",9999999.13)=ARY("DUR")
  1.  S:$D(ARY("INSURER")) ARY("FLD",9999999.12)=ARY("INSURER")
  1.  Q
  1. COST(PSODIR) ;EP-
  1.  N DIR,DIC,U
  1.  S DIR(0)="52,17"
  1.  S DIR("A")="UNIT PRICE OF DRUG"
  1.  S DIR("B")=$S($D(PSODIR("COST")):PSODIR("COST"),1:0)
  1.  D DIR^PSODIR1
  1.  I 'PSODIR("DFLG") S PSODIR("COST")=Y
  1.  Q
  1. COSTSAVE(RX,VAL) ;EP- Update UNIT PRICE OF DRUG field based on user input
  1.  N DA,DIE,X,DR,DIR
  1.  S DA=RX
  1.  S DIE="^PSRX("
  1.  S DR="17////"_VAL
  1.  D ^DIE
  1.  Q
  1. CHKSUSP ;EP-P1021 - Call Suspend function if auto suspend is true
  1.  I PSORXED("FILL DATE")>DT,$P(PSOPAR,U,6) D
  1.  .N DA,RXFL
  1.  .S DA=PSORXED("IRXN")
  1.  .S RXFL(DA)=0
  1.  .D SUS^PSORXL
  1.  Q