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

PSOSUTL.m

Go to the documentation of this file. 
  1. PSOSUTL ;BIR/RTR - Suspense utility routine ;26-Jul-2016 15:09;DU
  1.  ;;7.0;OUTPATIENT PHARMACY;**10,34,139,167,1008,1013,235,1015,1021**;DEC 1997;Build 14
  1.  ;External reference to ^PSDRUG supported by DBIA 221
  1.  ;External reference to ^PSNDF supported by DBIA 2195
  1.  ; Modified - IHS/MSC/PLS- 02/09/09 - Line AREC
  1.  ;                         09/20/2011 - Line AREC1+6,AREC1+9
  1.  ;                         11/29/2011 - Mod at AREC no longer needed.
  1.  ;                         07/26/2016 - Lines AREC1+5,AREC1+10
  1. AREC1 ;
  1.  S $P(^PSRX(RX,"STA"),"^")=0
  1.  S SFN=$O(^PS(52.5,"B",RX,0)) I 'SFN D CPMS Q
  1.  D NOW^%DTC S DTTM=% S COM="Suspense "_$S($G(RXRP(RX)):"(Reprint) ",1:"")_"Label Pulled Early"_$S($G(RXP):" (Partial)",1:"") S CNT=0 F JJ=0:0 S JJ=$O(^PSRX(RX,"A",JJ)) Q:'JJ  S CNT=JJ
  1.  D DEL S $P(^PSRX(RX,"STA"),"^")=0 K PSODEL S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RX,1,RF)) Q:'RF  S RFCNT=RF
  1.  ;IHS/MSC/PLS - 07/26/2016
  1.  ;I 'RFCNT,'$G(RXP),'$D(RXRP(RX)) S (X,OLD)=$P(^PSRX(RX,2),"^",2) D  K DIE
  1.  I 'RFCNT,'$G(RXP),('$D(RXRP(RX))!($D(RXRS(RX)))) S (X,OLD)=$P(^PSRX(RX,2),"^",2) D  K DIE
  1.  .;K DIE S DA=RX,DR="22////"_DT_";101////"_DT_";25////"_DT,DIE=52 D ^DIE
  1.  .K DIE S DA=RX,DR="22////"_DT_";101////"_DT_";25////"_DT_";20///"_PSOSITE,DIE=52 D ^DIE  ;IHS/MSC/PLS - 09/20/2011
  1.  ;IHS/MSC/PLS - 07/26/2016
  1.  ;I RFCNT,'$G(RXP),'$D(RXRP(RX)) S (OLD,X)=+$P($G(^PSRX(RX,1,RFCNT,0)),"^") D  K DIE S $P(^PSRX(RX,3),"^")=DT
  1.  I RFCNT,'$G(RXP),('$D(RXRP(RX))!($D(RXRS(RX)))) S (OLD,X)=+$P($G(^PSRX(RX,1,RFCNT,0)),"^") D  K DIE S $P(^PSRX(RX,3),"^")=DT
  1.  .;K DIE S DA(1)=RX,DA=RFCNT,DIE="^PSRX("_DA(1)_",1,",DR=".01///"_DT_";10.1///"_DT D ^DIE
  1.  .K DIE S DA(1)=RX,DA=RFCNT,DIE="^PSRX("_DA(1)_",1,",DR=".01///"_DT_";10.1///"_DT_";8///"_PSOSITE D ^DIE  ;IHS/MSC/PLS - 09/20/2011
  1.  S:'$D(PDUZ) PDUZ=DUZ S CNT=CNT+1,^PSRX(RX,"A",0)="^52.3DA^"_CNT_"^"_CNT
  1.  S ^PSRX(RX,"A",CNT,0)=DTTM_"^S^"_PDUZ_"^"_$S($G(RXP):6,'RFCNT:RFCNT,RFCNT<6:RFCNT,1:(RFCNT+1))_"^"_COM
  1.  D CPMS
  1.  Q
  1. CPMS ;
  1.  N PSOZZDD S PSOZZDD="Label printed from suspense" D EN^PSOHLSN1(RX,"SC","ZU",PSOZZDD) K PSOZZDD
  1.  Q
  1.  ;
  1. DEL S DA=SFN,DIK="^PS(52.5," D ^DIK K DIK Q
  1.  ;I 'PSODELE S NODE=^PS(52.5,SFN,0) K ^PS(52.5,"C",$P(NODE,"^",2),SFN),^PS(52.5,"AC",$P(NODE,"^",3),$P(NODE,"^",2),SFN) S $P(^PS(52.5,SFN,0),"^",2)=DT,^PS(52.5,"C",DT,SFN)="",^PS(52.5,SFN,"P")=1 D  K NODE
  1.  ;.S X1=DT,X2=+$P($G(^PS(59.7,1,40.1)),"^",5) D C^%DTC S ^PS(52.5,"ADL",X,SFN)="" K X
  1.  ;I $P($G(^PS(52.5,SFN,0)),"^",7)'="" N DA,DR,DIE S DA=SFN,DIE="^PS(52.5,",DR="3////P" D ^DIE
  1.  Q
  1. AREC N PSOZZDMS S PSOZZDMS=0 S:$P(^PSRX(RX,"STA"),"^")=5 PSOZZDMS=1
  1.  S:$P(^PSRX(RX,"STA"),"^")=5 $P(^PSRX(RX,"STA"),"^")=0 S SFN=$O(^PS(52.5,"B",RX,0)) D:'SFN&(PSOZZDMS) CPMSG Q:'SFN  D NOW^%DTC S DTTM=% S COM="Suspense "_$S($G(RXRP(RX)):"(Reprint) ",1:"")_"Label Printed"_$S($G(RXP):" (Partial)",1:"")
  1.  S $P(^PS(52.5,SFN,"P"),"^")=1 D  K ^PS(52.5,"AC",DFN,$P(^PS(52.5,SFN,0),"^",2),SFN) S CNT=0 F JJ=0:0 S JJ=$O(^PSRX(RX,"A",JJ)) Q:'JJ  S CNT=JJ
  1.  .S ^PS(52.5,"ADL",$E(PSOTIME,1,7),SFN)=""
  1.  S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RX,1,RF)) Q:'RF  S RFCNT=RF S:RF>5 RFCNT=RF+1
  1.  S CNT=CNT+1,^PSRX(RX,"A",0)="^52.3DA^"_CNT_"^"_CNT S ^PSRX(RX,"A",CNT,0)=DTTM_"^S^"_DUZ_"^"_$S($G(RXP):6,1:RFCNT)_"^"_COM
  1.  S $P(^PS(52.5,SFN,0),"^",8)=PSOTIME,$P(^PS(52.5,SFN,0),"^",9)=PDUZ S:'$P(^PS(52.5,SFN,0),"^",6) $P(^PS(52.5,SFN,0),"^",6)=PSOSITE
  1.  I PSOZZDMS D CPMSG
  1.  Q
  1. CPMSG ;
  1.  N PSOZZDDD S PSOZZDDD="Label printed from suspense" D EN^PSOHLSN1(RX,"SC","ZU",PSOZZDDD) K PSOZZDDD
  1.  Q
  1.  ;
  1. ARECD D NOW^%DTC S CNT=0,DTTM=% F JJ=0:0 S JJ=$O(^PSRX(RX,"A",JJ)) Q:'JJ  S CNT=JJ
  1.  S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RX,1,RF)) Q:'RF  S RFCNT=RF S:RF>5 RFCNT=RF+1
  1.  S RXP=$P(^PS(52.5,SFN,0),"^",5)
  1.  S CNT=CNT+1,^PSRX(RX,"A",0)="^52.3DA^"_CNT_"^"_CNT S ^PSRX(RX,"A",CNT,0)=DTTM_"^C^"_DUZ_"^"_$S($G(RXP):6,1:RFCNT)_"^"_COM K RXP
  1.  D EN^PSOHLSN1(RX,"OD","",COM,"A")
  1.  Q
  1. EX Q:'$G(RXREC)  D NOW^%DTC S PSCOU=0,DTTM=% F AAA=0:0 S AAA=$O(^PSRX(RXREC,"A",AAA)) Q:'AAA  S PSCOU=AAA
  1.  S VVV=0 F QQQ=0:0 S QQQ=$O(^PSRX(RXREC,1,QQQ)) Q:'QQQ  S VVV=QQQ S:QQQ>5 VVV=QQQ+1
  1.  S PSOPRT=$P(^PS(52.5,SFN,0),"^",5)
  1.  S PSOEXPI="Expired while on suspense"
  1.  S PSCOU=PSCOU+1,^PSRX(RXREC,"A",0)="^52.3DA^"_PSCOU_"^"_PSCOU S ^PSRX(RXREC,"A",PSCOU,0)=DTTM_"^S^"_DUZ_"^"_$S($G(PSOPRT):6,1:VVV)_"^"_PSOEXPI
  1.  D EN^PSOHLSN1(RXREC,"SC","ZE",PSOEXPI)
  1.  K PSCOU,AAA,QQQ,VVV,PSOPRT,PSOEXPI Q
  1. SET ; Set DEA in Suspense File
  1.  N PSOSUDEA
  1.  Q:'$G(X)  Q:'$D(^PSRX(X,0))
  1.  S PSOSUDEA=$P($G(^PSRX(X,0)),"^",6) I PSOSUDEA,$D(^PSDRUG(PSOSUDEA,0)) S $P(^PS(52.5,DA,0),"^",10)=$P(^PSDRUG(PSOSUDEA,0),"^",3)
  1.  Q
  1. KILL Q:'$G(DA)  Q:'$D(^PS(52.5,DA,0))
  1.  S $P(^PS(52.5,DA,0),"^",10)=""
  1.  Q
  1. SAS ;X-ref on Division field
  1.  N PSOC7,PSUSPIEN S PSUSPIEN=$O(^PS(52.5,"B",DA,0)) I PSUSPIEN,$D(^PS(52.5,PSUSPIEN,0)),'$P($G(^(0)),"^",5),'$O(^PSRX(DA,1,0)) D
  1.  .S PSOC7=$P($G(^PS(52.5,PSUSPIEN,0)),"^",7)
  1.  .S $P(^PS(52.5,PSUSPIEN,0),"^",6)=X S:$P(^PS(52.5,PSUSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P($G(^(0)),"^",7)="") ^PS(52.5,"AS",$P(^PS(52.5,PSUSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSUSPIEN)=""
  1.  .S $P(^PS(52.5,PSUSPIEN,0),"^",6)=X S:$P(^PS(52.5,PSUSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P($G(^(0)),"^",7)="P") ^PS(52.5,"APR",$P(^PS(52.5,PSUSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSUSPIEN)=""
  1.  .K:$P(^PS(52.5,PSUSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P($G(^(0)),"^",7)="P") ^PS(52.5,"AS",$P(^PS(52.5,PSUSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSUSPIEN)
  1.  .I PSOC7'="" D SCMPX^PSOCMOP(PSUSPIEN,PSOC7)
  1.  Q
  1. KAS ;
  1.  N PSUSPIEN,PSOC7 S PSUSPIEN=$O(^PS(52.5,"B",DA,0)) I PSUSPIEN,$D(^PS(52.5,PSUSPIEN,0)),'$P($G(^(0)),"^",5),'$O(^PSRX(DA,1,0)) D
  1.  .K:$P(^PS(52.5,PSUSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P(^(0),"^",7)="") ^PS(52.5,"AS",$P(^PS(52.5,PSUSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSUSPIEN)
  1.  .K:$P(^PS(52.5,PSUSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P(^(0),"^",7)="P") ^PS(52.5,"APR",$P(^PS(52.5,PSUSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSUSPIEN)
  1.  .S PSOC7=$P($G(^PS(52.5,PSUSPIEN,0)),"^",7)
  1.  .I PSOC7'="" D KCMPX^PSOCMOP(PSUSPIEN,PSOC7)
  1.  Q
  1. SAS1 ;Refill Division x-ref
  1.  N PSOSPIEN,ZZZ,PSREFCNT,PSOC7 S PSOSPIEN=$O(^PS(52.5,"B",DA(1),0)) I PSOSPIEN,$D(^PS(52.5,PSOSPIEN,0)),'$P($G(^(0)),"^",5),$O(^PSRX(DA(1),1,0)) D
  1.  .S PSOC7=$P($G(^PS(52.5,PSOSPIEN,0)),"^",7)
  1.  .S PSREFCNT=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(DA(1),1,ZZZ)) Q:'ZZZ  S PSREFCNT=PSREFCNT+1
  1.  .I PSREFCNT=DA S $P(^PS(52.5,PSOSPIEN,0),"^",6)=X D
  1.  ..S:$P(^PS(52.5,PSOSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P($G(^(0)),"^",7)="") ^PS(52.5,"AS",$P(^PS(52.5,PSOSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSOSPIEN)=""
  1.  ..S:$P(^PS(52.5,PSOSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P($G(^(0)),"^",7)="P") ^PS(52.5,"APR",$P(^PS(52.5,PSOSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSOSPIEN)=""
  1.  ..K:$P(^PS(52.5,PSOSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P($G(^(0)),"^",7)="P") ^PS(52.5,"AS",$P(^PS(52.5,PSOSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSOSPIEN)
  1.  ..I PSOC7'="" D SCMPX^PSOCMOP(PSOSPIEN,PSOC7)
  1.  Q
  1. KAS1 ;
  1.  N PSOSPIEN,ZZZ,PSREFCNT,PSOC7 S PSOSPIEN=$O(^PS(52.5,"B",DA(1),0)) I PSOSPIEN,$D(^PS(52.5,PSOSPIEN,0)),'$P($G(^(0)),"^",5),$O(^PSRX(DA(1),1,0)) D
  1.  .S PSREFCNT=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(DA(1),1,ZZZ)) Q:'ZZZ  S PSREFCNT=PSREFCNT+1
  1.  .I PSREFCNT=DA D
  1.  ..K:$P(^PS(52.5,PSOSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P(^(0),"^",7)="") ^PS(52.5,"AS",$P(^PS(52.5,PSOSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSOSPIEN)
  1.  ..K:$P(^PS(52.5,PSOSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P(^(0),"^",7)="P") ^PS(52.5,"APR",$P(^PS(52.5,PSOSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSOSPIEN)
  1.  ..S PSOC7=$P($G(^PS(52.5,PSOSPIEN,0)),"^",7)
  1.  ..I PSOC7'="" D KCMPX^PSOCMOP(PSOSPIEN,PSOC7)
  1.  Q
  1. SAS2 ;For partials
  1.  N PSPSPIEN S PSPSPIEN=$O(^PS(52.5,"B",DA(1),0)) I PSPSPIEN,$D(^PS(52.5,PSPSPIEN,0)),$P($G(^(0)),"^",5) D
  1.  .I DA=$P(^PS(52.5,PSPSPIEN,0),"^",5) S $P(^(0),"^",6)=X D
  1.  ..S:$P(^PS(52.5,PSPSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P($G(^(0)),"^",7)="") ^PS(52.5,"AS",$P(^PS(52.5,PSPSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSPSPIEN)=""
  1.  ..S:$P(^PS(52.5,PSPSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P($G(^(0)),"^",7)="P") ^PS(52.5,"APR",$P(^PS(52.5,PSPSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSPSPIEN)=""
  1.  ..K:$P(^PS(52.5,PSPSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P($G(^(0)),"^",7)="P") ^PS(52.5,"AS",$P(^PS(52.5,PSPSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSPSPIEN)
  1.  Q
  1. KAS2 ;
  1.  N PSPSPIEN S PSPSPIEN=$O(^PS(52.5,"B",DA(1),0)) I PSPSPIEN,$D(^PS(52.5,PSPSPIEN,0)),$P($G(^(0)),"^",5) D
  1.  .I DA=$P(^PS(52.5,PSPSPIEN,0),"^",5) D
  1.  ..K:$P(^PS(52.5,PSPSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P(^(0),"^",7)="") ^PS(52.5,"AS",$P(^PS(52.5,PSPSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSPSPIEN)
  1.  ..K:$P(^PS(52.5,PSPSPIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",11))&($P(^(0),"^",7)="P") ^PS(52.5,"APR",$P(^PS(52.5,PSPSPIEN,0),"^",8),$P(^(0),"^",9),X,$P(^(0),"^",11),PSPSPIEN)
  1.  Q
  1. SDEA ;Update Suspense with DEA
  1.  N PSSSPIEN S PSSSPIEN=$O(^PS(52.5,"B",DA,0)) Q:'$G(PSSSPIEN)
  1.  I $D(^PS(52.5,PSSSPIEN,0)),$P($G(^("P")),"^")=0 S $P(^PS(52.5,PSSSPIEN,0),"^",10)=$P($G(^PSDRUG(+X,0)),"^",3)
  1.  Q
  1. SDIV N PSODINT,PSDVP,PSLOOP
  1.  S PSODINT=+$P($G(^PS(52.5,DA,0)),"^") Q:'PSODINT
  1.  S PSDVP=$P($G(^PS(52.5,DA,0)),"^",5) I PSDVP D  Q
  1.  .S:$D(^PSRX(PSODINT,"P",+PSDVP,0)) $P(^(0),"^",9)=X
  1.  S PSDVP=0 F PSLOOP=0:0 S PSLOOP=$O(^PSRX(PSODINT,1,PSLOOP)) Q:'PSLOOP  S PSDVP=PSLOOP
  1.  I PSDVP S:$D(^PSRX(PSODINT,1,PSDVP,0)) $P(^(0),"^",9)=X Q
  1.  S:$D(^PSRX(PSODINT,2)) $P(^(2),"^",9)=X
  1.  Q
  1. ZZ(RX) ; Returns VA print name, Trade Name, Generic Name
  1.  S I50=$P(^PSRX(RX,0),U,6),ZDRUG=$P(^PSDRUG(I50,0),U)
  1.  I $G(ZDRUG)']"" S ZDRUG="DRUG NOT ON FILE ("_I50_")" G END
  1.  I $G(^PSRX(RX,"TN"))]"" S ZDRUG=^("TN") G END
  1.  I $D(^PSDRUG("AQ",I50)),($D(^PSDRUG(I50,"ND"))) D
  1.  .S Z1=$P($G(^PSDRUG(I50,"ND")),U),Z2=$P($G(^("ND")),U,3)
  1.  .I $G(Z1),($G(Z2)) D
  1.  ..I $T(^PSNAPIS)]"" S PSOXN=$$PROD2^PSNAPIS(Z1,Z2) S ZDRUG=$P($G(PSOXN),"^") K PSOXN Q
  1.  ..S ZDRUG=$P($G(^PSNDF(Z1,5,Z2,2)),"^")
  1.  .K Z1,Z2,I50
  1. END K I50
  1.  Q ZDRUG