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

PSOSULBL.m

Go to the documentation of this file. 
  1. PSOSULBL ;BHAM ISC/RTR,SAB-Print Suspended labels ;05-Sep-2013 14:45;PLS
  1.  ;;7.0;OUTPATIENT PHARMACY;**139,173,1008,174,148,200,260,264,287,289,1015,1016**;DEC 1997;Build 74
  1.  ;External reference ^PS(55 supported by DBIA 2228
  1.  ;Reference to SAVNDC^PSSNDCUT supported by IA 4707
  1.  ;Reference ^PSDRUG( supported by DBIA 221
  1.  ;Modified - IHS/MSC/PLS - 02/12/09 - Calls to DQ^PSOLBL changed to DQ^APSPLBL
  1.  ;                         08/31/09 - Added setting of PSOPULL flag so that Dispense and Fill dates are updated
  1.  K PDUZ,REPRINT G ^PSOSULB1
  1. BEG ;
  1.  K PSORUNIN,PSORETRY N BPSCNT
  1.  S PSORUNIN="PSOSUSP"_($G(PSOSITE))
  1.  L +@PSORUNIN:10 I '$T D
  1.  . F PSORETRY=1:1:120 L +@PSORUNIN:60 I $T Q  ;wait Max of 2 hrs before continue
  1.  . Q
  1.  K ^UTILITY($J,"PSOPRO"),^TMP("PSOSBAI",$J) S PSOSEQ=1 F DFN=0:0 S DFN=$O(^PS(52.5,"AC",DFN)) Q:'DFN  D  D:'PSRT PID^VADPT6 D CHKDEAD D:'DEAD&($G(PSOSFLAG)) PRT
  1.  .S PSOSFLAG=0 F ZZ=0:0 S ZZ=$O(^PS(52.5,"AC",DFN,ZZ)) Q:'ZZ!$G(PSOSFLAG)  I ZZ'>PRTDT S PSOSFLAG=1
  1.  D PPL
  1.  D:$D(^UTILITY($J,"PSOPRO"))&($P(PSOPAR,"^",8)) PROF
  1.  G EXIT
  1. PRT F SDT=0:0 S SDT=$O(^PS(52.5,"AC",DFN,SDT)) D:SDT CHK Q:'SDT
  1.  Q
  1. EXIT ;
  1.  I $D(^TMP("PSOSBAI",$J)) D CHKMAIL
  1.  K ^TMP($J),^TMP("PSOSBAI",$J)
  1.  I $D(PSORUNIN) L -@PSORUNIN
  1.  D ^%ZISC
  1.  K %,%ZIS,CNT,COM,DA,DEAD,DFN,DIRUT,DTTM,G,HDPPL,JJ,JJJ,JJJJ,PDUZ,IOP,ORD,PFIOQ,PSLION,PSRT,POP,PRF,PRTDT,PSLIO,PSNP,PSODBQ,PSOSEQ,PSOSFLAG,PSOSU,PSOTIME,PSOOUT,PSOPRFLG,PSOSEQ,PSOSUSPR,PSSPND,PST,PTL,PPLHLD,PSFNIEN,ZTSK
  1.  K PSOBADDR,PSORUNIN,PSORETRY,PSRTONE,PSSRT,PSUSDEA,RF,RFCNT,RX,RXDFN,SDT,SFN,SREC,STOP,SUSPT,VADM,VAPA,X,X1,X2,XAK,XDATE,Y,Z,ZZ,WWW,PSDDDATE,SINRX,RXPR,RXPR1,GGGG,XXX,ZII,ZTDESC,ZTRTN,ZTSAVE,RRRR,RXRP,RXRP1,RXFL,SPR S:$D(ZTQUEUED) ZTREQ="@" Q
  1. CHK I SDT'>XDATE D TMP Q
  1.  Q
  1. TMP F SFN=0:0 S SFN=$O(^PS(52.5,"AC",DFN,SDT,SFN)) Q:'SFN  D
  1.  . I '$D(^PS(52.5,SFN,0))!'$D(^DPT(+DFN,0)) Q
  1.  . N RXSITE,PRINTED,PSDFN,RXSTS,RXIEN,RXFILL,PARTIAL,RXEXPDT,RESP,DSHLD
  1.  . S RXIEN=+$$GET1^DIQ(52.5,SFN,.01,"I"),RXDFN=$$GET1^DIQ(52,RXIEN,2,"I")
  1.  . S RXSTS=$$GET1^DIQ(52,RXIEN,100,"I"),RXSITE=+$$GET1^DIQ(52.5,SFN,.06,"I"),PRINTED=+$$GET1^DIQ(52.5,SFN,2,"I")
  1.  . S PARTIAL=+$$GET1^DIQ(52.5,SFN,.05,"I"),RXEXPDT=$$GET1^DIQ(52,RXIEN,26,"I")
  1.  . S RXFILL=$$GET1^DIQ(52.5,SFN,9,"I") I RXFILL="" S RXFILL=$$LSTRFL^PSOBPSU1(RXIEN)
  1.  . I RXSITE=$G(PSOSITE),'PRINTED,RXDFN=DFN,RXSTS<9 D
  1.  . . I PARTIAL,'$D(^PSRX(RXIEN,"P",PARTIAL)) Q
  1.  . . I RXEXPDT<DT,RXSTS<11 D  Q
  1.  . . . N RXREC S RXREC=RXIEN D EX^PSOSUTL
  1.  . . . K DIE,DA S DIE=52,DA=RXIEN,DR="100///11" D ^DIE K DIE,DA
  1.  . . . K DIK,DA S DA=SFN,DIK="^PS(52.5," D ^DIK K DIK,DA
  1.  . . S PSOBADDR=0 D CHKBAI I PSOBADDR Q
  1.  . . I PSRT="D" D
  1.  . . . S PSSRT=$S($G(PSRTONE)="I":VA("PID"),1:$P(^DPT(DFN,0),"^")_$P(^(0),"^",9))
  1.  . . . S PSUSDEA=$P($G(^PS(52.5,SFN,0)),"^",10)
  1.  . . . S SRT=$S(PSUSDEA["A"!(PSUSDEA["C"):"A-"_PSSRT,PSUSDEA["S":"S-"_PSSRT,1:"Z-"_PSSRT)
  1.  . . I PSRT'="D" D
  1.  . . . S SRT=$S(PSRT:$P(^DPT(DFN,0),"^")_$P(^(0),"^",9),1:VA("PID"))
  1.  . . ; - If not partial fill, sending Rx to ECME for 3rd Party billing
  1.  . . I 'PARTIAL,$$RETRX^PSOBPSUT(RXIEN,RXFILL),SDT>DT Q
  1.  . . I 'PARTIAL,$$FIND^PSOREJUT(RXIEN,RXFILL),'$$DUR^PSOBPSU2(RXIEN,RXFILL) Q  ;epharmacy-host errors
  1.  . . I 'PARTIAL,$$STATUS^PSOBPSUT(RXIEN,RXFILL-1)'="" S DSHLD=$$DSH^PSOSULB1(SFN) Q:'DSHLD  ;epharmacy-3/4 days supply
  1.  . . I 'PARTIAL D  Q:$$FIND^PSOREJUT(RXIEN,RXFILL,,"79,88")  Q:$$TRISTA^PSOREJU3(RXIEN,RXFILL,.RESP,"PL")
  1.  . . . I $$FIND^PSOREJUT(RXIEN,RXFILL,,"79,88") Q
  1.  . . . I '$$RETRX^PSOBPSUT(RXIEN,RXFILL),'$$ECMESTAT^PSXRPPL2(RXIEN,RXFILL) Q
  1.  . . . D ECMESND^PSOBPSU1(RXIEN,RXFILL,,"PL",,,,,,.RESP) I $D(RESP),'RESP S BPSCNT=$G(BPSCNT)+1
  1.  . . S ^TMP($J,SRT,SFN)=RXIEN
  1.  Q
  1. PPL ; Wait some time before printing so response from 3rd party payers can be received
  1.  I $G(BPSCNT)>0 H 60+$S((BPSCNT*15)>7200:7200,1:(BPSCNT*15))
  1.  K PPL,PPL1 S ORD="" F  S ORD=$O(^TMP($J,ORD)) Q:ORD=""  D PPL1
  1.  Q
  1. PPL1 ; Printing Labels
  1.  N PARTIAL,REPRINT,REFILL,Z,QUIT
  1.  N PSOPULL  ;IHS/MSC/PLS - 08/31/09
  1.  S (PSOPRFLG,SUSPT)=1 S:$D(PSOPROP) PFIO=PSOPROP
  1.  S:'$D(PDUZ) PDUZ=DUZ K RXPR,RXPR1,PPL
  1.  F SFN=0:0 S SFN=$O(^TMP($J,ORD,SFN)) Q:'SFN  D
  1.  .I '$D(^PS(52.5,SFN,0)) Q
  1.  .S Z=$G(^PS(52.5,SFN,0)),SINRX=+$P(Z,"^"),REFILL=+$P(Z,"^",13)
  1.  .S PARTIAL=$P(Z,"^",5),REPRINT=$P(Z,"^",12)
  1.  .; - Screening out OPEN/UNRESOLVED Rejects (3rd Party Payer)
  1.  .S QUIT=0
  1.  .I 'PARTIAL,'REPRINT D  I QUIT Q
  1.  ..I $$FIND^PSOREJUT(SINRX,REFILL,,"79,88") S QUIT=1 Q
  1.  ..I $$STATUS^PSOBPSUT(SINRX,REFILL)="IN PROGRESS" S QUIT=1 Q
  1.  ..I $$STATUS^PSOBPSUT(SINRX,REFILL)="E PAYABLE" D
  1.  ...D SAVNDC^PSSNDCUT(+$$GET1^DIQ(52,SINRX,6,"I"),$$RXSITE^PSOBPSUT(SINRX,REFILL),$$GETNDC^PSONDCUT(SINRX,REFILL))
  1.  .;
  1.  .I $L($G(PPL))<240 D
  1.  ..S PPL=$P(^TMP($J,ORD,SFN),"^")_","_$G(PPL),RXPR(SINRX)=$P(^PS(52.5,SFN,0),"^",5)
  1.  ..S:$P(^PS(52.5,SFN,0),"^",12) RXRP(SINRX)=1
  1.  .E  D
  1.  ..S PPL1=$P(^TMP($J,ORD,SFN),"^")_","_$G(PPL1),RXPR1(SINRX)=$P(^PS(52.5,SFN,0),"^",5)
  1.  ..S:$P(^PS(52.5,SFN,0),"^",12) RXRP1(SINRX)=1
  1.  .S DFN=$P(^PS(52.5,SFN,0),"^",3)
  1.  .I $P(PSOPAR,"^",8),'$D(^PSRX($P(^PS(52.5,SFN,0),"^"),1)),'$G(RXPR(SINRX)),'$G(RXPR1(SINRX)) S PSOPRFLG=0
  1.  S PSNP=$S($P(PSOPAR,"^",8):1,1:0)
  1.  I $G(PPL) D
  1.  .S PPLHLD=$G(PPL1),HDPPL=PPL K PPL1 S (PSODBQ,PSOSUSPR)=1
  1.  .F GGGG=0:0 S GGGG=$O(RXPR(GGGG)) Q:'GGGG  K:'$G(RXPR(GGGG)) RXPR(GGGG)
  1.  ;IHS/MSC/PLS - 02/12/09 - Changed to call IHS label routine
  1.  ;I $G(PPL) D DQ^PSOLBL,SEQ D:'$G(PSOPRFLG)
  1.  S PSOPULL=1
  1.  I $G(PPL) D DQ^APSPLBL,SEQ D:'$G(PSOPRFLG)
  1.  .I $G(PSOPROP)'=$G(PSLION) S ^UTILITY($J,"PSOPRO",DFN)="" Q
  1.  .D DQ^PSOPRFSS
  1.  I $G(PPLHLD) K RXPR S (PPL,HDPPL)=PPLHLD,(PSODBQ,PSOSUSPR)=1,PSNP=0 S:'$D(PDUZ) PDUZ=DUZ F XXX=0:0 S XXX=$O(RXPR1(XXX)) Q:'XXX  S:$G(RXPR1(XXX)) RXPR(XXX)=RXPR1(XXX)
  1.  I $G(PPLHLD) F RRRR=0:0 S RRRR=$O(RXRP1(RRRR)) Q:'RRRR  S:$D(RXRP1(RRRR)) RXRP(RRRR)=1
  1.  ;IHS/MSC/PLS - 02/12/09 - Changed to call IHS label routine
  1.  ;I $G(PPLHLD) D DQ^PSOLBL,SEQ D:'$G(PSOPRFLG)
  1.  I $G(PPLHLD) D DQ^APSPLBL,SEQ D:'$G(PSOPRFLG)
  1.  .I $G(PSOPROP)'=$G(PSLION) S ^UTILITY($J,"PSOPRO",DFN)="" Q
  1.  .D DQ^PSOPRFSS
  1.  K PPL,PPL1,PPLHLD,RXPR,RXPR1,RXFL Q
  1. SEQ ;
  1.  S SQCOUNT=0 F JJJ=1:1:$L(HDPPL) S:$E(HDPPL,JJJ)="," SQCOUNT=SQCOUNT+1
  1.  F JJJJ=1:1:SQCOUNT S PSFNIEN=$P(HDPPL,",",JJJJ) D:PSFNIEN
  1.  .S PSFNIEN=$O(^PS(52.5,"B",PSFNIEN,0)) I PSFNIEN D
  1.  ..S $P(^PS(52.5,PSFNIEN,0),"^",11)=PSOSEQ,PSOSEQ=PSOSEQ+1 S:$P(^PS(52.5,PSFNIEN,0),"^",8)&($P(^(0),"^",9))&($P(^(0),"^",6)) ^PS(52.5,"AS",$P(^PS(52.5,PSFNIEN,0),"^",8),$P(^(0),"^",9),$P(^(0),"^",6),$P(^(0),"^",11),PSFNIEN)=""
  1.  Q
  1. CHKDEAD D DEM^VADPT I VADM(1)="" S DEAD=0 Q
  1.  I VADM(6)="" S DEAD=0 Q
  1.  S PSDDDATE=$P(VADM(6),"^",2) F WWW=0:0 S WWW=$O(^PS(55,DFN,"P",WWW)) Q:'WWW  I $D(^PS(55,DFN,"P",WWW,0)),$P($G(^(0)),"^") S (DA,RXREC)=$P(^(0),"^") S SFN=$O(^PS(52.5,"B",RXREC,0)) I SFN,$D(^PS(52.5,SFN,0)) S RX=$P(^(0),"^") D DEAD
  1.  Q
  1. DEAD S $P(^PSRX(RX,"STA"),"^")=12,COM="Died ("_$G(PSDDDATE)_")",DA(1)=RX
  1.  S DEAD=1 D ARECD^PSOSUTL S DIK="^PS(52.5,",DA=SFN D ^DIK K DIK
  1.  Q
  1. PROF ;
  1.  S ZTRTN="PRPROF^PSOSULBL",ZTDESC="PRINT PROFILES FROM SUSPENSE",ZTDTH=$H,ZTIO=PSOPROP
  1.  S ZTSAVE("^UTILITY($J,""PSOPRO"",")="",ZTSAVE("PSOPAR")="",ZTSAVE("PSODTCUT")="",ZTSAVE("PSOSITE")="",ZTSAVE("PSOPRPAS")="" D ^%ZTLOAD Q
  1. PRPROF ;
  1.  F LLL=0:0 S LLL=$O(^UTILITY($J,"PSOPRO",LLL)) Q:'LLL  I $D(^DPT(LLL,0)) S DFN=LLL D DQ^PSOPRFSS
  1.  K PSOPAR,PSODTCUT,PSOSITE,PSOPRPAS,LLL,DFN,^UTILITY($J,"PSOPRO") D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
  1.  Q
  1.  ;
  1. CHKBAI ; IF BAD ADDRESS INDICATOR, NO ACTIVE TEMPORARY ADDRESS AND ROUTING OF MAIL, DO NOT SEND TO OPAI AND/OR DO NOT PRINT LABEL
  1.  N PSOBADR,ACTSEQ,XX,PSOFIRST,ACTTYPE
  1.  I '$G(RXFILL),$P(^PSRX(RXIEN,0),"^",11)="W" Q
  1.  I $P($G(^PSRX(RXIEN,1,RXFILL,0)),"^",2)="W" Q
  1.  S ACTTYPE="BAD ADDRESS INDICATOR"
  1.  S PSOBADR=$$CHKRX^PSOBAI(RXIEN)
  1.  ; GOOD PERMANENT OR TEMPORARY ADDRESS - CHECK FOR DO NOT MAIL
  1.  I PSOBADR,'$P(PSOBADR,"^",2) D SETTMP(ACTTYPE) Q
  1.  S NOMAIL=0 D NOMAIL I NOMAIL Q
  1.  D FOREIGN
  1.  Q
  1.  ;
  1. SETTMP(ACTTYPE) ;
  1.  N ACTSEQ,XX,PSOFIRST,ZZ
  1.  S PSOFIRST=1
  1.  S PSOBADDR=1
  1.  S ACTSEQ=0 F  S ACTSEQ=$O(^PSRX(RXIEN,"A",ACTSEQ)) Q:ACTSEQ=""  D
  1.  .S XX=$G(^PSRX(RXIEN,"A",ACTSEQ,0)) I $P(XX,"^",2)="S" S ZZ=$P(XX,"^",4),ZZ=$S(ZZ<6:ZZ,1:ZZ-1) I ZZ=RXFILL,$P(XX,"^",5)["due to "_ACTTYPE S PSOFIRST=0 Q
  1.  I PSOFIRST D
  1.  .S ^TMP("PSOSBAI",$J,RXIEN,+RXFILL)=ACTTYPE
  1.  .D ACT(ACTTYPE)
  1.  Q
  1.  ;
  1. NOMAIL ; SEE IF FILE 55 STATUS IS DO NOT MAIL
  1.  N ACTTYPE,DFN,MAILST,MAILEXP
  1.  S ACTTYPE="DO NOT MAIL"
  1.  S DFN=+$P($G(^PSRX(RXIEN,0)),"^",2),MAILST=$P($G(^PS(55,DFN,0)),"^",3) I MAILST'=2 Q
  1.  S MAILEXP=$P(^PS(55,DFN,0),"^",5)
  1.  I MAILEXP=""!(MAILEXP>DT) D SETTMP(ACTTYPE)
  1.  Q
  1.  ;
  1. FOREIGN ;
  1.  N DFN,PSOFORGN
  1.  S DFN=+$P($G(^PSRX(RXIEN,0)),"^",2)
  1.  D ADD^VADPT
  1.  S PSOFORGN=$P($G(VAPA(25)),"^",2) I PSOFORGN'="",PSOFORGN'["UNITED STATES" S PSOFORGN=1
  1.  I PSOFORGN D SETTMP("FOREIGN ADDRESS")
  1.  Q
  1.  ;
  1. CHKMAIL ; SEE IF MAILMAN MESSAGE SHOULD BE SENT FOR BAI/MAIL ROUTING
  1.  N RXIEN,RXFILL,ACTSEQ,XX,DFN,SSN,NAME,ACTTYPE,ZZ
  1.  K ^TMP("PSOSM",$J)
  1.  S RXIEN=0 F  S RXIEN=$O(^TMP("PSOSBAI",$J,RXIEN)) Q:'RXIEN  D
  1.  .S RXFILL="" F  S RXFILL=$O(^TMP("PSOSBAI",$J,RXIEN,RXFILL)) Q:RXFILL=""  D
  1.  ..S ACTTYPE=^TMP("PSOSBAI",$J,RXIEN,RXFILL)
  1.  ..S ACTSEQ=0 F  S ACTSEQ=$O(^PSRX(RXIEN,"A",ACTSEQ)) Q:ACTSEQ=""  D
  1.  ...S XX=$G(^PSRX(RXIEN,"A",ACTSEQ,0)) I $P(XX,"^",2)="S" S ZZ=$P(XX,"^",4),ZZ=$S(ZZ<6:ZZ,1:ZZ-1) I ZZ=RXFILL,$P(XX,"^",5)["due to "_ACTTYPE Q
  1.  ...S DFN=$P(^PSRX(RXIEN,0),"^",2),NAME=$P(^DPT(DFN,0),"^"),SSN=$P(^(0),"^",9) I SSN="" S SSN=0
  1.  ...S ^TMP("PSOSM",$J,NAME,SSN,RXIEN,RXFILL)=ACTTYPE
  1.  I $D(^TMP("PSOSM",$J)) D BAIMAIL^PSOSULB1
  1.  K ^TMP("PSOSM",$J)
  1.  Q
  1.  ;
  1. ACT(ACTTYPE) ;adds activity info for rx not printed from suspense/not sent to OPAI
  1.  N NOW,IR,FDA
  1.  D NOW^%DTC S NOW=%
  1.  S IR=0 F FDA=0:0 S FDA=$O(^PSRX(RXIEN,"A",FDA)) Q:'FDA  S IR=FDA
  1.  S IR=IR+1,^PSRX(RXIEN,"A",0)="^52.3DA^"_IR_"^"_IR
  1.  S ^PSRX(RXIEN,"A",IR,0)=NOW_"^"_"S"_"^"_DUZ_"^"_$S(+RXFILL>5:RXFILL+1,1:+RXFILL)_"^"_"RX not printed from suspense due to "_ACTTYPE
  1.  K PSUS,RXF,I,FDA,DIC,DIE,DR,Y,X,%,%I,%H,RSDT
  1.  Q
  1.  ;