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

PSONEW2.m

Go to the documentation of this file. 
  1. PSONEW2 ;IHS/DSD/JCM - displays new rx information for edit ;29-May-2012 14:55;PLS
  1.  ;;7.0;OUTPATIENT PHARMACY;**32,37,46,71,94,124,139,157,1005,1006,1009,1013,143,226,237,239,225,1015**;DEC 1997;Build 62
  1.  ;External reference to ^PSDRUG supported by DBIA 221
  1.  ;External reference to ^DPT supported by DBIA 10035
  1.  ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
  1.  ;External reference VADPT supported by DBIA 10061
  1.  ; This routine displays the entered new rx information and
  1.  ; asks if correct, if not allows editing of the data.
  1.  ;------------------------------------------------------------
  1.  ;PSO*237 issue expired error message
  1.  ;
  1.  ; Modified - IHS/CIA/PLS - 01/02/04 - EP, EN1+2 and DISPLAY+3
  1.  ;          - IHS/MSC/PLS - 10/05/07 - Line RX52 - added call to APSPFNC3
  1.  ;                          09/27/10 - Line RX52+1 Added call to KILLOCM^PSORN52
  1.  ;                          10/19/10 - Added RX52E line tag
  1.  ;                          02/13/12 - Line STOP+2
  1. EP ; IHS/CIA/PLS - 01/02/04 - Check for DUE Questionnarie
  1.  ;N APFLAG S APFLAG="N" D ^APSPQ  ; PLS 06/21/04 COMMENTED OUT
  1. START ;
  1.  S (PSONEW("DFLG"),PSONEW2("QFLG"))=0
  1.  D STOP
  1.  D DISPLAY ; Displays information
  1.  ;Copay exemption checks
  1.  D SCP^PSORN52D
  1.  S PSONEWFF=1,PSOFLAG=1 K PSOANSQ,PSOANSQD S PSOCPZ("DFLG")=0,PSONEW("NEWCOPAY")=0
  1.  ;can't check PSOSCA for <50 here because of PSOBILL check in PSOCPB
  1.  I (PSOSCP<50&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1)),$G(DUZ("AG"))="V" D COPAY^PSOCPB W !
  1.  I PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1))!(PSOSCP>49&(PSOBILL=2)) D SC^PSOMLLD2
  1.  I $G(PSOCPZ("DFLG")) K PSONEWFF,PSOANSQD,PSOCPZ("DFLG"),PSONEW("NEWCOPAY") S DIRUT="",PSONEW("DFLG")=1 D ASKX G END
  1.  ;IF MILL BILL, AND COPAY (*******TEST THE COPAY CHECK)
  1.  I $$DT^PSOMLLDT D  I $G(PSOCPZ("DFLG")) K PSONEWFF,PSOANSQD,PSOANSQ,PSOCPZ("DFLG"),PSONEW("NEWCOPAY") S DIRUT="",PSONEW("DFLG")=1 D ASKX G END
  1.  .;New prompts Quit after first '^'
  1.  .I $D(PSOIBQS(PSODFN,"CV")) D CV^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("CV"))) K PSONEW("NEWCOPAY")
  1.  .I $D(PSOIBQS(PSODFN,"VEH")) D VEH^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("VEH"))) K PSONEW("NEWCOPAY")
  1.  .I $D(PSOIBQS(PSODFN,"RAD")) D RAD^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("RAD"))) K PSONEW("NEWCOPAY")
  1.  .I $D(PSOIBQS(PSODFN,"PGW")) D PGW^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("PGW"))) K PSONEW("NEWCOPAY")
  1.  .I $D(PSOIBQS(PSODFN,"SHAD")) D SHAD^PSOMLLD2 I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("SHAD"))) K PSONEW("NEWCOPAY")
  1.  .I $D(PSOIBQS(PSODFN,"MST")) D MST^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("MST"))) K PSONEW("NEWCOPAY")
  1.  .I $D(PSOIBQS(PSODFN,"HNC")) D HNC^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("HNC"))) K PSONEW("NEWCOPAY")
  1.  K PSOCPZ("DFLG"),PSONEWFF
  1.  D ASK K:$G(PSONEW("DFLG")) PSOANSQ G:PSONEW2("QFLG")!PSONEW("DFLG") END
  1.  S PSORX("EDIT")=1 D EN^PSOORNE1(.PSONEW),FULL^VALM1 G:$G(PSORX("FN")) END  I '$G(PSORX("FN")) S PSONEW("DFLG")=1 K PSOANSQ G END ;D EDIT
  1.  G:'$G(PSONEW("DFLG")) START
  1.  S PSONEW("QFLG")=1,PSONEW("DFLG")=0
  1. END D EOJ
  1.  Q
  1.  ;------------------------------------------------------------
  1. STOP K PSEXDT,X,%DT S PSON52("QFLG")=0
  1.  S X1=PSOID,X2=PSONEW("DAYS SUPPLY")*(PSONEW("# OF REFILLS")+1)\1
  1.  ;IHS/MSC/PLS - 02/13/2012 - Next four lines commented out
  1.  ;S X2=$S(PSONEW("DAYS SUPPLY")=X2:X2,+$G(PSONEW("CS")):184,1:366)
  1.  ;I X2<30 D
  1.  ;. N % S %=$P($G(PSORX("PATIENT STATUS")),"^"),X2=30
  1.  ;. S:%?.N %=$P($G(^PS(53,+%,0)),"^") I %["AUTH ABS" S X2=5
  1.  S X2=$S(+$G(PSONEW("CS")):184,1:366)
  1.  D C^%DTC I PSONEW("FILL DATE")>$P(X,".") S PSEXDT=1_"^"_$P(X,".")
  1.  K X1,X2,X,%DT
  1.  Q
  1. DISPLAY ;
  1.  W !!,"Rx # ",PSONEW("RX #")
  1.  W ?23,$E(PSONEW("FILL DATE"),4,5),"/",$E(PSONEW("FILL DATE"),6,7),"/",$E(PSONEW("FILL DATE"),2,3),!,$G(PSORX("NAME")),?30,"#",PSONEW("QTY")
  1.  ; IHS/CIA/PLS - 01/02/04 - Output NDC, AWP,Cost and Triplicate
  1.  W ?36,"NDC ",$S($G(PSONEW("NDC"))]"":PSONEW("NDC"),1:$G(PSODRUG("NDC")))
  1.  I ('$D(IOBON))!('$D(IOBOFF)) S X="IOBON;IOBOFF" D ENDR^%ZISS
  1.  W " ("_$S($G(PSONEW("AWP"))]"":PSONEW("AWP"),$G(PSODRUG("AWP"))]"":PSODRUG("AWP"),1:IOBON_"NO AWP"_IOBOFF)_")"
  1.  W " ("_$S($G(PSONEW("COST"))]"":PSONEW("COST"),$G(PSODRUG("COST"))]"":PSODRUG("COST"),1:IOBON_"NO COST"_IOBOFF)_")"
  1.  W:$G(PSONEW("TRIP"))]"" " TRIPLICATE SERIAL # "_PSONEW("TRIP")
  1.  I $G(SIGOK),$O(SIG(0)) D  K D G TRN
  1.  .F D=0:0 S D=$O(SIG(D)) W !,SIG(D) Q:'$O(SIG(D))
  1.  E  S X=PSONEW("SIG") D SIGONE^PSOHELP W !,$G(INS1)
  1. TRN ;I $G(PSOPRC) F I=0:0 S I=$O(PRC(I)) Q:'I  W !,PRC(I)
  1.  W !!,$S($G(PSODRUG("TRADE NAME"))]"":PSODRUG("TRADE NAME"),1:PSODRUG("NAME"))
  1.  W !,PSONEW("PROVIDER NAME"),?25,PSORX("CLERK CODE"),!,"# of Refills: ",PSONEW("# OF REFILLS"),!
  1.  ; IHS/CIA/PLS - 01/02/04 - Output Manufacturer, Lot # and Expiration Date
  1.  N EXPDT S EXPDT=$$FMTE^XLFDT($G(PSONEW("EXPIRATION DATE")),"5DZ") S:'$P(EXPDT,"/",2) EXPDT=$P(EXPDT,"/")_"/"_$P(EXPDT,"/",3)
  1.  I APSPMAN=1 D
  1.  .W !,"Drug Mfg: ",$G(PSONEW("MANUFACTURER")),?35,"Exp Date: ",$G(EXPDT)
  1.  .W ?58,"Lot #: ",$G(PSONEW("LOT #"))
  1.  E  I APSPMAN=2 D
  1.  .W !,?35,"Exp Date: ",$G(EXPDT)
  1.  Q
  1.  ;
  1. ASK ;
  1.  K DIR,X,Y S DIR("A")="Is this correct"
  1.  S DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR I $D(DIRUT) S PSONEW("DFLG")=1 G ASKX
  1. ASK1 I Y D  S PSONEW2("QFLG")=1
  1.  .S:$G(PSONEW("MAIL/WINDOW"))["W" BINGCRT=Y,BINGRTE="W"
  1.  .D:+$G(PSEXDT)
  1.  ..S Y=PSONEW("FILL DATE") X ^DD("DD") W !!,$C(7),Y_" fill date is greater than possible expiration date of " S Y=$P(PSEXDT,"^",2) X ^DD("DD") W Y_"."
  1.  .D DCORD K RORD,^TMP("PSORXDC",$J)
  1. ASKX I $D(DIRUT) D
  1.  .I +$G(PSEXDT) K DIRUT S (PSONEW2("QFLG"),PSONEW2("DFLG"),PSONEW("DFLG"),Y)=1
  1.  K X,Y,DIRUT,DTOUT,DUOUT
  1.  D:+$G(PSEXDT) PAUSE^VALM1
  1.  Q
  1. DCORD ;dc rxs and pending orders after new order is entered
  1.  F RORD=0:0 S RORD=$O(^TMP("PSORXDC",$J,RORD)) Q:'RORD  D @$S($P(^TMP("PSORXDC",$J,RORD,0),"^")="P":"PEN",1:"RX52")
  1.  K RORD
  1.  Q
  1. PEN ;pending ^tmp("psorxdc",$j,rord,0)="p^"_rord_"^"_msg
  1.  S $P(^PS(52.41,RORD,0),"^",3)="DC",^PS(52.41,RORD,4)=$P(^TMP("PSORXDC",$J,RORD,0),"^",3)
  1.  K ^PS(52.41,"AOR",PSODFN,+$P($G(^PS(52.41,RORD,"INI")),"^"),RORD)
  1.  D EN^PSOHLSN($P(^PS(52.41,RORD,0),"^"),"OC",$P(^TMP("PSORXDC",$J,RORD,0),"^",3),"D") W $C(7),!," -Pending Order was discontinued..."
  1.  D PSOUL^PSSLOCK(RORD_"S") K ^TMP("PSORXDC",$J,RORD,0)
  1.  Q
  1.  ; IHS/MSC/PLS - 10/05/07 - Restructured RX52 to process auto RTS/Delete
  1. RX52 ;rxs in file 52 ^tmp("psorxdc",$j,rord,0)=52^rord^msg^rea^act^sta^dnm^apsprts
  1.  I $P(^TMP("PSORXDC",$J,RORD,0),U,9) D KILLOCM^PSORN52(+RORD) G RX52E  ;IHS/MSC/PLS - 09/27/10 - Removed chronic med flag
  1.  I $P(^TMP("PSORXDC",$J,RORD,0),U,8) D
  1.  .D EN^APSPFNC3(RORD)
  1.  .W !," -Rx "_$P(^PSRX(RORD,0),"^")_" has been auto RTS/Deleted...",!
  1.  E  D
  1.  .S PSCAN($P(^PSRX(RORD,0),"^"))=RORD_"^"_$P(^TMP("PSORXDC",$J,RORD,0),"^",4)
  1.  .S MSG=$P(^TMP("PSORXDC",$J,RORD,0),"^",3),REA=$P(^(0),"^",4),ACT=$P(^(0),"^",5)
  1.  .N PSONOOR S PSONOOR="D",DUP=1,DA=RORD D CAN^PSOCAN K PSONOOR
  1.  .W !," -Rx "_$P(^PSRX(RORD,0),"^")_" has been discontinued...",!
  1. RX52E K PSOSD($P(^TMP("PSORXDC",$J,RORD,0),"^",6),$P(^TMP("PSORXDC",$J,RORD,0),"^",7))
  1.  D PSOUL^PSSLOCK(RORD) K ^TMP("PSORXDC",$J,RORD,0)
  1.  Q
  1.  ;
  1. EDIT ;
  1.  S PSORX("EDIT")=1
  1.  D ^PSONEW3
  1.  S PSONEW("DFLG")=$S($G(PSORX("DFLG")):1,1:0)
  1.  Q
  1.  ;
  1. EOJ ;
  1.  K PSONEW2,PSORX("EDIT"),PSORX("DFLG"),PSOEDIT,PSOSCA
  1.  Q
  1.  ;
  1. EN1(PSONEW2) ; Entry point to just display and ask if okay
  1.  S PSONEW("DFLG")=0
  1.  ; IHS/CIA/PLS - 01/06/04 - Set NDC, AWP, and COST array variables
  1.  S:$G(PSONEW2("NDC"))]"" PSONEW("NDC")=PSONEW2("NDC")
  1.  S:$G(PSONEW2("AWP"))]"" PSONEW("AWP")=PSONEW2("AWP")
  1.  S:$G(PSONEW2("COST"))]"" PSONEW("COST")=PSONEW2("COST")
  1.  I $G(^PSRX(PSONEW2("IRXN"),0))']"" S PSONEW("DFLG")=1 G EN1X
  1.  S PSOX=^PSRX(PSONEW2("IRXN"),0),PSONEW("TRADE NAME")=$G(^("TN")),PSONEW("FILL DATE")=$P($G(^(2)),"^",2)
  1.  S PSONEW("RX #")=$P(PSOX,"^"),PSORX("NAME")=$P(^DPT($P(PSOX,"^",2),0),"^")
  1.  S PSONEW("QTY")=$P(PSOX,"^",7),PSODRUG("NAME")=$P(^PSDRUG($P(PSOX,"^",6),0),"^"),PSONEW("# OF REFILLS")=$P(PSOX,"^",9)
  1.  S PSORX("CLERK CODE")=$P(^VA(200,$P(PSOX,"^",16),0),"^")
  1.  S:$G(PSONEW("PROVIDER NAME"))="" PSONEW("PROVIDER NAME")=$P(^VA(200,$P(PSOX,"^",4),0),"^")
  1.  S PSONEW("SIG")=$P($G(^PSRX(PSONEW2("IRXN"),"SIG")),"^")
  1.  D DISPLAY
  1.  D ASK
  1.  I PSONEW("DFLG")=1 S PSONEW2("DFLG")=1
  1. EN1X ;
  1.  Q
  1.  ;
  1. EXPR ;Display Expired error message                               ;PSO*237
  1.  S PSONEW("DFLG")=1
  1.  W $C(7)
  1.  S VALMSG="Order is older than 365 days and can't be finished"
  1.  S XQORM("B")="DC"
  1.  Q