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

PSOSULB1.m

Go to the documentation of this file.
  1. PSOSULB1 ;BHAM ISC/RTR,SAB - Print suspended labels cont. ;10/10/96
  1. ;;7.0;OUTPATIENT PHARMACY;**10,200,264,289,367,421,448,452,561**;DEC 1997;Build 41
  1. ;Reference to $$INSUR^IBBAPI supported by IA 4419
  1. ;Reference to $$BILLABLE^IBNCPDP supported by IA 6243
  1. ;
  1. DEV D:'$D(PSOPAR) ^PSOLSET G:'$D(PSOPAR) DEV S PSOION=ION
  1. N X S X="PSXRSUS" X ^%ZOSF("TEST") G:($T)&($G(PSXSYS))&($D(^XUSEC("PSXCMOPMGR",DUZ)))&($D(^XUSEC("PSX XMIT",DUZ))) ^PSXRSUS
  1. DEV1 I '$P(PSOPAR,"^",8) G START
  1. N PSOPROP,PFIO W $C(7),!!,"PROFILES MUST BE SENT TO PRINTER !!",! K IOP,%ZIS,IO("Q"),POP S %ZIS="MNQ",%ZIS("A")="Select PROFILE Device: " D ^%ZIS K %ZIS("A") G:POP EXIT^PSOSULBL G:$E(IOST)["C"!(PSOION=ION) DEV S PSOPROP=ION D ^%ZISC
  1. START I $G(PSOCUTDT)']"" S X1=DT,X2=-120 D C^%DTC S PSODTCUT=X,PSOPRPAS=$P(PSOPAR,"^",7) G ^PSOSUCAT ;Print Suspense by Category //rtw
  1. ASK K ^TMP($J),PSOSU,PSOSUSPR S PFIOQ=0,PDUZ=DUZ W !
  1. S %DT="AEX",%DT("A")="Print labels through date: ",%DT("B")="TODAY" D ^%DT K %DT D:Y<0 MESS G:Y<0 EXIT^PSOSULBL S PRTDT=Y
  1. I '$O(^PS(52.5,"C",0))!($O(^(0))>PRTDT) W $C(7),!!,"NOTHING THRU DATE TO PRINT" G ASK
  1. W ! K DIR S DIR("A")="Sort by Patient Name, ID#, or DEA Special Handling",DIR(0)="SB^P:PATIENT NAME;I:IDENTIFICATION NUMBER;D:DEA SPECIAL HANDLING"
  1. S DIR("?")="Enter 'P' to sort the labels alphabetically by name, enter 'I' to sort by identification number, enter 'D' to sort by DEA Special Handling."
  1. S DIR("?",1)="Sorting by DEA Special Handling will print the labels in three groups. The",DIR("?",2)="first will contain labels with drugs marked with an A or C in the DEA Special"
  1. S DIR("?",3)="Handling field, indicating NARCOTICS AND ALCOHOLICS, and CONTROLLED SUBSTANCES-",DIR("?",4)="NON NARCOTIC. The second group will contain ones marked with an S, indicating"
  1. S DIR("?",5)="SUPPLY, and all others will print in the third group.",DIR("?",6)=""
  1. S DIR("T")=DTIME
  1. D ^DIR K DIR D:$D(DIRUT) MESS G:$D(DIRUT) EXIT^PSOSULBL S PSRT=$S(Y="D":"D",Y="P":1,1:0)
  1. I Y="D" W ! K DIR S DIR(0)="SB^P:PATIENT NAME;I:IDENTIFICATION NUMBER",DIR("A")="Within DEA Special Handling, sort by Patient Name or ID#" D ^DIR K DIR D:$D(DIRUT) MESS G:$D(DIRUT) EXIT^PSOSULBL S PSRTONE=Y
  1. S X1=PRTDT,X2=$P(PSOPAR,"^",27) D C^%DTC S XDATE=X K IOP,POP,IO("Q"),ZTSK
  1. PRLBL W ! S %ZIS("A")="Printer 'LABEL' Device: ",%ZIS("B")="",%ZIS="MQN" D ^%ZIS S PSLION=ION I POP S IOP=PSOION D ^%ZIS D MESS G EXIT^PSOSULBL
  1. I $E(IOST)'["P" D MESSL G PRLBL
  1. ;
  1. FDAPRT ; Selects FDA Medication Guide Printer
  1. I $$GET1^DIQ(59,PSOSITE,134)'="" N FDAPRT S FDAPRT="" D I FDAPRT="^"!($G(PSOFDAPT)="") G EXIT^PSOSULBL
  1. . F D Q:FDAPRT'=""
  1. . . S FDAPRT=$$SELPRT^PSOFDAUT($P($G(PSOFDAPT),"^"))
  1. . . I FDAPRT="" W $C(7),!,"You must select a valid FDA Medication Guide printer."
  1. . I FDAPRT'="",(FDAPRT'="^") S PSOFDAPT=FDAPRT
  1. ;
  1. N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
  1. S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19)
  1. K PSOION D ^%ZISC I $D(IO("Q")) K IO("Q")
  1. QUE K %DT,PSOTIME,PSOOUT D NOW^%DTC S %DT="REAX",%DT(0)=%,%DT("B")="NOW",%DT("A")="Queue to run at what time: " D ^%DT K %DT I $D(DTOUT)!(Y<0) D MESS G EXIT^PSOSULBL
  1. S (PSOSUSPR,PSODBQ)=1,PSOTIME=Y
  1. S ZTRTN="BEG^PSOSULBL",ZTDESC="PRINT LABELS FROM SUSPENSE",ZTIO=PSLION,ZTDTH=PSOTIME
  1. S ZTSAVE("PSOSULST(")="" ;Print Suspense by Category //RTW
  1. S PSOG="" F PSOG="PSOPAR","PSOSYS","PSOSUSPR","PSODBQ","PSRT","PSRTONE","PSOPROP","PSLION","PFIO","PSOBARS","PSODTCUT","PSOPRPAS","PRTDT","PDUZ","PSOBAR0","PSOBAR1","PSOSITE","XDATE","PSOTIME","PSOFDAPT" S:$D(@PSOG) ZTSAVE(PSOG)=""
  1. D ^%ZTLOAD W !!,"PRINT FROM SUSPENSE JOB QUEUED!",! D ^%ZISC G EXIT^PSOSULBL
  1. ;G:PSRT'="D" BEG^PSOSULBL
  1. MESS W $C(7),!!?3,"NOTHING QUEUED TO PRINT!",! Q
  1. MESSL W $C(7),!?3,"LABELS MUST BE SENT TO A PRINTER!",! Q
  1. BAIMAIL ;Send mail message
  1. S:'$G(PDUZ) PDUZ=+$G(DUZ)
  1. K ^TMP("PSOM",$J)
  1. N SEQ,XMY,XMDUZ,XMSUB,XMTEXT,SEQ,NAME,PSSN,RX,FILL,FIRST
  1. S SEQ=1
  1. S XMY(PDUZ)=""
  1. S XMY("G.PSO EXTERNAL DISPENSE ALERTS")=""
  1. S XMDUZ="OUTPATIENT PHARMACY PACKAGE"
  1. S XMSUB="BAD ADDRESS SUSPENSE NOT PRINTED"
  1. I $G(PSOSITE) S XMSUB=$$GET1^DIQ(59,PSOSITE,.06)_" "_XMSUB
  1. S ^TMP("PSOM",$J,SEQ)="The following prescriptions with a routing of mail were not printed/sent to",SEQ=SEQ+1
  1. S ^TMP("PSOM",$J,SEQ)="external interface due to the BAD ADDRESS INDICATOR being set and no active",SEQ=SEQ+1
  1. S ^TMP("PSOM",$J,SEQ)="temporary address, or the patient has an active MAIL status of DO NOT MAIL, or",SEQ=SEQ+1
  1. S ^TMP("PSOM",$J,SEQ)="the patient has a foreign address:",SEQ=SEQ+1
  1. S NAME="" F S NAME=$O(^TMP("PSOSM",$J,NAME)) Q:NAME="" D
  1. .S PSSN="" F S PSSN=$O(^TMP("PSOSM",$J,NAME,PSSN)) Q:PSSN="" D
  1. ..S ^TMP("PSOM",$J,SEQ)="",SEQ=SEQ+1
  1. ..S ^TMP("PSOM",$J,SEQ)=NAME_" "_PSSN,FIRST=1
  1. ..S RX=0 F S RX=$O(^TMP("PSOSM",$J,NAME,PSSN,RX)) Q:'RX S FILL="" F S FILL=$O(^TMP("PSOSM",$J,NAME,PSSN,RX,FILL)) Q:FILL="" D
  1. ...I FIRST D S FIRST=0
  1. ....S ^TMP("PSOM",$J,SEQ)=^TMP("PSOM",$J,SEQ)_" ("_$G(^TMP("PSOSM",$J,NAME,PSSN,RX,FILL))_")"
  1. ....S SEQ=SEQ+1
  1. ...S ^TMP("PSOM",$J,SEQ)=" "_$P(^PSRX(RX,0),"^")_" ("_FILL_") "_$P($G(^PSDRUG($P(^PSRX(RX,0),"^",6),0)),"^"),SEQ=SEQ+1
  1. S ^TMP("PSOM",$J,SEQ+1)=""
  1. S XMTEXT="^TMP(""PSOM"",$J," N DIFROM D ^XMD K XMSUB,XMTEXT,XMY,XMDUZ
  1. Q
  1. ;
  1. ; DSH determines whether a prescription has a 3/4 days supply hold
  1. ; condition.
  1. ; Input: REC = Pointer to Suspense file (#52.5)
  1. ; Returns: 1 or 0
  1. ; 1 (one) if 3/4 of days supply has elapsed.
  1. ; 0 (zero) if 3/4 of days supply has not elapsed.
  1. ;
  1. DSH(REC) ; ePharmacy - verify that 3/4 days supply has elapsed before printing from suspense
  1. ;
  1. N COMM,DA,DAYSSUP,DIE,DR,DSHDT,DSHOLD
  1. N PREVRX,PSARR,PSINSUR,RFL,RXIEN,SDT,SFN,SHDT
  1. ;
  1. S DSHOLD=1
  1. S RXIEN=$$GET1^DIQ(52.5,REC,.01,"I")
  1. S RFL=$$GET1^DIQ(52.5,REC,9,"I")
  1. I RFL="" S RFL=$$LSTRFL^PSOBPSU1(RXIEN)
  1. ;
  1. ; If the Rx/Fill is not e-billable, then Quit out.
  1. ;
  1. I '$$EBILLABLE^PSOSULB2(RXIEN,RFL) Q DSHOLD
  1. ;
  1. S DSHDT=$$DSHDT(RXIEN,RFL) ; 3/4 of days supply date
  1. S PREVRX=$P(DSHDT,U,2)
  1. S DSHDT=$P(DSHDT,U)
  1. I DSHDT>DT S DSHOLD=0 D
  1. . I DSHDT'=$$GET1^DIQ(52.5,REC,10,"I") D ; Update Suspense Hold Date and Activity Log
  1. . . ; If a previous Rx is used in the 3/4 days' supply calculation,
  1. . . ; capture that Rx in the activity log.
  1. . . S COMM="3/4 of Days Supply SUSPENSE HOLD until "_$$FMTE^XLFDT(DSHDT,"2D")
  1. . . I PREVRX'="" S COMM=COMM_" (prior Rx "_PREVRX_")"
  1. . . S COMM=COMM_"."
  1. . . S DAYSSUP=$$LFDS(RXIEN)
  1. . . D RXACT^PSOBPSU2(RXIEN,RFL,COMM,"S",+$G(DUZ)) ; Update Activity Log
  1. . . S DR="10///^S X=DSHDT",DIE="^PS(52.5,",DA=REC D ^DIE ; File Suspense Hold Date
  1. . . N DA,DIE,DR,PSOX,SFN,INDT,DEAD,SUB,XOK,OLD
  1. . . S DA=REC,DIE="^PS(52.5,",DR=".02///"_DSHDT D ^DIE
  1. . . S SFN=REC,DEAD=0,INDT=DSHDT D CHANGE^PSOSUCH1(RXIEN,RFL)
  1. . . Q
  1. . Q
  1. ;
  1. Q DSHOLD
  1. ;
  1. DSHDT(RXIEN,RFL) ; ePharmacy function to determine the 3/4 of the days supply date
  1. ; Input: RXIEN = Prescription file #52 ien
  1. ; RFL = fill#
  1. ; Returns: DATE value of last date of service plus 3/4 of days supply
  1. ; PREVRX = Previous Rx if PREVRX^PSOREJP2 identified one that
  1. ; should be used in the 3/4 days' supply calculation.
  1. ;
  1. N FILLDT,DAYSSUP,DSH34,PREVRX
  1. I '$D(^PSRX(RXIEN,0)) Q -1
  1. I $G(RFL)="" Q -1
  1. ;
  1. D PREVRX^PSOREJP2(RXIEN,RFL,,.FILLDT,.DAYSSUP,.PREVRX)
  1. I FILLDT="" Q -1
  1. ;
  1. S DSH34=DAYSSUP*.75 ; 3/4 of Days Supply
  1. S:DSH34["." DSH34=(DSH34+1)\1
  1. ; Return last date of service plus 3/4 of Days Supply date
  1. ; and the previous Rx used in the calculation, if any.
  1. Q $$FMADD^XLFDT(FILLDT,DSH34)_U_PREVRX
  1. ;
  1. ;
  1. ; Description: This function returns the DAYS SUPPLY for the Latest Fill
  1. ; for a Prescription
  1. ; Input: RXIEN = Prescription file #52 IEN
  1. ; Returns: DAYS SUPPLY for the latest fill
  1. ; -1 if RXIEN is not valid
  1. LFDS(RXIEN) ;
  1. N RXFIL
  1. Q:'$D(^PSRX(RXIEN)) -1
  1. S RXFIL=$$LSTRFL^PSOBPSU1(RXIEN)
  1. Q $S(RXFIL=0:$P(^PSRX(RXIEN,0),U,8),1:$P(^PSRX(RXIEN,1,RXFIL,0),U,10))
  1. ;