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

PSOUTL.m

Go to the documentation of this file. 
  1. PSOUTL ;BHAM ISC/SAB - pso utility routine ;29-May-2012 15:16;PLS
  1.  ;;7.0;OUTPATIENT PHARMACY;**1,21,126,1006,1011,174,218,259,1015**;DEC 1997;Build 62
  1.  ;External reference SERV^IBARX1 supported by DBIA 2245
  1.  ;External reference ^PS(55,     supported by DBIA 2228
  1.  ;
  1.  ;*218 prevent refill from being deleted if pending processing via
  1.  ; external dispense machines
  1.  ;*259 reverse *218 restrictions & Add del only last refill logic.
  1.  ; Modified - IHS/MSC/PLS - 02/21/08 - Line ECAN+7 commented out
  1.  ;                          04/30/08 - Line CAN+7 commented out
  1.  ;                          03/28/11 - Line CID+1,CIDH, CIDADJ (new EP)
  1. SUSPCAN ;dcl rx from suspense used in new, renew AND verification of Rxs
  1.  S PSLAST=0 F PSI=0:0 S PSI=$O(^PSRX(PSRX,1,PSI)) Q:'PSI  S PSLAST=PSI
  1.  I PSLAST S PSI=^PSRX(PSRX,1,PSLAST,0) K ^PSRX(PSRX,1,PSLAST),^PSRX(PSRX,1,"B",+PSI,PSLAST) S ^(0)=$P(^PSRX(PSRX,1,0),"^",1,3)_"^"_($P(^(0),"^",4)-1) K PSLAST,PSI,SUSX,SUS1,SUS2 Q
  1.  S $P(^PSRX(PSRX,3),"^",7)="DISCONTINUED FROM SUSPENSE BEFORE FILLING" K PSI,SUSX,SUS1,SUS2 Q
  1.  ;
  1. ACTLOG ;
  1.  F PSI=0:0 S PSI=$O(^PSRX(PSRX,"A",PSI)) I 'PSI!'$O(^(PSI)) S ^PSRX(PSRX,"A",+PSI+1,0)=DT_"^"_PSREA_"^"_PSOCLC_"^"_PSRXREF_"^"_PSMSG,^PSRX(PSRX,"A",0)="^52.3DA^"_(+PSI+1)_"^"_(+PSI+1) Q
  1. ACTOUT I PSREA="C" S PSI=$S($D(^PSRX(PSRX,2)):+$P(^(2),"^",6),1:0) K:$D(^PS(55,PSDFN,"P","A",PSI,PSRX)) ^(PSRX) S ^PS(55,PSDFN,"P","A",DT,PSRX)="" Q
  1.  I PSREA="R" F PSI=0:0 S PSI=$O(^PSRX(PSRX,"A",PSI)) Q:'PSI  I $D(^(PSI,0)),$P(^(0),"^",2)="C" S PSS=+^(0)
  1.  I $D(PSS),PSS K:$D(^PS(55,PSDFN,"P","A",PSS,PSRX)) ^(PSRX)
  1.  I PSREA="R",$D(^PSRX(PSRX,2))#2 S ^PS(55,PSDFN,"P","A",+$P(^PSRX(PSRX,2),"^",6),PSRX)=""
  1.  Q
  1.  ;
  1. QUES ;INSTRUCTIONS FOR RENEW AND REFILL
  1.  W !?5,"Enter the item #(s) or RX #(s) you wish to ",$S(PSFROM="N":"renew ",PSFROM="R":"REFILL "),"separated by commas."
  1.  W !?5,"For example: 1,2,5 or 123456,33254A,232323B."
  1.  W !?5,"Do not enter the same number twice, duplicates are not allowed."
  1.  Q
  1. ENDVCHK S PSOPOP=0 Q:'PSODIV  Q:'$P(^PSRX(PSRX,2),"^",9)!($P(^(2),"^",9)=PSOSITE)
  1. CHK1 I '$P(PSOSYS,"^",2) W !?10,$C(7),"RX# ",$P(^PSRX(PSRX,0),"^")," is not a valid choice. (Different Division)" S PSPOP=1 Q
  1.  I $P(PSOSYS,"^",3) W !?10,$C(7),"RX# ",$P(^PSRX(PSRX,0),"^")," is from another division. Continue? (Y/N) " R ANS:DTIME I ANS="^"!(ANS="") S PSPOP=1 Q
  1.  I (ANS']"")!("YNyn"'[$E(ANS)) W !?10,$C(7),"Answer 'YES' or 'NO'." G CHK1
  1.  S:$E(ANS)["Nn" PSPOP=1 Q
  1.  ;PSO*7*259; SET VAR PSOSFN TO CHECK FOR SUSPENDED REFILL
  1. K52 K PSOSFN S SFN=+$O(^PS(52.5,"B",DA(1),0)),PSOSFN=SFN Q:SFN=0
  1.  I $P($G(^PS(52.5,SFN,0)),"^",5)=$P($G(^PSRX(+^PS(52.5,SFN,0),"P",0)),"^",3),$P($G(^PSRX($P(^PS(52.5,SFN,0),"^"),"P",0)),"^",4)=0 N PSOXX S PSOXX=1 G KILL
  1.  G:X'=""&($G(Y)=1) KILL I $G(Y)'=1,SFN I $D(^PS(52.5,SFN,0)),'$P(^(0),"^",5),'$P($G(^("P")),"^") D
  1.  .S SDT=+$P(^PS(52.5,SFN,0),"^",2) K ^PS(52.5,"C",SDT,SFN)
  1.  .I $P($G(^PS(52.5,SFN,0)),"^",7)="Q" K ^PS(52.5,"AQ",SDT,+$P(^PS(52.5,SFN,0),"^",3),SFN) D KCMPX^PSOCMOP(SFN,"Q")
  1.  .I $P($G(^PS(52.5,SFN,0)),"^",7)="" K ^PS(52.5,"AC",+$P(^PS(52.5,SFN,0),"^",3),SDT,SFN)
  1.  .K SFN,SDT
  1.  Q
  1. S52 S (RIFN,PSOSX)=0 F  S RIFN=$O(^PSRX(DA(1),1,RIFN)) Q:'RIFN  S RFID=$P(^PSRX(DA(1),1,RIFN,0),"^"),PSOSX=PSOSX+1
  1.  S SFN=+$O(^PS(52.5,"B",DA(1),0)) I SFN,'$G(^PS(52.5,SFN,"P")),$P($G(^PSRX($P($G(^PS(52.5,SFN,0)),"^"),"STA")),"^")=5 D
  1.  .I '$D(^PS(52.5,SFN,0))!($P($G(^(0)),"^",5)) Q
  1.  .S $P(^PS(52.5,SFN,0),"^",2)=RFID,^PS(52.5,"C",RFID,SFN)=""
  1.  .I $P($G(^PS(52.5,SFN,0)),"^",7)="Q" S ^PS(52.5,"AQ",RFID,+$P(^PS(52.5,SFN,0),"^",3),SFN)="" D SCMPX^PSOCMOP(SFN,"Q")
  1.  .I $P($G(^PS(52.5,SFN,0)),"^",7)="" S ^PS(52.5,"AC",+$P(^PS(52.5,SFN,0),"^",3),RFID,SFN)=""
  1.  K SFN,RFIN,RFID,PSOSX,PSOSXDT Q
  1. KILL N DFN
  1.  I SFN D
  1.  .S $P(^PSRX(DA(1),"STA"),"^")=0 Q:'$D(^PS(52.5,SFN,0))  S DFN=+$P(^PS(52.5,SFN,0),"^",3),PAT=$P(^DPT(DFN,0),"^")
  1.  .;I $P(^PS(52.5,SFN,0),"^",5) Q
  1.  .K ^PS(52.5,"B",+$P(^PS(52.5,SFN,0),"^"),SFN),^PS(52.5,"C",+$P(^PS(52.5,SFN,0),"^",2),SFN),^PS(52.5,"D",PAT,SFN),^PS(52.5,"AF",DFN,SFN)
  1.  .I $P($G(^PS(52.5,SFN,0)),"^",7)="" D
  1.  ..I $G(^PS(52.5,SFN,"P")) K ^PS(52.5,"AS",+$P(^(0),"^",8),+$P(^(0),"^",9),+$P(^(0),"^",6),+$P(^(0),"^",11),SFN),^PS(52.5,"ADL",$E(+$P(^PS(52.5,SFN,0),"^",8),1,7),SFN) Q
  1.  ..K ^PS(52.5,"AC",DFN,+$P(^PS(52.5,SFN,0),"^",2),SFN)
  1.  .I $P($G(^PS(52.5,SFN,0)),"^",7)'="" D
  1.  ..;Kill CMOP xrefs
  1.  ..N PSOC7 S PSOC7=$P($G(^PS(52.5,SFN,0)),"^",7)
  1.  ..I PSOC7="Q"!(PSOC7="P") K ^PS(52.5,"AG",+$P(^PS(52.5,SFN,0),"^",3),SFN) D KCMPX^PSOCMOP(SFN,PSOC7)
  1.  ..I PSOC7="X"!(PSOC7="P")!(PSOC7="L") K ^PS(52.5,$S(PSOC7="X":"AX",PSOC7="P":"AP",1:"AL"),$P(^PS(52.5,SFN,0),"^",2),$P(^(0),"^",3),SFN) D KCMPX^PSOCMOP(SFN,PSOC7)
  1.  ..K ^PS(52.5,"APR",+$P(^PS(52.5,SFN,0),"^",8),+$P(^(0),"^",9),+$P(^(0),"^",6),+$P(^(0),"^",11),SFN),^PS(52.5,"ADL",$E(+$P(^PS(52.5,SFN,0),"^",8),1,7),SFN)
  1.  .K ^PS(52.5,SFN,0),^PS(52.5,SFN,"P"),DFN,SFN,PAT
  1.  S CNT=0 F SUB=0:0 S SUB=$O(^PSRX(DA(1),"A",SUB)) Q:'SUB  S CNT=SUB
  1.  S:DA>5 DA=DA+1 D NOW^%DTC S CNT=CNT+1
  1.  S ^PSRX(DA(1),"A",0)="^52.3DA^"_CNT_"^"_CNT,^PSRX(DA(1),"A",CNT,0)=%_"^D^"_DUZ_"^"_DA_"^"
  1.  I '$D(PSOXX) S ^PSRX(DA(1),"A",CNT,0)=^PSRX(DA(1),"A",CNT,0)_"Refill "
  1.  ;if PSOXX not exist, = refill. otherwise, it is a partial.
  1.  S ^PSRX(DA(1),"A",CNT,0)=^PSRX(DA(1),"A",CNT,0)_$S($G(RESK):"returned to stock.",$G(PSOPSDAL):"deleted during Controlled Subs release.",$G(PSOXX)=1:"Partial deleted from suspense file.",1:"deleted during Rx edit.") K CNT,SUB
  1.  Q
  1. CID ;calculates six months limit on issue dates
  1.  ;IHS/MSC/PLS - 03/28/11 - Next four lines
  1.  ;S PSID=X,X="T-6M",%DT="X" D ^%DT S %DT(0)=Y,X=PSID,%DT="EX" D ^%DT K PSID
  1.  S PSID=X
  1.  S X=$$CIDADJ()
  1.  S %DT="X" D ^%DT S %DT(0)=Y,X=PSID,%DT="EX" D ^%DT K PSID
  1.  Q
  1. CIDH ;IHS/MSC/PLS - 03/28/11 - Next 3 lines
  1.  ;S X="T-6M",%DT="X" D ^%DT X ^DD("DD") D EN^DDIOL("Issue Date must be greater or equal to "_Y,"","!")
  1.  S X=$$CIDADJ()
  1.  S %DT="X" D ^%DT X ^DD("DD") D EN^DDIOL("Issue Date must be greater or equal to "_Y,"","!")
  1.  Q
  1.  ; Result earliest Issue Date
  1. CIDADJ() ;EP - p1011
  1.  N RES
  1.  S RES="T-6M"
  1.  I $G(PSODRUG("IEN")) D
  1.  .Q:$$ISSCH^APSPFNC2(PSODRUG("IEN"),"345")
  1.  .S RES="T-365"
  1.  Q RES
  1. SPR F RF=0:0 S RF=$O(^PSRX(DA(1),1,RF)) Q:'RF  S NODE=RF
  1.  I NODE=1 S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),2),"^",2) Q
  1. SREF I $G(NODE) S NODE=NODE-1 G:'$D(^PSRX(DA(1),1,NODE,0)) SREF
  1.  I NODE=0 S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),2),"^",2) Q
  1.  S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),1,NODE,0),"^",1) Q
  1.  K NODE,RF
  1.  Q
  1. KPR F RF=0:0 S RF=$O(^PSRX(DA(1),1,RF)) Q:'RF  S NODE=RF
  1.  I NODE=DA&(X'="") S NODE=NODE-1 S:NODE=1 NODE=0 G:'NODE ORIG G:NODE>1 KREF
  1.  I NODE=1 S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),2),"^",2) G EX
  1. KREF S NODE=NODE-1 G:'NODE EX
  1.  I NODE=1 S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),2),"^",2) G EX
  1.  G:NODE=DA&(X'="") KREF G:'$D(^PSRX(DA(1),1,NODE,0)) KREF
  1. ORIG I 'NODE S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),2),"^",2) G EX
  1.  S $P(^PSRX(DA(1),3),"^",4)=$P(^PSRX(DA(1),1,NODE,0),"^",1) G EX
  1. EX K NODE,RF
  1.  Q
  1. IBSS N PSOHLP S PSOHLP(1,"F")="!!"
  1.  S PSOHLP(1)="Entry in this field must match the SERVICE field for pharmacy action"
  1.  S PSOHLP(2,"F")="!"
  1.  S PSOHLP(2)="types in the IB ACTION TYPE file AND be a valid entry in your"
  1.  S PSOHLP(3,"F")="!"
  1.  S PSOHLP(3)="SERVICE/SECTION file to generate copay charges!"
  1.  S PSOHLP(4,"F")="!!"
  1.  D EN^DDIOL(.PSOHLP) K PSOHLP
  1.  Q
  1. IBSSR S PSOIBFL=0 F PSOIBLP=0:0 S PSOIBLP=$O(^DIC(49,PSOIBLP)) Q:'PSOIBLP!(PSOIBFL)  S Y=PSOIBLP,PSOIBST=$$SERV^IBARX1(+Y) I $G(PSOIBST) S DIE="^PS(59,",DA=PSOSITE,DR="1003////"_PSOIBLP D ^DIE K DIE D  S PSOIBFL=1
  1.  .W $C(7),!!,"There was an invalid entry in your IB SERVICE/SECTION field in your Outpatient",!,"Site Parameter file, but we have fixed the problem for you, and you",!,"may continue!" Q
  1.  Q
  1. WARN ;
  1.  I $G(PSOUNHLD) D  Q
  1.  .D EN^DDIOL("You cannot delete a refill while removing from Hold! Use the Edit Action.","","$C(7),!!"),EN^DDIOL(" ","","!!")
  1.  I $G(CMOP(DA))]""&(+$G(CMOP(DA))<3) D  K CMOP Q
  1.  .D EN^DDIOL("You cannot delete a refill that"_$S(+$G(CMOP(DA))=1:" has been released by",1:" is being transmitted to")_" the CMOP","","!!")
  1.  .D EN^DDIOL(" ","","!!")
  1.  K CMOP
  1.  ;
  1.  N PSOL,PSR
  1.  S PSR=0 F  S PSR=$O(^PSRX(DA(1),1,PSR)) Q:'PSR  S PSOL=PSR
  1.  I DA=PSOL,$P(^PSRX(DA(1),1,DA,0),"^",18) D  Q
  1.  .D EN^DDIOL("Refill Released! Use the 'Return to Stock' option!","","$C(7),!!"),EN^DDIOL(" ","","!")
  1.  ;
  1.  ;Only allow deletion if last refill      *259
  1.  I $O(^PSRX(DA(1),1,DA)) D  Q
  1.  .D EN^DDIOL("Only the last refill can be deleted.  Later refills must be deleted first.","","$C(7),!!")
  1.  .D EN^DDIOL("","","!!")
  1.  ;
  1.  ;Warn of In Process, Only delete if answered Yes         ;*259
  1.  I $$REFIP^PSOUTLA1(DA(1),DA,"R") D  I 'Y Q               ;reset $T
  1.  . D EN^DDIOL("** Refill has previously been sent to the External Dispense Machine","","!!,?2")
  1.  . D EN^DDIOL("** for filling and is still Pending Processing","","$C(7),!,?2")
  1.  . D EN^DDIOL("","","!")
  1.  . K DIR
  1.  . S DIR("A")="Do you want to continue? "
  1.  . S DIR("B")="Y"
  1.  . S DIR(0)="YA^^"
  1.  . S DIR("?")="Enter Y for Yes or N for No."
  1.  . D ^DIR
  1.  . K DIR
  1.  Q
  1.  ;
  1. WARN1 ;move to PSOUTLA1
  1.  D WARN1^PSOUTLA1
  1.  Q
  1.  ;
  1. CAN(PSOXRX) ;Clean up Rx when discontinued
  1.  N SUSD,IFN,RF,NODE,DA
  1.  Q:'$D(^PSRX(PSOXRX,0))
  1.  S DA=$O(^PS(52.5,"B",PSOXRX,0)) I DA S DIK="^PS(52.5,",SUSD=$P($G(^PS(52.5,DA,0)),"^",2) D ^DIK K DIK I $O(^PSRX(PSOXRX,1,0)) S DA=PSOXRX D REF^PSOCAN2
  1.  I $D(^PS(52.4,PSOXRX,0)) S DIK="^PS(52.4,",DA=PSOXRX D ^DIK K DIK
  1.  I $G(^PSRX(PSOXRX,"H"))]"" K:$P(^PSRX(PSOXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOXRX,"H"),"^"),PSOXRX) S ^PSRX(PSOXRX,"H")=""
  1.  ; IHS/MSC/PLS - 04/30/08 - Suppress the setting of the Fill Date for prescriptions on HOLD
  1.  ;I '$P($G(^PSRX(PSOXRX,2)),"^",2) K DIE S DIE="^PSRX(",DA=PSOXRX,DR="22///"_DT D ^DIE
  1.  Q
  1. ECAN(PSOXRX) ;Clean up Rx when expired
  1.  N DA
  1.  Q:'$D(^PSRX(PSOXRX,0))
  1.  S DA=$O(^PS(52.5,"B",PSOXRX,0)) I DA K DIK S DIK="^PS(52.5," D ^DIK K DIK
  1.  I $D(^PS(52.4,PSOXRX,0)) K DIK S DIK="^PS(52.4,",DA=PSOXRX D ^DIK K DIK
  1.  I $G(^PSRX(PSOXRX,"H"))]"" K:$P(^PSRX(PSOXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOXRX,"H"),"^"),PSOXRX) S ^PSRX(PSOXRX,"H")=""
  1.  ; IHS/MSC/PLS - 02/21/08 - Suppress the setting of the Fill Date for prescriptions on HOLD
  1.  ;I '$P($G(^PSRX(PSOXRX,2)),"^",2) K DIE S DIE="^PSRX(",DA=PSOXRX,DR="22///"_DT D ^DIE
  1.  Q
  1. CMOP ;CMOP("L")=LAST FILL... if it is orig Rx =0
  1.  ;CMOP(FILL #)=CMOP status from 52[TRAN=0,DISP=1,RETRAN=2,NOT DISP=3
  1.  ;If suspended CMOP("S")=CMOP suspense status Q,L,X,P,R
  1.  ;All returned variables can be killed by K CMOP
  1.  ;
  1.  S CRX=DA
  1. CMOP1 N X
  1.  S (CMOP("L"),X)=0  F  S X=$O(^PSRX(CRX,1,X)) Q:'X  S CMOP("L")=X
  1.  I $O(^PSRX(CRX,4,0)) F X=0:0 S X=$O(^PSRX(CRX,4,X)) Q:'X  D
  1.  .S CMOP($P($G(^PSRX(CRX,4,X,0)),"^",3))=$P($G(^(0)),"^",4)
  1.  S X=$O(^PS(52.5,"B",CRX,0)) I X]"" S CMOP("S")=$P($G(^PS(52.5,X,0)),"^",7)
  1.  K CRX,X
  1.  Q