Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (15 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

Location:
WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP
Files:
144 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFIN.m

    r613 r623  
    1 PSOAFIN ;VFA/HMS autofinish rx's from cprs ;2:33 PM  11 Nov 2008
    2         ;;7.0;OUTPATIENT PHARMACY;**208,250003**;DEC 1997;Build 41
    3         ; Copyright (C) 2007 WorldVistA
    4         ;
    5         ; This program is free software; you can redistribute it and/or modify
    6         ; it under the terms of the GNU General Public License as published by
    7         ; the Free Software Foundation; either version 2 of the License, or
    8         ; (at your option) any later version.
    9         ;
    10         ; This program is distributed in the hope that it will be useful,
    11         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    12         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    13         ; GNU General Public License for more details.
    14         ;
    15         ; You should have received a copy of the GNU General Public License
    16         ; along with this program; if not, write to the Free Software
    17         ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    18         ;
    19         ; Please note this routine is the gateway to modified routines that autofinish pending rxs entered by a provider.  The modified routines allow rxs to be finished automatically & properly update File#100 and File#52.
    20         ; The routines do not autocheck orders, check for duplicates, concatenate comments to sigs etc. All of the pharmacist checks will be done by the dispensing pharmacist.
    21         ; $G(PSOAFYN) is tested at beginning of line to determine if the original code will run or if code modified to do AutoFinish,Rx will run
    22 EN      I '$D(^PS(52.41,"B",+ORDERID)) Q  ;Check for pending order
    23         N ZTRTN,ZTDESC,ZTDTH,ZTSAVE,ZTSK,ZTIO
    24         S ZTRTN="EN1^PSOAFIN",ZTDESC="Autofinish,Rx",ZTDTH=$H,ZTDTH=$S(($P(ZTDTH,",",2)+10)\86400:(1+ZTDTH)_","_((($P(ZTDTH,",",2)+10)#86400)/100000),1:(+ZTDTH)_","_($P(ZTDTH,",",2)+10))
    25         S ZTSAVE("ORL")="",ZTSAVE("ORVP")="",ZTSAVE("VALMWD")=""
    26         S ZTSAVE("ORL")="",ZTSAVE("ORDERID")=""
    27         S ZTIO="NULL" ;WVEHR - 250003
    28         D ^%ZTLOAD
    29         Q  ;Quits back to ORWDX
    30         ;
    31 EN1     ;Autofinish Task Begins Here
    32         ;D ^%ZTER ; For testing *ONLY*
    33         ;S IOP="NULL" D ^%ZIS U IO
    34         S PSOSITE=$G(^SC(+ORL,"AFRXSITE")) ;+ORL is hospital location from ORWDX
    35         Q:PSOSITE=""  ;Quits with no autofinish if File#44 does not point to File#59
    36         I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",1)'="Y" Q  ;Quits if Autofinish not turned on in File#59 Field#459001
    37         ;Check patient eligibility
    38         S VFAELD="Y"
    39         I $D(^PS(59,PSOSITE,"RXFINEL",1)) S VFAELD="N",DFN=+ORVP D ELIG^VADPT D
    40         .S VFAEL=0
    41         .F L=1:1 S VFAEL=$O(^PS(59,PSOSITE,"RXFINEL",VFAEL)) Q:VFAEL=""!(VFAEL="B")!(VFAELD="Y")  D
    42         ..S VFAELL=$P(^PS(59,PSOSITE,"RXFINEL",VFAEL,0),"^",1)
    43         ..I VFAELL=+VAEL(1) S VFAELD="Y"
    44         Q:VFAELD="N"
    45         ;Check Date Verify Code Last Changed and check Verify Code never expires.
    46         S PSOAFYN="Y" ;Sets flag if Autofinish,Rx is turned on & is used throughout the routines
    47         S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX"
    48         D ^DIC K DIC
    49         Q:+Y=-1  ;Quits if AUTOFINISH,RX not a user
    50         S DA=+Y
    51         D DUZ^XUP(DA) ;Sets DUZ for AUTOFINISH,RX
    52         K PSOAFDON ;Makes sure flag for quitting patient loop through File#52.41 is null
    53         S PSOAFDFN=+ORVP ;From ORWDX CPRS Call is DFN of patient auto finishing rxs for
    54         S PSOAFPAT=$P($G(^PS(55,PSOAFDFN,"PS")),"^") ;Sets patient status if it exists
    55         I $G(PSOAFPAT)="" D
    56         .I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",2)'="" D
    57         ..S ^PS(55,PSOAFDFN,"PS")=$P(^PS(59,PSOSITE,"RXFIN"),"^",2)
    58         ..S PSOAFPAT=$P(^PS(59,PSOSITE,"RXFIN"),"^",2)
    59         I $G(PSOAFPAT)="" D NOPATS ;Prints message if no patient status
    60         S PSORX("PATIENT STATUS")=PSOAFPAT ;HMS 2007_03_11
    61         S PSOAFPNM=$P(^DPT(PSOAFDFN,0),"^",1)
    62         S (PSODFN,PAT)=PSOAFDFN,PSOFINY=PSOAFDFN_"^"_PSOAFPNM
    63         D ^PSOORFIN ;Begins execution of Rx Finishing routines
    64         K PSOAFDFN,PSOAFYN,PSOAFDON,PSOAFDUZ,PSOAFPAT,PAT,PSODFN,PSOFINY,PSOSITE
    65         Q  ;Autofinish Task Quits Here
    66         ;
    67         ;
    68         ;
    69 NOPATS  ;Quit message prints instead of prescription if no patient status
    70         ;Checks for nw orders in File#52.41
    71         ;I $G(REA)'="" Q  ;Quits if not signing a new rx
    72         S PSOAFORB=+ORDERID-1,PSOAFORB=$O(^PS(52.41,"B",PSOAFORB)),PSOAFOB1="",PSOAFOB1=$O(^PS(52.41,"B",PSOAFORB,PSOAFOB1)),PSOAFRXS=$P(^PS(52.41,PSOAFOB1,0),"^",3)
    73         I PSOAFRXS'="NW" K PSOAFORB,PSOAFOB1,PSOAFRXS Q  ;Quits if no new pending rxs in File#52.41
    74         K PSOAFORB,PSOAFOB1,PSOAFRXS
    75         I $G(PSOAFYN)="Y" S PSOLAP=$G(^SC(+ORL,"AFRXCLINPRNT")) ;vfah sets printer as defined in File#44
    76         I $G(PSOAFYN)="Y" I PSOLAP="" S DIRUT="^" G:$D(DIRUT)!($D(DUOUT)) EX ;vfah If DIRUT set to "^" will bypass label printing, queueing etc if no printer defined in File#44
    77         I $G(PSOAFYN)="Y" S PSOLAP=$P(^%ZIS(1,PSOLAP,0),"^",1) ;vhah sets PSOLAP to literal of printer name
    78         S PSOAFPNM=$P(^DPT(PSOAFDFN,0),"^",1)
    79         S PSOAFPNM=$P(^DPT(PSOAFDFN,0),"^",1)
    80 QLBL    ;Queues no patient status notice
    81         D ^%ZISC
    82         S ZTRTN="PLBL^PSOAFIN",ZTIO=$G(PSOLAP),ZTDESC="Autofinish,Rx No Patient Status Message",ZTDTH=$H ;Sets Taskman variables
    83         Q:PSOLAP=""
    84         S ZTSAVE("*")=""
    85         D ^%ZTLOAD
    86         H 1
    87         D ^%ZISC
    88         K PSOAFDFN,PSOAFPNM
    89         Q
    90         ;
    91 PLBL    ;Prints no patient status notice
    92         W !,"CAN NOT AUTO-FINISH or MANUALLY FINISH RX(S)"
    93         W !!,"FOR PATIENT:  ",PSOAFPNM_"  "_$E($P($G(^DPT(PSOAFDFN,0)),"^",9),4,5)_"-"_$E($P($G(^DPT(PSOAFDFN,0)),"^",9),6,9)
    94         W !!,"THERE IS NO PATIENT STATUS SET FOR THIS PATIENT."
    95         W !!,"PLEASE ENTER A PATIENT STATUS FOR THIS PATIENT"
    96         W !,"AND THEN SIGN RXS IN CPRS TO AUTOFINISH RXS"
    97         W !!,"THANK YOU"
    98         W !,"AUTOFINISH,RX"
    99         W !,$$FMTE^XLFDT($$NOW^XLFDT())
    100         D ^%ZISC
    101 EX      K PSOAFDFN,PSOAFYN,PSOAFDON,PSOAFDUZ,PSOAFPNM,PSOAFPAT,PAT,PSODFN,PSOFINY,PSOSITE
    102         Q
    103         ;
    104 DISPD   ;Selects dispense drug if not selected in CPRS
    105         S PSI=0
    106         F PSI=0:0 S PSI=$O(^PSDRUG("ASP",PSODRUG("OI"),PSI)) Q:'PSI  I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($P($G(^PSDRUG(PSI,2)),"^",3)'["O":0,1:1) D  Q:PSI>0
    107         .S $P(OR0,"^",9)=PSI,$P(^PS(52.41,ORD,0),"^",9)=PSI
    108         S VFASDD="Y"
    109         Q
     1PSOAFIN ;VFA/HMS autofinish rx's from cprs ;4/21/07  19:10
     2 ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 39
     3 ; Copyright (C) 2007 WorldVistA
     4 ;
     5 ; This program is free software; you can redistribute it and/or modify
     6 ; it under the terms of the GNU General Public License as published by
     7 ; the Free Software Foundation; either version 2 of the License, or
     8 ; (at your option) any later version.
     9 ;
     10 ; This program is distributed in the hope that it will be useful,
     11 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     12 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     13 ; GNU General Public License for more details.
     14 ;
     15 ; You should have received a copy of the GNU General Public License
     16 ; along with this program; if not, write to the Free Software
     17 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     18 ;
     19 ; Please note this routine is the gateway to modified routines that autofinish pending rxs entered by a provider.  The modified routines allow rxs to be finished automatically & properly update File#100 and File#52.
     20 ; The routines do not autocheck orders, check for duplicates, concatenate comments to sigs etc. All of the pharmacist checks will be done by the dispensing pharmacist.
     21 ; $G(PSOAFYN) is tested at beginning of line to determine if the original code will run or if code modified to do AutoFinish,Rx will run
     22EN I '$D(^PS(52.41,"B",+ORDERID)) Q  ;Check for pending order
     23 N ZTRTN,ZTDESC,ZTDTH,ZTSAVE,ZTSK
     24 S ZTRTN="EN1^PSOAFIN",ZTDESC="Autofinish,Rx",ZTDTH=$H,ZTDTH=$S(($P(ZTDTH,",",2)+10)\86400:(1+ZTDTH)_","_((($P(ZTDTH,",",2)+10)#86400)/100000),1:(+ZTDTH)_","_($P(ZTDTH,",",2)+10))
     25 S ZTSAVE("ORL")="",ZTSAVE("ORVP")="",ZTSAVE("IO*")="",ZTSAVE("VALMWD")="",ZTSAVE("ORL")="",ZTSAVE("ORDERID")="" D ^%ZTLOAD
     26 Q  ;Quits back to ORWDX
     27 ;
     28EN1 ;Autofinish Task Begins Here
     29 S PSOSITE=$G(^SC(+ORL,"AFRXSITE")) ;+ORL is hospital location from ORWDX
     30 Q:PSOSITE=""  ;Quits with no autofinish if File#44 does not point to File#59
     31 I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",1)'="Y" Q  ;Quits if Autofinish not turned on in File#59 Field#459001
     32 ;Check patient eligibility
     33 S VFAELD="Y"
     34 I $D(^PS(59,PSOSITE,"RXFINEL",1)) S VFAELD="N",DFN=+ORVP D ELIG^VADPT D
     35 .S VFAEL=0
     36 .F L=1:1 S VFAEL=$O(^PS(59,PSOSITE,"RXFINEL",VFAEL)) Q:VFAEL=""!(VFAEL="B")!(VFAELD="Y")  D
     37 ..S VFAELL=$P(^PS(59,PSOSITE,"RXFINEL",VFAEL,0),"^",1)
     38 ..I VFAELL=+VAEL(1) S VFAELD="Y"
     39 Q:VFAELD="N"
     40 ;Check Date Verify Code Last Changed and check Verify Code never expires.
     41 S PSOAFYN="Y" ;Sets flag if Autofinish,Rx is turned on & is used throughout the routines
     42 S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX"
     43 D ^DIC K DIC
     44 Q:+Y=-1  ;Quits if AUTOFINISH,RX not a user
     45 S DA=+Y
     46 D DUZ^XUP(DA) ;Sets DUZ for AUTOFINISH,RX
     47 K PSOAFDON ;Makes sure flag for quitting patient loop through File#52.41 is null
     48 S PSOAFDFN=+ORVP ;From ORWDX CPRS Call is DFN of patient auto finishing rxs for
     49 S PSOAFPAT=$P($G(^PS(55,PSOAFDFN,"PS")),"^") ;Sets patient status if it exists
     50 I $G(PSOAFPAT)="" D
     51 .I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",2)'="" D
     52 ..S ^PS(55,PSOAFDFN,"PS")=$P(^PS(59,PSOSITE,"RXFIN"),"^",2)
     53 ..S PSOAFPAT=$P(^PS(59,PSOSITE,"RXFIN"),"^",2)
     54 I $G(PSOAFPAT)="" D NOPATS ;Prints message if no patient status
     55 S PSORX("PATIENT STATUS")=PSOAFPAT ;HMS 2007_03_11
     56 S PSOAFPNM=$P(^DPT(PSOAFDFN,0),"^",1)
     57 S (PSODFN,PAT)=PSOAFDFN,PSOFINY=PSOAFDFN_"^"_PSOAFPNM
     58 D ^PSOORFIN ;Begins execution of Rx Finishing routines
     59 K PSOAFDFN,PSOAFYN,PSOAFDON,PSOAFDUZ,PSOAFPAT,PAT,PSODFN,PSOFINY,PSOSITE
     60 Q  ;Autofinish Task Quits Here
     61 ;
     62 ;
     63 ;
     64NOPATS ;Quit message prints instead of prescription if no patient status
     65 ;Checks for nw orders in File#52.41
     66 ;I $G(REA)'="" Q  ;Quits if not signing a new rx
     67 S PSOAFORB=+ORDERID-1,PSOAFORB=$O(^PS(52.41,"B",PSOAFORB)),PSOAFOB1="",PSOAFOB1=$O(^PS(52.41,"B",PSOAFORB,PSOAFOB1)),PSOAFRXS=$P(^PS(52.41,PSOAFOB1,0),"^",3)
     68 I PSOAFRXS'="NW" K PSOAFORB,PSOAFOB1,PSOAFRXS Q  ;Quits if no new pending rxs in File#52.41
     69 K PSOAFORB,PSOAFOB1,PSOAFRXS
     70 I $G(PSOAFYN)="Y" S PSOLAP=$G(^SC(+ORL,"AFRXCLINPRNT")) ;vfah sets printer as defined in File#44
     71 I $G(PSOAFYN)="Y" I PSOLAP="" S DIRUT="^" G:$D(DIRUT)!($D(DUOUT)) EX ;vfah If DIRUT set to "^" will bypass label printing, queueing etc if no printer defined in File#44
     72 I $G(PSOAFYN)="Y" S PSOLAP=$P(^%ZIS(1,PSOLAP,0),"^",1) ;vhah sets PSOLAP to literal of printer name
     73 S PSOAFPNM=$P(^DPT(PSOAFDFN,0),"^",1)
     74 S PSOAFPNM=$P(^DPT(PSOAFDFN,0),"^",1)
     75QLBL ;Queues no patient status notice
     76 D ^%ZISC
     77 S ZTRTN="PLBL^PSOAFIN",ZTIO=$G(PSOLAP),ZTDESC="Autofinish,Rx No Patient Status Message",ZTDTH=$H ;Sets Taskman variables
     78 Q:PSOLAP=""
     79 S ZTSAVE("*")=""
     80 D ^%ZTLOAD
     81 H 1
     82 D ^%ZISC
     83 K PSOAFDFN,PSOAFPNM
     84 Q
     85 ;
     86PLBL ;Prints no patient status notice
     87 W !,"CAN NOT AUTO-FINISH or MANUALLY FINISH RX(S)"
     88 W !!,"FOR PATIENT:  ",PSOAFPNM_"  "_$E($P($G(^DPT(PSOAFDFN,0)),"^",9),4,5)_"-"_$E($P($G(^DPT(PSOAFDFN,0)),"^",9),6,9)
     89 W !!,"THERE IS NO PATIENT STATUS SET FOR THIS PATIENT."
     90 W !!,"PLEASE ENTER A PATIENT STATUS FOR THIS PATIENT"
     91 W !,"AND THEN SIGN RXS IN CPRS TO AUTOFINISH RXS"
     92 W !!,"THANK YOU"
     93 W !,"AUTOFINISH,RX"
     94 W !,$$FMTE^XLFDT($$NOW^XLFDT())
     95 D ^%ZISC
     96EX K PSOAFDFN,PSOAFYN,PSOAFDON,PSOAFDUZ,PSOAFPNM,PSOAFPAT,PAT,PSODFN,PSOFINY,PSOSITE
     97 Q
     98 ;
     99DISPD ;Selects dispense drug if not selected in CPRS
     100 S PSI=0
     101 F PSI=0:0 S PSI=$O(^PSDRUG("ASP",PSODRUG("OI"),PSI)) Q:'PSI  I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($P($G(^PSDRUG(PSI,2)),"^",3)'["O":0,1:1) D  Q:PSI>0
     102 .S $P(OR0,"^",9)=PSI,$P(^PS(52.41,ORD,0),"^",9)=PSI
     103 S VFASDD="Y"
     104 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFPT1.m

    r613 r623  
    1 PSOAFPT1        ;VFA/HMS Autofinish Star Micronics Landscape print; 3/1/07 7:13pm ; 3/1/07 9:48pm
    2         ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 41
    3         ; Copyright (C) 2007 WorldVistA
    4         ;
    5         ; This program is free software; you can redistribute it and/or modify
    6         ; it under the terms of the GNU General Public License as published by
    7         ; the Free Software Foundation; either version 2 of the License, or
    8         ; (at your option) any later version.
    9         ;
    10         ; This program is distributed in the hope that it will be useful,
    11         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    12         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    13         ; GNU General Public License for more details.
    14         ;
    15         ; You should have received a copy of the GNU General Public License
    16         ; along with this program; if not, write to the Free Software
    17         ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    18 BEGLP   ;
    19 PRNT    D PRNT^PSOAFPTS ;For testing until landscape code completed
     1PSOAFPT1 ;VFA/HMS Autofinish Star Micronics Landscape print; 3/1/07 7:13pm ; 3/1/07 9:48pm
     2 ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 39
     3 ; Copyright (C) 2007 WorldVistA
     4 ;
     5 ; This program is free software; you can redistribute it and/or modify
     6 ; it under the terms of the GNU General Public License as published by
     7 ; the Free Software Foundation; either version 2 of the License, or
     8 ; (at your option) any later version.
     9 ;
     10 ; This program is distributed in the hope that it will be useful,
     11 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     12 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     13 ; GNU General Public License for more details.
     14 ;
     15 ; You should have received a copy of the GNU General Public License
     16 ; along with this program; if not, write to the Free Software
     17 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     18BEGLP ;
     19PRNT D PRNT^PSOAFPTS ;For testing until landscape code completed

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFPTL.m

    r613 r623  
    1 PSOAFPTL        ;VFA/HMS autofinish print for laser printer ; 3/6/07 9:25pm
    2         ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 41
    3         ; Copyright (C) 2007 WorldVistA
    4         ;
    5         ; This program is free software; you can redistribute it and/or modify
    6         ; it under the terms of the GNU General Public License as published by
    7         ; the Free Software Foundation; either version 2 of the License, or
    8         ; (at your option) any later version.
    9         ;
    10         ; This program is distributed in the hope that it will be useful,
    11         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    12         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    13         ; GNU General Public License for more details.
    14         ;
    15         ; You should have received a copy of the GNU General Public License
    16         ; along with this program; if not, write to the Free Software
    17         ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    18 BEGLP   ;
    19         U IO ;hms fax stuff
    20         ;
    21         F DR=1:1 Q:$G(SGY(DR))=""  S SN=19+DR D
    22         .S AFSIG(SN)=$G(SGY(DR))
    23         S SIGL=DR-1
    24         ;
    25         ;CHECK FOR ES
    26         S AFESFLAG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",3)
    27         S AFORD=$P(^PSRX(RX,"OR1"),"^",2)
    28         I $G(AFESFLAG)="Y" D
    29         .S AFES=$P($G(^OR(100,AFORD,8,1,0)),"^",4)
    30         .I $G(AFES)=1 S AFESYN="Y"
    31         .I $G(AFESYN)="Y" S AFESIGN=$P($G(^OR(100,AFORD,8,1,0)),"^",5)
    32         ;
    33         ;CHECK FOR SCHEDULE II WET SIGNATUIRE
    34         S AFWET2=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",6)
    35         S AFDEA=$P(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),0),"^",3)
    36         ;
    37         I $G(AFWET2)="Y"&($G(AFDEA)["2") S AFESFLAG="" ;Turns off ES for Sch IIs if wet sig for IIs set in File#59
    38         I $G(AFWET2)="Y"&($G(AFDEA)["2") S AFESYN=""
    39         ;
    40         ;Get Synonym
    41         S AFS=0,DONE="N",AFSYN="" F L=1:1 S AFS=$O(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS)) Q:AFS=""!(DONE="Y")  D
    42         .I $P(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS,0),"^",3)="0" D
    43         ..S AFSYN=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS,0)),"^",1),DONE="Y"
    44         K DONE
    45         ;
    46 FAX     ;
    47         K AFFAX
    48         S FAXNUM=$G(PSOAFFXP) ;PSOAFFXP from PSOLBLN
    49         S FAXLCNUM=$G(PSOAFFXL)_"@"_FAXNUM
    50         S FAXSER=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",10)
    51         I $G(FAXNUM)'=""&(FAXSER'="") D
    52         . S AFFAX="Y"
    53         I IO["AFFAX"!($G(AFFAX)="Y") D
    54         .D NOW^%DTC
    55         .S FAXDATE=$P(%,".",1)_"Z"_$P(%,".",2)
    56         .S FAXJOB=RX_"Z"_DFN_"Z"_FAXDATE
    57         .D OPEN^%ZISH("HFSFAX",FAXSER,FAXJOB_"+"_FAXLCNUM_".TXT","A")
    58         .S AFFAX="Y"
    59         .U IO
    60         ;
    61         ;Checks to see if 1st 3 lines should print
    62         S PSOAFPFT=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",9)
    63         ;
    64 EN1     S OFF=$P(PS,"^",1)
    65         W $S(PSOAFPFT="N":"",1:OFF)
    66         ;
    67         S OFFAD=$P(PS,"^",7)_","_STATE_"  "_$G(PSOHZIP)
    68         W !
    69         W $S(PSOAFPFT="N":"",1:OFFAD)
    70         ;
    71         S OFFTEL=$P(PS,"^",3)_"-"_$P(PS,"^",4)
    72         W !
    73         W $S(PSOAFPFT="N":"",1:OFFTEL)
    74         ;
    75         S OFFFREE=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",4)
    76         W !,OFFFREE
    77         ;
    78         W !,"---------------------------------------------------------------",!
    79         ;
    80         W !,"Rx for: "
    81         ;
    82         D 6^VADPT,PID^VADPT
    83         S PSOAFPTI=$S(DUZ("AG")="V":$E($G(VA("PID")),5,12),1:$G(VA("PID")))
    84         S AFPNAM=PNM_" "_$G(PSOAFPTI)
    85         W AFPNAM
    86         ;
    87         S AFPADD1=$G(VAPA(1))
    88         W !,"        ",AFPADD1
    89         ;
    90         S AFPADD2=$G(ADDR(2))
    91         W !,"        ",AFPADD2
    92         ;
    93         S AFPADD3=$G(ADDR(3))
    94         W !,"        ",AFPADD3
    95         ;
    96         S AFPADD4=$G(ADDR(4))
    97         W !,"        ",AFPADD4
    98         ;
    99         W !,"---------------------------------------------------------------",!
    100         S AFDRUG=DRUG
    101         W !,AFDRUG
    102         ;
    103         S SYNFLAG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",5)
    104         I SYNFLAG="Y"&(AFSYN'="") D
    105         .W !,"Also known as: "
    106         .W AFSYN
    107         ;
    108         I $P($G(^PSRX(RX,"RXFIN")),"^",1)="Y" S VFASDD="Y"
    109         I $G(VFASDD)="Y" D
    110         .W !,"Pharmacy may choose strength(s) of drug to meet requirements of directions"
    111         ;
    112         ;
    113 SIG     S SN=19
    114         W !
    115         F L=1:1:SIGL S SN=SN+1 W !,AFSIG(SN)
    116         W !
    117         ;
    118         W !,"   Dispense: "
    119         S AFDISP=$G(QTY)_" "_$G(PSDU)
    120         W AFDISP
    121         ;
    122         I $G(VFASDD)="Y" W "     Pharmacy to adjust qty for # of days"
    123         ;
    124         W !,"Days Supply: "
    125         S VFADAYS=$G(DAYS)
    126         W VFADAYS
    127         ;
    128         W !,"  Refill(s): "
    129         S AFRF=$P(RXY,"^",9)
    130         W AFRF
    131         ;
    132         W !," Issue Date: "
    133         W DATE
    134         ;
    135         ;Print Diagnosis
    136         I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",8)="Y" D
    137 DIAG    .W !,"  Diagnosis:"
    138         .S AFICD9="None",AFICD="Not Available"
    139         .I $D(^OR(100,AFORD,5.1,0)) D
    140         ..S AFORL=0
    141         ..F L=1:1 S AFORL=$O(^OR(100,AFORD,5.1,AFORL)) Q:AFORL="B"!(AFORL=0)!(AFORL="")  D
    142         ...S AFORIN=$P($G(^OR(100,AFORD,5.1,AFORL,0)),"^",1)
    143         ...I AFORIN>"" D
    144         ....S AFICD9=$P($G(^ICD9(AFORIN,0)),"^",1)
    145         ....S AFICD=$P($G(^ICD9(AFORIN,0)),"^",3)
    146         ....W ?13,AFICD9,?23,AFICD
    147         .I AFICD9="None" W ?13,AFICD9,?23,AFICD
    148         ;
    149         ;Prints DOB
    150         I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",7)="Y" D
    151         .S PSOAFDOB=$P($G(VADM(3)),"^",2)
    152         .W !,"        DOB: "_PSOAFDOB,!
    153         ;
    154         ;Prints Provider Comments
    155         ;W "MD Comments:"
    156         K ^UTILITY($J,"W") S PSNACNT=1,DIWL=0,DIWR=48,DIWF="",(PSSIXFL,PSSEVFL)=0 F ZZ=0:0 S ZZ=$O(^PSRX(RX,"PRC",ZZ)) Q:'ZZ  I $D(^(ZZ,0)) S X=^(0) D ^DIWP
    157         ;D ^DIWW
    158         I $D(^UTILITY($J,"W")) D
    159         .W "MD Comments:"
    160         .F ZZ=0:0 S ZZ=$O(^UTILITY($J,"W",DIWL,ZZ)) Q:'ZZ  I $D(^(ZZ,0)) W ?13,^(0),!
    161         K ^UTILITY($J,"W")
    162         ;
    163 SIGN    ;Prints DEA if it exists-if no DEA# prints VA# if it exists
    164         I $G(AFESFLAG)="Y" D
    165         .I $G(AFESYN)="Y" D
    166         ..S AFDEA=$$GET1^DIQ(200,AFESIGN,53.2,"I")
    167         ..I AFDEA="" D
    168         ...S AFDEA=$$GET1^DIQ(200,AFESIGN,53.3,"I")
    169         ..S AFESIGNN=$$GET1^DIQ(200,AFESIGN,.01,"I")
    170         ..S AFSIGN=$G(AFESIGNN)_"  "_AFDEA
    171         ;
    172 SIGN1   I $G(AFESFLAG)'="Y" D
    173         .W !!!,"Signature:_________________________________________________"
    174         .;vfah prints DEA if it exists-if no DEA# prints VA# if it exists
    175         .S AFDEA=$$GET1^DIQ(200,PSOAFPRV,53.2,"I")
    176         .I AFDEA="" D
    177         ..S AFDEA=$$GET1^DIQ(200,PSOAFPRV,53.3,"I")
    178         .S AFSIGN="           "_$G(PHYS)_"  "_AFDEA
    179         ;
    180 SIGNP   I $G(AFESYN)="Y" S AFSIGN="Signed: /ES/"_AFSIGN
    181         W !,AFSIGN
    182         ;
    183         K AFESYN,AFESIGN,AFESIGNN
    184         ;
    185         W !!,"Must write BRAND NECESSARY to dispense brand drug"
    186         ;
    187         S AFPTIM=$S($D(REPRINT):"Re-Printed on: ",1:"Printed on: ")
    188         W !!,AFPTIM
    189         ;
    190         D NOW^%DTC S Y=% X ^DD("DD")
    191         S AFPRNDT=Y_"  ("_RX_")"
    192         W AFPRNDT
    193         ;
    194         I IO["AFFAX"!($G(AFFAX)="Y") D
    195         .S FAXFROM=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",11)
    196         .W !!,"Faxed from: ",FAXFROM," ON ",Y
    197         ;
    198         I $D(REPRINT)&($G(PSOCKHN)'=",") W @IOF
    199         ;
    200         K VFASDD
    201         ;
    202         I IO["AFFAX"!($G(AFFAX)="Y") D CLOSE^%ZISH("HFSFAX") ;HMS CLOSE HFS FILE
    203         ;
    204         I $G(REPRINT)'=1 D
    205         .I IO["AFFAX"!($G(AFFAX)="Y") D
    206         ..S PSOLAP=$G(^SC(+ORL,"AFRXCLINPRNT"))
    207         ..S PSOLAP=$P(^%ZIS(1,PSOLAP,0),"^",1)
    208         ..S IOP=PSOLAP D ^%ZIS
    209         ..U IO
    210         ;
    211 ACT     ;Set activity log if faxed
    212         I IO["AFFAX"!($G(AFFAX)="Y") D
    213         .S (X,PCOM,PCOMX)="Faxed to: "_PSOAFFXP_" on "_Y
    214         .I '$D(PSOCLC) S PSOCLC=DUZ
    215 ACT1    .S RXF=0 F J=0:0 S J=$O(^PSRX(RX,1,J)) Q:'J  S RXF=J S:J>5 RXF=J+1
    216         .S IR=0 F J=0:0 S J=$O(^PSRX(RX,"A",J)) Q:'J  S IR=J
    217         .S PSOAFPTZ=$S($D(REPRINT):"W",1:"AFFAX")
    218         .S IR=IR+1,^PSRX(RX,"A",0)="^52.3DA^"_IR_"^"_IR
    219         .D NOW^%DTC S ^PSRX(RX,"A",IR,0)=%_"^"_PSOAFPTZ_"^"_DUZ_"^"_RXF_"^"_PCOM K PC,IR,PS,PCOM,XX,%,%H,%I,RXF
    220         ;
    221         K PSOAFFXP,PSOAFFXL
    222         ;
    223         Q
     1PSOAFPTL ;VFA/HMS autofinish print for laser printer ; 3/6/07 9:25pm
     2 ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 39
     3 ; Copyright (C) 2007 WorldVistA
     4 ;
     5 ; This program is free software; you can redistribute it and/or modify
     6 ; it under the terms of the GNU General Public License as published by
     7 ; the Free Software Foundation; either version 2 of the License, or
     8 ; (at your option) any later version.
     9 ;
     10 ; This program is distributed in the hope that it will be useful,
     11 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     12 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     13 ; GNU General Public License for more details.
     14 ;
     15 ; You should have received a copy of the GNU General Public License
     16 ; along with this program; if not, write to the Free Software
     17 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     18BEGLP ;
     19 U IO ;hms fax stuff
     20 ;
     21 F DR=1:1 Q:$G(SGY(DR))=""  S SN=19+DR D
     22 .S AFSIG(SN)=$G(SGY(DR))
     23 S SIGL=DR-1
     24 ;
     25 ;CHECK FOR ES
     26 S AFESFLAG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",3)
     27 S AFORD=$P(^PSRX(RX,"OR1"),"^",2)
     28 I $G(AFESFLAG)="Y" D
     29 .S AFES=$P($G(^OR(100,AFORD,8,1,0)),"^",4)
     30 .I $G(AFES)=1 S AFESYN="Y"
     31 .I $G(AFESYN)="Y" S AFESIGN=$P($G(^OR(100,AFORD,8,1,0)),"^",5)
     32 ;
     33 ;CHECK FOR SCHEDULE II WET SIGNATUIRE
     34 S AFWET2=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",6)
     35 S AFDEA=$P(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),0),"^",3)
     36 ;
     37 I $G(AFWET2)="Y"&($G(AFDEA)["2") S AFESFLAG="" ;Turns off ES for Sch IIs if wet sig for IIs set in File#59
     38 I $G(AFWET2)="Y"&($G(AFDEA)["2") S AFESYN=""
     39 ;
     40 ;Get Synonym
     41 S AFS=0,DONE="N",AFSYN="" F L=1:1 S AFS=$O(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS)) Q:AFS=""!(DONE="Y")  D
     42 .I $P(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS,0),"^",3)="0" D
     43 ..S AFSYN=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS,0)),"^",1),DONE="Y"
     44 K DONE
     45 ;
     46FAX ;
     47 K AFFAX
     48 S FAXNUM=$G(PSOAFFXP) ;PSOAFFXP from PSOLBLN
     49 S FAXLCNUM=$G(PSOAFFXL)_"@"_FAXNUM
     50 S FAXSER=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",10)
     51 I $G(FAXNUM)'=""&(FAXSER'="") D
     52 . S AFFAX="Y"
     53 I IO["AFFAX"!($G(AFFAX)="Y") D
     54 .D NOW^%DTC
     55 .S FAXDATE=$P(%,".",1)_"Z"_$P(%,".",2)
     56 .S FAXJOB=RX_"Z"_DFN_"Z"_FAXDATE
     57 .D OPEN^%ZISH("HFSFAX",FAXSER,FAXJOB_"+"_FAXLCNUM_".TXT","A")
     58 .S AFFAX="Y"
     59 .U IO
     60 ;
     61 ;Checks to see if 1st 3 lines should print
     62 S PSOAFPFT=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",9)
     63 ;
     64EN1 S OFF=$P(PS,"^",1)
     65 W $S(PSOAFPFT="N":"",1:OFF)
     66 ;
     67 S OFFAD=$P(PS,"^",7)_","_STATE_"  "_$G(PSOHZIP)
     68 W !
     69 W $S(PSOAFPFT="N":"",1:OFFAD)
     70 ;
     71 S OFFTEL=$P(PS,"^",3)_"-"_$P(PS,"^",4)
     72 W !
     73 W $S(PSOAFPFT="N":"",1:OFFTEL)
     74 ;
     75 S OFFFREE=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",4)
     76 W !,OFFFREE
     77 ;
     78 W !,"---------------------------------------------------------------",!
     79 ;
     80 W !,"Rx for: "
     81 ;
     82 D 6^VADPT,PID^VADPT
     83 S PSOAFPTI=$S(DUZ("AG")="V":$E($G(VA("PID")),5,12),1:$G(VA("PID")))
     84 S AFPNAM=PNM_" "_$G(PSOAFPTI)
     85 W AFPNAM
     86 ;
     87 S AFPADD1=$G(VAPA(1))
     88 W !,"        ",AFPADD1
     89 ;
     90 S AFPADD2=$G(ADDR(2))
     91 W !,"        ",AFPADD2
     92 ;
     93 S AFPADD3=$G(ADDR(3))
     94 W !,"        ",AFPADD3
     95 ;
     96 S AFPADD4=$G(ADDR(4))
     97 W !,"        ",AFPADD4
     98 ;
     99 W !,"---------------------------------------------------------------",!
     100 S AFDRUG=DRUG
     101 W !,AFDRUG
     102 ;
     103 S SYNFLAG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",5)
     104 I SYNFLAG="Y"&(AFSYN'="") D
     105 .W !,"Also known as: "
     106 .W AFSYN
     107 ;
     108 I $P($G(^PSRX(RX,"RXFIN")),"^",1)="Y" S VFASDD="Y"
     109 I $G(VFASDD)="Y" D
     110 .W !,"Pharmacy may choose strength(s) of drug to meet requirements of directions"
     111 ;
     112 ;
     113SIG S SN=19
     114 W !
     115 F L=1:1:SIGL S SN=SN+1 W !,AFSIG(SN)
     116 W !
     117 ;
     118 W !,"   Dispense: "
     119 S AFDISP=$G(QTY)_" "_$G(PSDU)
     120 W AFDISP
     121 ;
     122 I $G(VFASDD)="Y" W "     Pharmacy to adjust qty for # of days"
     123 ;
     124 W !,"Days Supply: "
     125 S VFADAYS=$G(DAYS)
     126 W VFADAYS
     127 ;
     128 W !,"  Refill(s): "
     129 S AFRF=$P(RXY,"^",9)
     130 W AFRF
     131 ;
     132 W !," Issue Date: "
     133 W DATE
     134 ;
     135 ;Print Diagnosis
     136 I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",8)="Y" D
     137DIAG .W !,"  Diagnosis:"
     138 .S AFICD9="None",AFICD="Not Available"
     139 .I $D(^OR(100,AFORD,5.1,0)) D
     140 ..S AFORL=0
     141 ..F L=1:1 S AFORL=$O(^OR(100,AFORD,5.1,AFORL)) Q:AFORL="B"!(AFORL=0)!(AFORL="")  D
     142 ...S AFORIN=$P($G(^OR(100,AFORD,5.1,AFORL,0)),"^",1)
     143 ...I AFORIN>"" D
     144 ....S AFICD9=$P($G(^ICD9(AFORIN,0)),"^",1)
     145 ....S AFICD=$P($G(^ICD9(AFORIN,0)),"^",3)
     146 ....W ?13,AFICD9,?23,AFICD
     147 .I AFICD9="None" W ?13,AFICD9,?23,AFICD
     148 ;
     149 ;Prints DOB
     150 I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",7)="Y" D
     151 .S PSOAFDOB=$P($G(VADM(3)),"^",2)
     152 .W !,"        DOB: "_PSOAFDOB,!
     153 ;
     154 ;Prints Provider Comments
     155 ;W "MD Comments:"
     156 K ^UTILITY($J,"W") S PSNACNT=1,DIWL=0,DIWR=48,DIWF="",(PSSIXFL,PSSEVFL)=0 F ZZ=0:0 S ZZ=$O(^PSRX(RX,"PRC",ZZ)) Q:'ZZ  I $D(^(ZZ,0)) S X=^(0) D ^DIWP
     157 ;D ^DIWW
     158 I $D(^UTILITY($J,"W")) D
     159 .W "MD Comments:"
     160 .F ZZ=0:0 S ZZ=$O(^UTILITY($J,"W",DIWL,ZZ)) Q:'ZZ  I $D(^(ZZ,0)) W ?13,^(0),!
     161 K ^UTILITY($J,"W")
     162 ;
     163SIGN ;Prints DEA if it exists-if no DEA# prints VA# if it exists
     164 I $G(AFESFLAG)="Y" D
     165 .I $G(AFESYN)="Y" D
     166 ..S AFDEA=$$GET1^DIQ(200,AFESIGN,53.2,"I")
     167 ..I AFDEA="" D
     168 ...S AFDEA=$$GET1^DIQ(200,AFESIGN,53.3,"I")
     169 ..S AFESIGNN=$$GET1^DIQ(200,AFESIGN,.01,"I")
     170 ..S AFSIGN=$G(AFESIGNN)_"  "_AFDEA
     171 ;
     172SIGN1 I $G(AFESFLAG)'="Y" D
     173 .W !!!,"Signature:_________________________________________________"
     174 .;vfah prints DEA if it exists-if no DEA# prints VA# if it exists
     175 .S AFDEA=$$GET1^DIQ(200,PSOAFPRV,53.2,"I")
     176 .I AFDEA="" D
     177 ..S AFDEA=$$GET1^DIQ(200,PSOAFPRV,53.3,"I")
     178 .S AFSIGN="           "_$G(PHYS)_"  "_AFDEA
     179 ;
     180SIGNP I $G(AFESYN)="Y" S AFSIGN="Signed: /ES/"_AFSIGN
     181 W !,AFSIGN
     182 ;
     183 K AFESYN,AFESIGN,AFESIGNN
     184 ;
     185 W !!,"Must write BRAND NECESSARY to dispense brand drug"
     186 ;
     187 S AFPTIM=$S($D(REPRINT):"Re-Printed on: ",1:"Printed on: ")
     188 W !!,AFPTIM
     189 ;
     190 D NOW^%DTC S Y=% X ^DD("DD")
     191 S AFPRNDT=Y_"  ("_RX_")"
     192 W AFPRNDT
     193 ;
     194 I IO["AFFAX"!($G(AFFAX)="Y") D
     195 .S FAXFROM=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",11)
     196 .W !!,"Faxed from: ",FAXFROM," ON ",Y
     197 ;
     198 I $D(REPRINT)&($G(PSOCKHN)'=",") W @IOF
     199 ;
     200 K VFASDD
     201 ;
     202 I IO["AFFAX"!($G(AFFAX)="Y") D CLOSE^%ZISH("HFSFAX") ;HMS CLOSE HFS FILE
     203 ;
     204 I $G(REPRINT)'=1 D
     205 .I IO["AFFAX"!($G(AFFAX)="Y") D
     206 ..S PSOLAP=$G(^SC(+ORL,"AFRXCLINPRNT"))
     207 ..S PSOLAP=$P(^%ZIS(1,PSOLAP,0),"^",1)
     208 ..S IOP=PSOLAP D ^%ZIS
     209 ..U IO
     210 ;
     211ACT ;Set activity log if faxed
     212 I IO["AFFAX"!($G(AFFAX)="Y") D
     213 .S (X,PCOM,PCOMX)="Faxed to: "_PSOAFFXP_" on "_Y
     214 .I '$D(PSOCLC) S PSOCLC=DUZ
     215ACT1 .S RXF=0 F J=0:0 S J=$O(^PSRX(RX,1,J)) Q:'J  S RXF=J S:J>5 RXF=J+1
     216 .S IR=0 F J=0:0 S J=$O(^PSRX(RX,"A",J)) Q:'J  S IR=J
     217 .S PSOAFPTZ=$S($D(REPRINT):"W",1:"AFFAX")
     218 .S IR=IR+1,^PSRX(RX,"A",0)="^52.3DA^"_IR_"^"_IR
     219 .D NOW^%DTC S ^PSRX(RX,"A",IR,0)=%_"^"_PSOAFPTZ_"^"_DUZ_"^"_RXF_"^"_PCOM K PC,IR,PS,PCOM,XX,%,%H,%I,RXF
     220 ;
     221 K PSOAFFXP,PSOAFFXL
     222 ;
     223 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFPTS.m

    r613 r623  
    1 PSOAFPTS        ;VFA/HMS autofinish print for star printer ;3/13/07  19:26
    2         ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 41
    3         ; Copyright (C) GNU GPL 2007 WorldVistA
    4         ;
    5 PRNT    ;PAGEMODE for Star Micronics
    6         ;
    7         U IO ;vfah fax
    8         ;
    9         F DR=1:1 Q:$G(SGY(DR))=""  S SN=19+DR D
    10         .S AFSIG(SN)=$G(SGY(DR))
    11         S SIGL=DR-1
    12         ;
    13         S AFESFLAG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",3)
    14         S AFORD=$P(^PSRX(RX,"OR1"),"^",2)
    15         I $G(AFESFLAG)="Y" D
    16         .S AFES=$P($G(^OR(100,AFORD,8,1,0)),"^",4)
    17         .I $G(AFES)=1 S AFESYN="Y"
    18         .I $G(AFESYN)="Y" S AFESIGN=$P($G(^OR(100,AFORD,8,1,0)),"^",5)
    19         ;
    20         S AFWET2=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",6)
    21         S AFDEA=$P(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),0),"^",3)
    22         ;
    23         I $G(AFWET2)="Y"&($G(AFDEA)["2") S AFESFLAG="" ;Turns off ES for Sch IIs if wet sig for IIs set in File#59
    24         I $G(AFWET2)="Y"&($G(AFDEA)["2") S AFESYN=""
    25         ;
    26         S AFS=0,DONE="N",AFSYN="" F L=1:1 S AFS=$O(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS)) Q:AFS=""!(DONE="Y")  D
    27         .I $P(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS,0),"^",3)="0" D
    28         ..S AFSYN=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS,0)),"^",1),DONE="Y"
    29         K DONE
    30         ;
    31 DIAG    ;
    32         S AFICD9(1)="None",AFICD(1)="Not Available",L=2
    33         I $D(^OR(100,AFORD,5.1,0)) D
    34         .S AFORL=0
    35         .F L=1:1 S AFORL=$O(^OR(100,AFORD,5.1,AFORL)) Q:AFORL="B"!(AFORL=0)!(AFORL="")  D
    36         ..S AFORIN=$P($G(^OR(100,AFORD,5.1,AFORL,0)),"^",1)
    37         ..I AFORIN>"" D
    38         ...S AFICD9(L)=$P($G(^ICD9(AFORIN,0)),"^",1)
    39         ...S AFICD(L)=$P($G(^ICD9(AFORIN,0)),"^",3)
    40         S AFICDN=L-1
    41         ;
    42 PRC     ;
    43         K ^UTILITY($J,"W") S PSNACNT=1,DIWL=0,DIWR=70,DIWF="",(PSSIXFL,PSSEVFL)=0 F ZZ=0:0 S ZZ=$O(^PSRX(RX,"PRC",ZZ)) Q:'ZZ  I $D(^(ZZ,0)) S X=^(0) D ^DIWP
    44         F ZZ=0:0 S ZZ=$O(^UTILITY($J,"W",DIWL,ZZ)) Q:'ZZ  I $D(^(ZZ,0)) S PSOAFZZ=ZZ
    45         ;
    46         W $C(27),"C",$C(10),$C(0) ;Clear format
    47         ;
    48         W $C(27),"L00;0110,0030,0920,0030,0,6",$C(10),$C(0) ;T
    49         W $C(27),"L01;0025,0100,0025,0230,1,6",$C(10),$C(0) ;L
    50         W $C(27),"L02;1000,0100,1000,0238,1,6",$C(10),$C(0) ;R
    51         W $C(27),"L03;0025,0230,1000,0230,0,6",$C(10),$C(0) ;B
    52         W $C(27),"L10;0920,0030,0920,0100,1,6",$C(10),$C(0) ;R
    53         W $C(27),"L11;0920,0100,1000,0100,0,6",$C(10),$C(0) ;B
    54         W $C(27),"L12;0110,0030,0110,0102,1,6",$C(10),$C(0) ;R
    55         W $C(27),"L13;0025,0100,0112,0100,0,6",$C(10),$C(0) ;B
    56         ;
    57         W $C(27),"L05;0025,0470,1000,0470,0,2",$C(10),$C(0) ;Div Line
    58         ;
    59         W $C(27),"PC00;0210,0055,1,1,4,00,00",$C(10),$C(0) ;Dr
    60         W $C(27),"PC01;0025,0100,1,1,2,00,00",$C(10),$C(0) ;Dr
    61         W $C(27),"PC02;0025,0145,1,1,2,00,00",$C(10),$C(0) ;Dr Phone
    62         W $C(27),"PC70;0025,0190,1,1,2,00,00",$C(10),$C(0) ;Free line
    63         ;
    64         W $C(27),"PC03;0025,0285,1,1,1,00,03",$C(10),$C(0) ;Rx For
    65         W $C(27),"PC04;0130,0280,1,1,2,00,00",$C(10),$C(0) ;Pat Name
    66         W $C(27),"PC05;0130,0320,1,1,2,00,00",$C(10),$C(0) ;Pat Str1
    67         W $C(27),"PC06;0130,0360,1,1,2,00,00",$C(10),$C(0) ;Pat Str2
    68         W $C(27),"PC07;0130,0400,1,1,2,00,00",$C(10),$C(0) ;Pat Str3
    69         W $C(27),"PC08;0130,0440,1,1,2,00,00",$C(10),$C(0) ;Pat City
    70         ;
    71         S DHL=4
    72         S:$L(DRUG)>33 DHL=2 ;Reduce size for L>33
    73         W $C(27),"PC09;0025,0500,1,1,"_DHL_",00,00",$C(10),$C(0) ;Drug
    74         ;
    75         W $C(27),"PC72;0025,0558,1,1,1,00,03",$C(10),$C(0) ;AKA Notice
    76         W $C(27),"PC71;0225,0550,1,1,2,00,00",$C(10),$C(0) ;Drug Syn
    77         ;
    78         W $C(27),"PC10;0025,0590,1,1,1,00,03",$C(10),$C(0) ;SDD Disclaimer
    79         ;
    80         S SL=19,VP=590
    81         F L=1:1:SIGL D
    82         .S SL=SL+1,VP=VP+40
    83         .D SVP
    84         .W $C(27),"PC"_SL_";0025,"_VP_",1,1,2,00,00",$C(10),$C(0)
    85         ;
    86         S VP=VP+60 D SVP
    87         W $C(27),"PC50;0085,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Disp:
    88         W $C(27),"PC51;0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Disp Num
    89         ;
    90         ;S VP=VP+40 D SVP
    91         W $C(27),"PC52;0450,"_VP_",1,1,1,00,03",$C(10),$C(0) ;Disp Disclaimer
    92         ;
    93         S VP=VP+40 D SVP
    94         W $C(27),"PC53;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Days
    95         W $C(27),"PC54;0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ; Supply
    96         ;
    97         S VP=VP+40 D SVP
    98         W $C(27),"PC55;0065,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Refill
    99         W $C(27),"PC56;0300,"_VP_",1,1,2,00,00",$C(10),$C(0)
    100         ;
    101         S VP=VP+40 D SVP
    102         W $C(27),"PC57;0045,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Issue
    103         W $C(27),"PC58;0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ; Date #
    104         ;
    105         ;Diag Line Logo
    106         S VP=VP+40 D SVP
    107         W $C(27),"PC79;0065,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Diag
    108         ;
    109         S SL=79,VP=VP-40 ;Diag lines
    110         F L=1:1:AFICDN D
    111         .S SL=SL+1,VP=VP+40
    112         .D SVP
    113         .W $C(27),"PC"_SL_";0300,"_VP_",1,1,2,00,00",$C(10),$C(0)
    114         .S SL=SL+1
    115         .W $C(27),"PC"_SL_";0475,"_VP_",1,1,2,00,00",$C(10),$C(0)
    116         ;
    117         ;DOB Line
    118         S SL=SL+1,VP=VP+40 D SVP
    119         W $C(27),"PC"_SL_";0065,"_VP_",1,1,2,00,00",$C(10),$C(0) ;DOB:
    120         S SL=SL+1
    121         W $C(27),"PC"_SL_";0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ;DOB
    122         ;
    123         ;Comment Line Logo
    124         I $G(PSOAFZZ)>0 D
    125         .S SL=SL+1,VP=VP+40 D SVP
    126         .W $C(27),"PC"_SL_";0008,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Comment Logo
    127         ;
    128         I $G(PSOAFZZ)>0 D
    129         .S VP=VP-40 ;Comment lines
    130         .F L=1:1:PSOAFZZ D
    131         ..S SL=SL+1,VP=VP+$S(L=1:48,1:25)
    132         ..D SVP
    133         ..W $C(27),"PC"_SL_";0300,"_VP_",1,1,1,00,00",$C(10),$C(0)
    134         ;
    135         ;Signature lines start here
    136         I $G(AFESYN)="Y" S VP=VP+130 D SVP G SIGNL
    137         S VP=VP+130 D SVP
    138         W $C(27),"PC59;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Sig:
    139         ;
    140         S VP=VP+30 D SVP
    141         W $C(27),"L04;0230,"_VP_",1000,"_VP_",0,2",$C(10),$C(0) ;Line
    142         ;
    143 SIGNL   S VP=VP+10 D SVP
    144         I $G(AFESYN)="Y" G SIGNL1
    145         W $C(27),"PC60;0240,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Prov Name
    146 SIGNL1  W $C(27),"PC60;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;ES Prov Name
    147         ;
    148         S VP=VP+110 D SVP
    149         W $C(27),"PC61;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Trail
    150         ;
    151         S VP=VP+90 D SVP
    152         W $C(27),"PC62;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Printed On:
    153         W $C(27),"PC63;0320,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Printed On D/T
    154         ;
    155         ;Testing form length on Star
    156         S PA=$S(VP>1501:1900,1:1500)
    157         W $C(27),"D"_PA_"",$C(10),$C(0) ;Set print area
    158         ;
    159         W $C(27),"B",$C(10),$C(0) ;Enable cutter
    160         ;
    161         S OFF=$P(PS,"^",1)
    162         S VFAX=OFF,VFAM=20
    163         D CENTER
    164         S OFF=VFAX
    165         W $C(27),"RC00;"_OFF_"",$C(10),$C(0)
    166         ;
    167         S OFFAD=$P(PS,"^",7)_","_STATE_"  "_$G(PSOHZIP)
    168         S VFAX=OFFAD,VFAM=49
    169         D CENTER
    170         S OFFAD=VFAX
    171         W $C(27),"RC01;"_OFFAD_"",$C(10),$C(0)
    172         ;
    173         S OFFTEL=$P(PS,"^",3)_"-"_$P(PS,"^",4)
    174         S VFAX=OFFTEL,VFAM=49
    175         D CENTER
    176         S OFFTEL=VFAX
    177         W $C(27),"RC02;"_OFFTEL_"",$C(10),$C(0)
    178         ;
    179         S OFFFREE=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",4)
    180         S VFAX=OFFFREE,VFAM=49
    181         D CENTER
    182         S OFFFREE=VFAX
    183         W $C(27),"RC70;"_OFFFREE_"",$C(10),$C(0)
    184         ;
    185         W $C(27),"RC03;Rx for:",$C(10),$C(0)
    186         ;
    187         D 6^VADPT,PID^VADPT
    188         S PSOAFPTI=$S(DUZ("AG")="V":$E($G(VA("PID")),5,12),1:$G(VA("PID")))
    189         S AFPNAM=PNM_" "_$G(PSOAFPTI)
    190         W $C(27),"RC04;"_AFPNAM_"",$C(10),$C(0)
    191         ;
    192         S AFPADD1=$G(VAPA(1))
    193         W $C(27),"RC05;"_AFPADD1_"",$C(10),$C(0)
    194         ;
    195         S AFPADD2=$G(ADDR(2))
    196         W $C(27),"RC06;"_AFPADD2_"",$C(10),$C(0)
    197         ;
    198         S AFPADD3=$G(ADDR(3))
    199         W $C(27),"RC07;"_AFPADD3_"",$C(10),$C(0)
    200         ;
    201         S AFPADD4=$G(ADDR(4))
    202         W $C(27),"RC08;"_AFPADD4_"",$C(10),$C(0)
    203         ;
    204         S AFDRUG=DRUG
    205         W $C(27),"RC09;"_AFDRUG_"",$C(10),$C(0)
    206         ;
    207         S SYNFLAG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",5)
    208         I SYNFLAG="Y"&(AFSYN'="") D
    209         .W $C(27),"RC72;Also known as:",$C(10),$C(0) ;L-72
    210         .W $C(27),"RC71;"_AFSYN_"",$C(10),$C(0) ;L-71
    211         ;
    212         I $P($G(^PSRX(RX,"RXFIN")),"^",1)="Y" S VFASDD="Y"
    213         I $G(VFASDD)="Y" D
    214         .W $C(27),"RC10;Pharmacy may choose strength(s) of drug to meet requirements of directions",$C(10),$C(0)
    215         ;
    216         ;
    217 SIG     S SN=19
    218         F L=1:1:SIGL S SN=SN+1 W $C(27),"RC"_SN_";"_AFSIG(SN)_"",$C(10),$C(0)
    219         ;
    220         W $C(27),"RC50;Dispense:",$C(10),$C(0)
    221         S AFDISP=$G(QTY)_" "_$G(PSDU)
    222         W $C(27),"RC51;"_AFDISP_"",$C(10),$C(0)
    223         ;
    224         I $G(VFASDD)="Y" W $C(27),"RC52;Pharmacy to adjust qty for # of days",$C(10),$C(0)
    225         ;
    226         W $C(27),"RC53;Days Supply:",$C(10),$C(0)
    227         S VFADAYS=$G(DAYS)
    228         W $C(27),"RC54;"_VFADAYS_"",$C(10),$C(0)
    229         ;
    230         W $C(27),"RC55;Refill(s):",$C(10),$C(0)
    231         S AFRF=$P(RXY,"^",9)
    232         W $C(27),"RC56;"_AFRF_"",$C(10),$C(0)
    233         ;
    234         W $C(27),"RC57;Issue Date:",$C(10),$C(0)
    235         W $C(27),"RC58;"_DATE_"",$C(10),$C(0)
    236         ;
    237 DIA     S PSOAFDOB=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",8)
    238         I PSOAFDOB="Y" D
    239         .W $C(27),"RC79;Diagnosis:",$C(10),$C(0)
    240         .S SN=79
    241         .F L=1:1:AFICDN S SN=SN+1 D
    242         ..W $C(27),"RC"_SN_";"_AFICD9(L)_"",$C(10),$C(0)
    243         ..S SN=SN+1
    244         ..W $C(27),"RC"_SN_";"_AFICD(L)_"",$C(10),$C(0)
    245         I PSOAFDOB="" S SN=80+AFICDN
    246         ;
    247 DOB     ;DOB
    248         S PSOAFDIG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",7)
    249         I PSOAFDIG="Y" D
    250         .S PSOAFDOB=$P($G(VADM(3)),"^",2),PSOAFDOL="      DOB:"
    251         .S SN=SN+1
    252         .W $C(27),"RC"_SN_";      DOB:",$C(10),$C(0)
    253         .S SN=SN+1
    254         .W $C(27),"RC"_SN_";"_PSOAFDOB_"",$C(10),$C(0)
    255         I PSOAFDIG="" S SN=SN+2
    256         ;
    257 COM     ;
    258         I $D(^UTILITY($J,"W")) D
    259         .S SN=SN+1
    260         .W $C(27),"RC"_SN_"; MD Comments:",$C(10),$C(0)
    261         .F ZZ=0:0:PSOAFZZ S ZZ=$O(^UTILITY($J,"W",DIWL,ZZ)) Q:'ZZ  I $D(^(ZZ,0)) S PSOAFCOM=^(0),SN=SN+1 W $C(27),"RC"_SN_";"_PSOAFCOM_"",$C(10),$C(0)
    262         K PSOZAFZZ,^UTILITY($J,"W")
    263         ;
    264         ;Signature Block
    265 SIGN    ;Prints DEA if it exists-if no DEA# prints VA# if it exists
    266         I $G(AFESFLAG)="Y" D
    267         .I $G(AFESYN)="Y" D
    268         ..S AFDEA=$$GET1^DIQ(200,AFESIGN,53.2,"I")
    269         ..I AFDEA="" D
    270         ...S AFDEA=$$GET1^DIQ(200,AFESIGN,53.3,"I")
    271         ..S AFESIGNN=$$GET1^DIQ(200,AFESIGN,.01,"I")
    272         ..S AFSIGN=$G(AFESIGNN)_"  "_AFDEA
    273         ;
    274 SIGN1   I $G(AFESFLAG)'="Y" D
    275         .W $C(27),"RC59;Signature:",$C(10),$C(0)  ;SCD
    276         .;vfah prints DEA if it exists-if no DEA# prints VA# if it exists
    277         .S AFDEA=$$GET1^DIQ(200,PSOAFPRV,53.2,"I")
    278         .I AFDEA="" D
    279         ..S AFDEA=$$GET1^DIQ(200,PSOAFPRV,53.3,"I")
    280         .S AFSIGN="           "_$G(PHYS)_"  "_AFDEA
    281         ;
    282 SIGNP   I $G(AFESYN)="Y" S AFSIGN="Signed: /ES/"_AFSIGN
    283         W $C(27),"RC60;"_AFSIGN_"",$C(10),$C(0) ;SCD
    284         ;
    285         K AFESYN,AFESIGN,AFESIGNN
    286         ;
    287         W $C(27),"RC61;Must write BRAND NECESSARY to dispense brand drug",$C(10),$C(0) ;SCD
    288         ;
    289         S AFPTIM=$S($D(REPRINT):"Re-Printed on:",1:"Printed on:")
    290         W $C(27),"RC62;"_AFPTIM_"",$C(10),$C(0) ;SCD
    291         D NOW^%DTC S Y=% X ^DD("DD")
    292         S AFPRNDT=Y_"  ("_RX_")"
    293         W $C(27),"RC63;"_AFPRNDT_"",$C(10),$C(0) ;SCD
    294         ;
    295 WRITE   W $C(27),"I",$C(10),$C(0) ;Print label
    296         ;
    297         K VFASDD
    298         Q
    299         ;
    300 SVP     S VP=$S($L(VP)=1:"000"_VP,$L(VP)=2:"00"_VP,$L(VP)=3:"0"_VP,1:VP)
    301         Q
    302         ;
    303 CENTER  ;Center header
    304         S VFAS=(VFAM-$L(VFAX))\2
    305         F L=1:1:VFAS S VFAX=" "_VFAX
     1PSOAFPTS ;VFA/HMS autofinish print for star printer ;3/13/07  19:26
     2 ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 39
     3 ; Copyright (C) GNU GPL 2007 WorldVistA
     4 ;
     5PRNT ;PAGEMODE for Star Micronics
     6 ;
     7 U IO ;vfah fax
     8 ;
     9 F DR=1:1 Q:$G(SGY(DR))=""  S SN=19+DR D
     10 .S AFSIG(SN)=$G(SGY(DR))
     11 S SIGL=DR-1
     12 ;
     13 S AFESFLAG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",3)
     14 S AFORD=$P(^PSRX(RX,"OR1"),"^",2)
     15 I $G(AFESFLAG)="Y" D
     16 .S AFES=$P($G(^OR(100,AFORD,8,1,0)),"^",4)
     17 .I $G(AFES)=1 S AFESYN="Y"
     18 .I $G(AFESYN)="Y" S AFESIGN=$P($G(^OR(100,AFORD,8,1,0)),"^",5)
     19 ;
     20 S AFWET2=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",6)
     21 S AFDEA=$P(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),0),"^",3)
     22 ;
     23 I $G(AFWET2)="Y"&($G(AFDEA)["2") S AFESFLAG="" ;Turns off ES for Sch IIs if wet sig for IIs set in File#59
     24 I $G(AFWET2)="Y"&($G(AFDEA)["2") S AFESYN=""
     25 ;
     26 S AFS=0,DONE="N",AFSYN="" F L=1:1 S AFS=$O(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS)) Q:AFS=""!(DONE="Y")  D
     27 .I $P(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS,0),"^",3)="0" D
     28 ..S AFSYN=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS,0)),"^",1),DONE="Y"
     29 K DONE
     30 ;
     31DIAG ;
     32 S AFICD9(1)="None",AFICD(1)="Not Available",L=2
     33 I $D(^OR(100,AFORD,5.1,0)) D
     34 .S AFORL=0
     35 .F L=1:1 S AFORL=$O(^OR(100,AFORD,5.1,AFORL)) Q:AFORL="B"!(AFORL=0)!(AFORL="")  D
     36 ..S AFORIN=$P($G(^OR(100,AFORD,5.1,AFORL,0)),"^",1)
     37 ..I AFORIN>"" D
     38 ...S AFICD9(L)=$P($G(^ICD9(AFORIN,0)),"^",1)
     39 ...S AFICD(L)=$P($G(^ICD9(AFORIN,0)),"^",3)
     40 S AFICDN=L-1
     41 ;
     42PRC ;
     43 K ^UTILITY($J,"W") S PSNACNT=1,DIWL=0,DIWR=70,DIWF="",(PSSIXFL,PSSEVFL)=0 F ZZ=0:0 S ZZ=$O(^PSRX(RX,"PRC",ZZ)) Q:'ZZ  I $D(^(ZZ,0)) S X=^(0) D ^DIWP
     44 F ZZ=0:0 S ZZ=$O(^UTILITY($J,"W",DIWL,ZZ)) Q:'ZZ  I $D(^(ZZ,0)) S PSOAFZZ=ZZ
     45 ;
     46 W $C(27),"C",$C(10),$C(0) ;Clear format
     47 ;
     48 W $C(27),"L00;0110,0030,0920,0030,0,6",$C(10),$C(0) ;T
     49 W $C(27),"L01;0025,0100,0025,0230,1,6",$C(10),$C(0) ;L
     50 W $C(27),"L02;1000,0100,1000,0238,1,6",$C(10),$C(0) ;R
     51 W $C(27),"L03;0025,0230,1000,0230,0,6",$C(10),$C(0) ;B
     52 W $C(27),"L10;0920,0030,0920,0100,1,6",$C(10),$C(0) ;R
     53 W $C(27),"L11;0920,0100,1000,0100,0,6",$C(10),$C(0) ;B
     54 W $C(27),"L12;0110,0030,0110,0102,1,6",$C(10),$C(0) ;R
     55 W $C(27),"L13;0025,0100,0112,0100,0,6",$C(10),$C(0) ;B
     56 ;
     57 W $C(27),"L05;0025,0470,1000,0470,0,2",$C(10),$C(0) ;Div Line
     58 ;
     59 W $C(27),"PC00;0210,0055,1,1,4,00,00",$C(10),$C(0) ;Dr
     60 W $C(27),"PC01;0025,0100,1,1,2,00,00",$C(10),$C(0) ;Dr
     61 W $C(27),"PC02;0025,0145,1,1,2,00,00",$C(10),$C(0) ;Dr Phone
     62 W $C(27),"PC70;0025,0190,1,1,2,00,00",$C(10),$C(0) ;Free line
     63 ;
     64 W $C(27),"PC03;0025,0285,1,1,1,00,03",$C(10),$C(0) ;Rx For
     65 W $C(27),"PC04;0130,0280,1,1,2,00,00",$C(10),$C(0) ;Pat Name
     66 W $C(27),"PC05;0130,0320,1,1,2,00,00",$C(10),$C(0) ;Pat Str1
     67 W $C(27),"PC06;0130,0360,1,1,2,00,00",$C(10),$C(0) ;Pat Str2
     68 W $C(27),"PC07;0130,0400,1,1,2,00,00",$C(10),$C(0) ;Pat Str3
     69 W $C(27),"PC08;0130,0440,1,1,2,00,00",$C(10),$C(0) ;Pat City
     70 ;
     71 S DHL=4
     72 S:$L(DRUG)>33 DHL=2 ;Reduce size for L>33
     73 W $C(27),"PC09;0025,0500,1,1,"_DHL_",00,00",$C(10),$C(0) ;Drug
     74 ;
     75 W $C(27),"PC72;0025,0558,1,1,1,00,03",$C(10),$C(0) ;AKA Notice
     76 W $C(27),"PC71;0225,0550,1,1,2,00,00",$C(10),$C(0) ;Drug Syn
     77 ;
     78 W $C(27),"PC10;0025,0590,1,1,1,00,03",$C(10),$C(0) ;SDD Disclaimer
     79 ;
     80 S SL=19,VP=590
     81 F L=1:1:SIGL D
     82 .S SL=SL+1,VP=VP+40
     83 .D SVP
     84 .W $C(27),"PC"_SL_";0025,"_VP_",1,1,2,00,00",$C(10),$C(0)
     85 ;
     86 S VP=VP+60 D SVP
     87 W $C(27),"PC50;0085,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Disp:
     88 W $C(27),"PC51;0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Disp Num
     89 ;
     90 ;S VP=VP+40 D SVP
     91 W $C(27),"PC52;0450,"_VP_",1,1,1,00,03",$C(10),$C(0) ;Disp Disclaimer
     92 ;
     93 S VP=VP+40 D SVP
     94 W $C(27),"PC53;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Days
     95 W $C(27),"PC54;0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ; Supply
     96 ;
     97 S VP=VP+40 D SVP
     98 W $C(27),"PC55;0065,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Refill
     99 W $C(27),"PC56;0300,"_VP_",1,1,2,00,00",$C(10),$C(0)
     100 ;
     101 S VP=VP+40 D SVP
     102 W $C(27),"PC57;0045,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Issue
     103 W $C(27),"PC58;0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ; Date #
     104 ;
     105 ;Diag Line Logo
     106 S VP=VP+40 D SVP
     107 W $C(27),"PC79;0065,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Diag
     108 ;
     109 S SL=79,VP=VP-40 ;Diag lines
     110 F L=1:1:AFICDN D
     111 .S SL=SL+1,VP=VP+40
     112 .D SVP
     113 .W $C(27),"PC"_SL_";0300,"_VP_",1,1,2,00,00",$C(10),$C(0)
     114 .S SL=SL+1
     115 .W $C(27),"PC"_SL_";0475,"_VP_",1,1,2,00,00",$C(10),$C(0)
     116 ;
     117 ;DOB Line
     118 S SL=SL+1,VP=VP+40 D SVP
     119 W $C(27),"PC"_SL_";0065,"_VP_",1,1,2,00,00",$C(10),$C(0) ;DOB:
     120 S SL=SL+1
     121 W $C(27),"PC"_SL_";0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ;DOB
     122 ;
     123 ;Comment Line Logo
     124 I $G(PSOAFZZ)>0 D
     125 .S SL=SL+1,VP=VP+40 D SVP
     126 .W $C(27),"PC"_SL_";0008,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Comment Logo
     127 ;
     128 I $G(PSOAFZZ)>0 D
     129 .S VP=VP-40 ;Comment lines
     130 .F L=1:1:PSOAFZZ D
     131 ..S SL=SL+1,VP=VP+$S(L=1:48,1:25)
     132 ..D SVP
     133 ..W $C(27),"PC"_SL_";0300,"_VP_",1,1,1,00,00",$C(10),$C(0)
     134 ;
     135 ;Signature lines start here
     136 I $G(AFESYN)="Y" S VP=VP+130 D SVP G SIGNL
     137 S VP=VP+130 D SVP
     138 W $C(27),"PC59;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Sig:
     139 ;
     140 S VP=VP+30 D SVP
     141 W $C(27),"L04;0230,"_VP_",1000,"_VP_",0,2",$C(10),$C(0) ;Line
     142 ;
     143SIGNL S VP=VP+10 D SVP
     144 I $G(AFESYN)="Y" G SIGNL1
     145 W $C(27),"PC60;0240,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Prov Name
     146SIGNL1 W $C(27),"PC60;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;ES Prov Name
     147 ;
     148 S VP=VP+110 D SVP
     149 W $C(27),"PC61;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Trail
     150 ;
     151 S VP=VP+90 D SVP
     152 W $C(27),"PC62;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Printed On:
     153 W $C(27),"PC63;0320,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Printed On D/T
     154 ;
     155 ;Testing form length on Star
     156 S PA=$S(VP>1501:1900,1:1500)
     157 W $C(27),"D"_PA_"",$C(10),$C(0) ;Set print area
     158 ;
     159 W $C(27),"B",$C(10),$C(0) ;Enable cutter
     160 ;
     161 S OFF=$P(PS,"^",1)
     162 S VFAX=OFF,VFAM=20
     163 D CENTER
     164 S OFF=VFAX
     165 W $C(27),"RC00;"_OFF_"",$C(10),$C(0)
     166 ;
     167 S OFFAD=$P(PS,"^",7)_","_STATE_"  "_$G(PSOHZIP)
     168 S VFAX=OFFAD,VFAM=49
     169 D CENTER
     170 S OFFAD=VFAX
     171 W $C(27),"RC01;"_OFFAD_"",$C(10),$C(0)
     172 ;
     173 S OFFTEL=$P(PS,"^",3)_"-"_$P(PS,"^",4)
     174 S VFAX=OFFTEL,VFAM=49
     175 D CENTER
     176 S OFFTEL=VFAX
     177 W $C(27),"RC02;"_OFFTEL_"",$C(10),$C(0)
     178 ;
     179 S OFFFREE=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",4)
     180 S VFAX=OFFFREE,VFAM=49
     181 D CENTER
     182 S OFFFREE=VFAX
     183 W $C(27),"RC70;"_OFFFREE_"",$C(10),$C(0)
     184 ;
     185 W $C(27),"RC03;Rx for:",$C(10),$C(0)
     186 ;
     187 D 6^VADPT,PID^VADPT
     188 S PSOAFPTI=$S(DUZ("AG")="V":$E($G(VA("PID")),5,12),1:$G(VA("PID")))
     189 S AFPNAM=PNM_" "_$G(PSOAFPTI)
     190 W $C(27),"RC04;"_AFPNAM_"",$C(10),$C(0)
     191 ;
     192 S AFPADD1=$G(VAPA(1))
     193 W $C(27),"RC05;"_AFPADD1_"",$C(10),$C(0)
     194 ;
     195 S AFPADD2=$G(ADDR(2))
     196 W $C(27),"RC06;"_AFPADD2_"",$C(10),$C(0)
     197 ;
     198 S AFPADD3=$G(ADDR(3))
     199 W $C(27),"RC07;"_AFPADD3_"",$C(10),$C(0)
     200 ;
     201 S AFPADD4=$G(ADDR(4))
     202 W $C(27),"RC08;"_AFPADD4_"",$C(10),$C(0)
     203 ;
     204 S AFDRUG=DRUG
     205 W $C(27),"RC09;"_AFDRUG_"",$C(10),$C(0)
     206 ;
     207 S SYNFLAG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",5)
     208 I SYNFLAG="Y"&(AFSYN'="") D
     209 .W $C(27),"RC72;Also known as:",$C(10),$C(0) ;L-72
     210 .W $C(27),"RC71;"_AFSYN_"",$C(10),$C(0) ;L-71
     211 ;
     212 I $P($G(^PSRX(RX,"RXFIN")),"^",1)="Y" S VFASDD="Y"
     213 I $G(VFASDD)="Y" D
     214 .W $C(27),"RC10;Pharmacy may choose strength(s) of drug to meet requirements of directions",$C(10),$C(0)
     215 ;
     216 ;
     217SIG S SN=19
     218 F L=1:1:SIGL S SN=SN+1 W $C(27),"RC"_SN_";"_AFSIG(SN)_"",$C(10),$C(0)
     219 ;
     220 W $C(27),"RC50;Dispense:",$C(10),$C(0)
     221 S AFDISP=$G(QTY)_" "_$G(PSDU)
     222 W $C(27),"RC51;"_AFDISP_"",$C(10),$C(0)
     223 ;
     224 I $G(VFASDD)="Y" W $C(27),"RC52;Pharmacy to adjust qty for # of days",$C(10),$C(0)
     225 ;
     226 W $C(27),"RC53;Days Supply:",$C(10),$C(0)
     227 S VFADAYS=$G(DAYS)
     228 W $C(27),"RC54;"_VFADAYS_"",$C(10),$C(0)
     229 ;
     230 W $C(27),"RC55;Refill(s):",$C(10),$C(0)
     231 S AFRF=$P(RXY,"^",9)
     232 W $C(27),"RC56;"_AFRF_"",$C(10),$C(0)
     233 ;
     234 W $C(27),"RC57;Issue Date:",$C(10),$C(0)
     235 W $C(27),"RC58;"_DATE_"",$C(10),$C(0)
     236 ;
     237DIA S PSOAFDOB=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",8)
     238 I PSOAFDOB="Y" D
     239 .W $C(27),"RC79;Diagnosis:",$C(10),$C(0)
     240 .S SN=79
     241 .F L=1:1:AFICDN S SN=SN+1 D
     242 ..W $C(27),"RC"_SN_";"_AFICD9(L)_"",$C(10),$C(0)
     243 ..S SN=SN+1
     244 ..W $C(27),"RC"_SN_";"_AFICD(L)_"",$C(10),$C(0)
     245 I PSOAFDOB="" S SN=80+AFICDN
     246 ;
     247DOB ;DOB
     248 S PSOAFDIG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",7)
     249 I PSOAFDIG="Y" D
     250 .S PSOAFDOB=$P($G(VADM(3)),"^",2),PSOAFDOL="      DOB:"
     251 .S SN=SN+1
     252 .W $C(27),"RC"_SN_";      DOB:",$C(10),$C(0)
     253 .S SN=SN+1
     254 .W $C(27),"RC"_SN_";"_PSOAFDOB_"",$C(10),$C(0)
     255 I PSOAFDIG="" S SN=SN+2
     256 ;
     257COM ;
     258 I $D(^UTILITY($J,"W")) D
     259 .S SN=SN+1
     260 .W $C(27),"RC"_SN_"; MD Comments:",$C(10),$C(0)
     261 .F ZZ=0:0:PSOAFZZ S ZZ=$O(^UTILITY($J,"W",DIWL,ZZ)) Q:'ZZ  I $D(^(ZZ,0)) S PSOAFCOM=^(0),SN=SN+1 W $C(27),"RC"_SN_";"_PSOAFCOM_"",$C(10),$C(0)
     262 K PSOZAFZZ,^UTILITY($J,"W")
     263 ;
     264 ;Signature Block
     265SIGN ;Prints DEA if it exists-if no DEA# prints VA# if it exists
     266 I $G(AFESFLAG)="Y" D
     267 .I $G(AFESYN)="Y" D
     268 ..S AFDEA=$$GET1^DIQ(200,AFESIGN,53.2,"I")
     269 ..I AFDEA="" D
     270 ...S AFDEA=$$GET1^DIQ(200,AFESIGN,53.3,"I")
     271 ..S AFESIGNN=$$GET1^DIQ(200,AFESIGN,.01,"I")
     272 ..S AFSIGN=$G(AFESIGNN)_"  "_AFDEA
     273 ;
     274SIGN1 I $G(AFESFLAG)'="Y" D
     275 .W $C(27),"RC59;Signature:",$C(10),$C(0)  ;SCD
     276 .;vfah prints DEA if it exists-if no DEA# prints VA# if it exists
     277 .S AFDEA=$$GET1^DIQ(200,PSOAFPRV,53.2,"I")
     278 .I AFDEA="" D
     279 ..S AFDEA=$$GET1^DIQ(200,PSOAFPRV,53.3,"I")
     280 .S AFSIGN="           "_$G(PHYS)_"  "_AFDEA
     281 ;
     282SIGNP I $G(AFESYN)="Y" S AFSIGN="Signed: /ES/"_AFSIGN
     283 W $C(27),"RC60;"_AFSIGN_"",$C(10),$C(0) ;SCD
     284 ;
     285 K AFESYN,AFESIGN,AFESIGNN
     286 ;
     287 W $C(27),"RC61;Must write BRAND NECESSARY to dispense brand drug",$C(10),$C(0) ;SCD
     288 ;
     289 S AFPTIM=$S($D(REPRINT):"Re-Printed on:",1:"Printed on:")
     290 W $C(27),"RC62;"_AFPTIM_"",$C(10),$C(0) ;SCD
     291 D NOW^%DTC S Y=% X ^DD("DD")
     292 S AFPRNDT=Y_"  ("_RX_")"
     293 W $C(27),"RC63;"_AFPRNDT_"",$C(10),$C(0) ;SCD
     294 ;
     295WRITE W $C(27),"I",$C(10),$C(0) ;Print label
     296 ;
     297 K VFASDD
     298 Q
     299 ;
     300SVP S VP=$S($L(VP)=1:"000"_VP,$L(VP)=2:"00"_VP,$L(VP)=3:"0"_VP,1:VP)
     301 Q
     302 ;
     303CENTER ;Center header
     304 S VFAS=(VFAM-$L(VFAX))\2
     305 F L=1:1:VFAS S VFAX=" "_VFAX

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFRP1.m

    r613 r623  
    1 PSOAFRP1        ;VFA/HMS autofinish rx speed reprint for listman ;1/30/07  19:48
    2         ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 41
    3         ; Copyright (C) 2007 WorldVistA
    4         ;
    5         ; This program is free software; you can redistribute it and/or modify
    6         ; it under the terms of the GNU General Public License as published by
    7         ; the Free Software Foundation; either version 2 of the License, or
    8         ; (at your option) any later version.
    9         ;
    10         ; This program is distributed in the hope that it will be useful,
    11         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    12         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    13         ; GNU General Public License for more details.
    14         ;
    15         ; You should have received a copy of the GNU General Public License
    16         ; along with this program; if not, write to the Free Software
    17         ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    18         ;'Modified' MAS Patient Look-up Check Cross-References June 1987
    19         ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
    20 SEL     N PSODISP,VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
    21         S PSOAFYN="Y"
    22         S RXCNT=0 K PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR S LST=Y I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" Q
    23         ;
    24         ;F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""  S ORN=$P(LST,",",ORD),QFLG=0 D:+PSOLST(ORN)=52
    25         ;.S PSORPSRX=$P(PSOLST(ORN),"^",2)
    26         ;
    27         K DIR,DIRUT,DTOUT,PSOOELSE,PSOREPX I +LST S PSOOELSE=1 D
    28         .;D FULL^VALM1 K DIR S DIR("A")="Number of Copies? ",DIR(0)="N^1:99:0",DIR("?")="Enter the number of copies you want (1 TO 99)",DIR("B")=1
    29         .;D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT)  S COPIES=Y
    30         .S COPIES=1
    31         .;K DIR S DIR("A")="Print adhesive portion of label only? ",DIR(0)="Y",DIR("B")="No",DIR("?",1)="If entire label, including trailers are to print press RETURN for default."
    32         .;S DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES." D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT)  S SIDE=Y
    33         .S SIDE=0
    34         .I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D  Q:$G(PSOREPX)
    35         ..;K DIR,DIRUT S DIR("A")="Do you want to resend to Dispensing System Device",DIR(0)="Y",DIR("B")="No"
    36         ..;D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT)  S PSODISP=$S(Y:0,1:1)
    37         ..S PSODISP=1
    38         .K DIRUT,DIR S DIR("A")="Comments(Required): ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX)
    39         .D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT)  S (PCOM,PCOMX)=Y
    40         .S PSOCLC=DUZ
    41         .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""  S ORN=$P(LST,",",ORD),QFLG=0 D:+PSOLST(ORN)=52 RX
    42         .S VALMBCK="R"
    43         I $G(PSOREPX) S VALMBCK="R",VALMSG="No Labels Reprinted."
    44         K PSOREPX
    45         I '$G(PSOOELSE) S VALMBCK=""
    46         D ^PSOBUILD
    47         K PSOMSG,PSORPSRX,QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,I,J,JJJ,K,RX,RXF,X,Y,Z,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSOOELSE,ORD,LST,ORN D KVA^VADPT
    48         Q
    49         ;
    50 RX      ;process reprint request
    51         ;
    52         S PSORPSRX=$P(PSOLST(ORN),"^",2)
    53         ;S PSOZAF="" S PSOZAF=$O(^VA(200,"B","AUTOFINISH,RX",PSOZAF)) ;vfah
    54         S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX"
    55         D ^DIC K DIC
    56         S PSOZAF=+Y
    57         I $P($G(^PSRX(PSORPSRX,"OR1")),"^",5)'=$G(PSOZAF) S VFANRP=1 ;vfah
    58         I $G(VFANRP)=1 W $C(7),!,"Re-Print only available for Autofinished Rxs" D PAUSE^VALM1 K PSORPSRX,VFANRP Q
    59         ;Q:$G(VFANRP)=1
    60         ;
    61         Q:$P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^")>11
    62         S PSORPSRX=$P(PSOLST(ORN),"^",2) D PSOL^PSSLOCK(PSORPSRX) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P($G(^PSRX(PSORPSRX,0)),"^")),! D PAUSE^VALM1 K PSORPSRX,PSOMSG Q
    63         S RX=$P(PSOLST(ORN),"^",2),STA=$P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^") D CHK I $G(QFLG) D ULR Q
    64         S RXF=0,ZD(RX)=DT,REPRINT=1
    65         S RXRP($P(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE
    66         I $G(PSODISP)=1 S RXRP($P(PSOLST(ORN),"^",2),"RP")=1
    67         S RXFL($P(PSOLST(ORN),"^",2))=0 F ZZZ=0:0 S ZZZ=$O(^PSRX($P(PSOLST(ORN),"^",2),1,ZZZ)) Q:'ZZZ  S RXFL($P(PSOLST(ORN),"^",2))=ZZZ
    68         K ZZZ
    69         I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=RX_"," S ST="" D ACT1,ULR Q
    70         F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
    71         I $L(PSORX("PSOL",PSOX2))+$L(RX)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RX_","
    72         E  S PSORX("PSOL",PSOX2+1)=RX_","
    73         S ST="" D ACT1
    74         D ULR
    75         Q
    76 CHK     ;check for valid reprint
    77         I DT>$P(^PSRX(RX,2),"^",6) D  S QFLG=1 Q
    78         .I $P(^PSRX(RX,"STA"),"^")<11 S $P(^PSRX(RX,"STA"),"^")=11 D
    79         ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(RX,"SC","ZE",COMM) K COMM
    80         S DFN=PSODFN D DEM^VADPT I $P(VADM(6),"^",2)]"" D  S QFLG=1 Q
    81         .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A")
    82         .D ACT1
    83         I $D(RXPR($P(PSOLST(ORN),"^",2)))!$D(RXRP($P(PSOLST(ORN),"^",2))) S QFLG=1 Q
    84         D VALID Q:$G(QFLG)
    85         S X=$O(^PS(52.5,"B",RX,0)) I X,'$G(^PS(52.5,X,"P")) S QFLG=1 Q
    86         I $G(X)'>0 G GOOD
    87         I $P($G(^PS(52.5,X,0)),"^",7)']"" G GOOD
    88         I $P($G(^PS(52.5,X,0)),"^",7)="Q" K X,XX S QFLG=1 Q
    89         I $P($G(^PS(52.5,X,0)),"^",7)="L" K X,XX S QFLG=1 Q
    90 GOOD    K X
    91         I $D(^PS(52.4,RX)) S QFLG=1 Q
    92         I $D(^PS(52.4,"AREF",PSODFN,RX)) S QFLG=1 Q
    93         I $G(PSODIV),$D(^PSRX(RX,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=RX D CHK1^PSOUTLA I $G(POERR)&(PSPOP) S QFLG=1 Q
    94         I STA=3!(STA=4)!(STA=12) S QFLG=1 Q
    95         Q
    96 ACT1    S RXF=0 F J=0:0 S J=$O(^PSRX(RX,1,J)) Q:'J  S RXF=J S:J>5 RXF=J+1
    97         S IR=0 F J=0:0 S J=$O(^PSRX(RX,"A",J)) Q:'J  S IR=J
    98         S IR=IR+1,^PSRX(RX,"A",0)="^52.3DA^"_IR_"^"_IR
    99         D NOW^%DTC S ^PSRX(RX,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,XX,%,%H,%I,RXF
    100         S:$P(^PSRX(RX,2),"^",15)&($G(ST)'="C") $P(^PSRX(RX,2),"^",14)=1
    101         Q
    102 VALID   ;check for rx in label array
    103         I $O(PSORX("PSOL",0)) D
    104         .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  I PSORX("PSOL",PSOX1)[RX_"," S QFLG=1 Q
    105         Q
    106 ULR     ;
    107         I $G(PSORPSRX) D PSOUL^PSSLOCK(PSORPSRX)
    108         Q
     1PSOAFRP1 ;VFA/HMS autofinish rx speed reprint for listman ;1/30/07  19:48
     2 ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 39
     3 ; Copyright (C) 2007 WorldVistA
     4 ;
     5 ; This program is free software; you can redistribute it and/or modify
     6 ; it under the terms of the GNU General Public License as published by
     7 ; the Free Software Foundation; either version 2 of the License, or
     8 ; (at your option) any later version.
     9 ;
     10 ; This program is distributed in the hope that it will be useful,
     11 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     12 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     13 ; GNU General Public License for more details.
     14 ;
     15 ; You should have received a copy of the GNU General Public License
     16 ; along with this program; if not, write to the Free Software
     17 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     18 ;'Modified' MAS Patient Look-up Check Cross-References June 1987
     19 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
     20SEL N PSODISP,VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
     21 S PSOAFYN="Y"
     22 S RXCNT=0 K PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR S LST=Y I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" Q
     23 ;
     24 ;F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""  S ORN=$P(LST,",",ORD),QFLG=0 D:+PSOLST(ORN)=52
     25 ;.S PSORPSRX=$P(PSOLST(ORN),"^",2)
     26 ;
     27 K DIR,DIRUT,DTOUT,PSOOELSE,PSOREPX I +LST S PSOOELSE=1 D
     28 .;D FULL^VALM1 K DIR S DIR("A")="Number of Copies? ",DIR(0)="N^1:99:0",DIR("?")="Enter the number of copies you want (1 TO 99)",DIR("B")=1
     29 .;D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT)  S COPIES=Y
     30 .S COPIES=1
     31 .;K DIR S DIR("A")="Print adhesive portion of label only? ",DIR(0)="Y",DIR("B")="No",DIR("?",1)="If entire label, including trailers are to print press RETURN for default."
     32 .;S DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES." D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT)  S SIDE=Y
     33 .S SIDE=0
     34 .I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D  Q:$G(PSOREPX)
     35 ..;K DIR,DIRUT S DIR("A")="Do you want to resend to Dispensing System Device",DIR(0)="Y",DIR("B")="No"
     36 ..;D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT)  S PSODISP=$S(Y:0,1:1)
     37 ..S PSODISP=1
     38 .K DIRUT,DIR S DIR("A")="Comments(Required): ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX)
     39 .D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT)  S (PCOM,PCOMX)=Y
     40 .S PSOCLC=DUZ
     41 .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""  S ORN=$P(LST,",",ORD),QFLG=0 D:+PSOLST(ORN)=52 RX
     42 .S VALMBCK="R"
     43 I $G(PSOREPX) S VALMBCK="R",VALMSG="No Labels Reprinted."
     44 K PSOREPX
     45 I '$G(PSOOELSE) S VALMBCK=""
     46 D ^PSOBUILD
     47 K PSOMSG,PSORPSRX,QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,I,J,JJJ,K,RX,RXF,X,Y,Z,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSOOELSE,ORD,LST,ORN D KVA^VADPT
     48 Q
     49 ;
     50RX ;process reprint request
     51 ;
     52 S PSORPSRX=$P(PSOLST(ORN),"^",2)
     53 ;S PSOZAF="" S PSOZAF=$O(^VA(200,"B","AUTOFINISH,RX",PSOZAF)) ;vfah
     54 S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX"
     55 D ^DIC K DIC
     56 S PSOZAF=+Y
     57 I $P($G(^PSRX(PSORPSRX,"OR1")),"^",5)'=$G(PSOZAF) S VFANRP=1 ;vfah
     58 I $G(VFANRP)=1 W $C(7),!,"Re-Print only available for Autofinished Rxs" D PAUSE^VALM1 K PSORPSRX,VFANRP Q
     59 ;Q:$G(VFANRP)=1
     60 ;
     61 Q:$P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^")>11
     62 S PSORPSRX=$P(PSOLST(ORN),"^",2) D PSOL^PSSLOCK(PSORPSRX) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P($G(^PSRX(PSORPSRX,0)),"^")),! D PAUSE^VALM1 K PSORPSRX,PSOMSG Q
     63 S RX=$P(PSOLST(ORN),"^",2),STA=$P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^") D CHK I $G(QFLG) D ULR Q
     64 S RXF=0,ZD(RX)=DT,REPRINT=1
     65 S RXRP($P(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE
     66 I $G(PSODISP)=1 S RXRP($P(PSOLST(ORN),"^",2),"RP")=1
     67 S RXFL($P(PSOLST(ORN),"^",2))=0 F ZZZ=0:0 S ZZZ=$O(^PSRX($P(PSOLST(ORN),"^",2),1,ZZZ)) Q:'ZZZ  S RXFL($P(PSOLST(ORN),"^",2))=ZZZ
     68 K ZZZ
     69 I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=RX_"," S ST="" D ACT1,ULR Q
     70 F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
     71 I $L(PSORX("PSOL",PSOX2))+$L(RX)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RX_","
     72 E  S PSORX("PSOL",PSOX2+1)=RX_","
     73 S ST="" D ACT1
     74 D ULR
     75 Q
     76CHK ;check for valid reprint
     77 I DT>$P(^PSRX(RX,2),"^",6) D  S QFLG=1 Q
     78 .I $P(^PSRX(RX,"STA"),"^")<11 S $P(^PSRX(RX,"STA"),"^")=11 D
     79 ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(RX,"SC","ZE",COMM) K COMM
     80 S DFN=PSODFN D DEM^VADPT I $P(VADM(6),"^",2)]"" D  S QFLG=1 Q
     81 .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A")
     82 .D ACT1
     83 I $D(RXPR($P(PSOLST(ORN),"^",2)))!$D(RXRP($P(PSOLST(ORN),"^",2))) S QFLG=1 Q
     84 D VALID Q:$G(QFLG)
     85 S X=$O(^PS(52.5,"B",RX,0)) I X,'$G(^PS(52.5,X,"P")) S QFLG=1 Q
     86 I $G(X)'>0 G GOOD
     87 I $P($G(^PS(52.5,X,0)),"^",7)']"" G GOOD
     88 I $P($G(^PS(52.5,X,0)),"^",7)="Q" K X,XX S QFLG=1 Q
     89 I $P($G(^PS(52.5,X,0)),"^",7)="L" K X,XX S QFLG=1 Q
     90GOOD K X
     91 I $D(^PS(52.4,RX)) S QFLG=1 Q
     92 I $D(^PS(52.4,"AREF",PSODFN,RX)) S QFLG=1 Q
     93 I $G(PSODIV),$D(^PSRX(RX,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=RX D CHK1^PSOUTLA I $G(POERR)&(PSPOP) S QFLG=1 Q
     94 I STA=3!(STA=4)!(STA=12) S QFLG=1 Q
     95 Q
     96ACT1 S RXF=0 F J=0:0 S J=$O(^PSRX(RX,1,J)) Q:'J  S RXF=J S:J>5 RXF=J+1
     97 S IR=0 F J=0:0 S J=$O(^PSRX(RX,"A",J)) Q:'J  S IR=J
     98 S IR=IR+1,^PSRX(RX,"A",0)="^52.3DA^"_IR_"^"_IR
     99 D NOW^%DTC S ^PSRX(RX,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,XX,%,%H,%I,RXF
     100 S:$P(^PSRX(RX,2),"^",15)&($G(ST)'="C") $P(^PSRX(RX,2),"^",14)=1
     101 Q
     102VALID ;check for rx in label array
     103 I $O(PSORX("PSOL",0)) D
     104 .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  I PSORX("PSOL",PSOX1)[RX_"," S QFLG=1 Q
     105 Q
     106ULR ;
     107 I $G(PSORPSRX) D PSOUL^PSSLOCK(PSORPSRX)
     108 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFRPT.m

    r613 r623  
    1 PSOAFRPT        ;VFA/HMS autofinish reprint of a prescription label ;1/30/07  19:40
    2         ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 41
    3         ; Copyright (C) 2007 WorldVistA
    4         ;
    5         ; This program is free software; you can redistribute it and/or modify
    6         ; it under the terms of the GNU General Public License as published by
    7         ; the Free Software Foundation; either version 2 of the License, or
    8         ; (at your option) any later version.
    9         ;
    10         ; This program is distributed in the hope that it will be useful,
    11         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    12         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    13         ; GNU General Public License for more details.
    14         ;
    15         ; You should have received a copy of the GNU General Public License
    16         ; along with this program; if not, write to the Free Software
    17         ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    18         ;'Modified' MAS Patient Look-up Check Cross-References June 1987
    19         ;External reference to ^PSDRUG supported by DBIA 221
    20         ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
    21 BCK     I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q
    22         S PSOAFYN="Y"
    23         N PSODISP S PSORPLRX=$P(PSOLST(ORN),"^",2)
    24         ;
    25         ;S PSOZAF="" S PSOZAF=$O(^VA(200,"B","AUTOFINISH,RX",PSOZAF)) ;vfah
    26         S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX"
    27         D ^DIC K DIC
    28         S PSOZAF=+Y
    29         I $P($G(^PSRX(PSORPLRX,"OR1")),"^",5)'=$G(PSOZAF) S VALMBCK="",VALMSG="Re-Print option is only available for Autofinshed Rxs",QFLG=1 D ULR,KILL K PSOZAF Q  ;vfah
    30         ;
    31         D PSOL^PSSLOCK(PSORPLRX) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG Q
    32         I $G(POERR) K QFLG D  I $G(QFLG) D ULR G KILL
    33         .D FULL^VALM1 S X=$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),Y=$P(PSOLST(ORN),"^",2)_"^"_X,Y(0)=$G(^PSRX($P(PSOLST(ORN),"^",2),0))
    34         .I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial Rx has been requested!",QFLG=1 Q
    35         .I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!",QFLG=1 Q
    36         .I $D(RXRS($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="Rx is being pulled from suspense!",QFLG=1 Q
    37         .S RX=$P(PSOLST(ORN),"^",2) D VALID^PSORXRP1 S:$G(QFLG) VALMBCK="",VALMSG="A New Label has been requested already!"
    38         S (PPL,DA,RX)=+Y,PDA=Y(0),RXF=0,ZD(DA)=DT,REPRINT=1,STA=+$G(^PSRX(+Y,"STA"))
    39         I $P(^PSRX(RX,"STA"),"^")=14 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued by Provider.",QFLG=1 D ULR,KILL Q
    40         I $P(^PSRX(RX,"STA"),"^")=15 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued due to editing.",QFLG=1 D ULR,KILL Q
    41         I $P(^PSRX(RX,"STA"),"^")=16 S VALMBCK="",VALMSG="Cannot Reprint! Placed on HOLD by Provider.",QFLG=1 D ULR,KILL Q
    42         I DT>$P(^PSRX(RX,2),"^",6) D  G PAUSE
    43         .W !,$C(7),"Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 D
    44         ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM) K COMM
    45         S DFN=$P(PDA,"^",2) D DEM^VADPT I $P(VADM(6),"^",2)]"" D  G PAUSE
    46         .W $C(7),!!,$P(^DPT($P(PDA,"^",2),0),"^")_" Died "_$P(VADM(6),"^",2)_".",!
    47         .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A")
    48         .D ACT1,ULR,KILL
    49         S X=$O(^PS(52.5,"B",DA,0)) I X,'$G(^PS(52.5,X,"P")) W !,$C(7),"RX MAY NOT BE PRINTED using this option, use SUSPENSE FUNCTIONS Options." K X G PAUSE
    50         S PSX=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J  S PSX=J
    51         K X
    52         I $D(^PS(52.4,DA)) W !,"Prescription is Non-Verified",!! G PAUSE
    53         S DFN=$P(^PSRX(DA,0),"^",2) I $D(^PS(52.4,"AREF",DFN,DA)) W !,"Prescription is waiting for others to be verified",!! G PAUSE
    54         I $G(PSODIV),$D(^PSRX(DA,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=DA D CHK1^PSOUTLA G:$G(POERR)&(PSPOP) PAUSE G:PSPOP PAUSE
    55         I STA=3 W !?3,"Prescription is on Hold" G PAUSE
    56         I STA=4 W !?3,"Prescription is Pending Due to Drug Interactions" G PAUSE
    57         I STA=12 W !?3,"Prescription is Discontinued" G PAUSE
    58         S COPIES=1
    59         S SIDE=0
    60         S PSODISP=0
    61         I $D(DIRUT) D ULR G KILL
    62         D ACT I $D(DIRUT) D ULR,KILL G PAUSE
    63         Q:$G(POERR)&($D(PCOM))  G PAUSE:$D(PCOM)
    64         F I=1,2,4,6,7,9,13,16 S P(I)=$P(PDA,"^",I)
    65         S P(6)=+P(6) I $D(^PSRX(DA,"TN")),^("TN")]"" S P(6)=^("TN")
    66         W !!,"Rx # "_P(1),?23,$E(P(13),4,5)_"/"_$E(P(13),6,7)_"/"_$E(P(13),2,3),!,$S($D(^DPT(+P(2),0)):$P(^(0),"^"),1:"Not on File"),?30,"#"_P(7),!
    67         I $P($G(^PSRX(DA,"SIG")),"^",2) S D=0 D  K D,FSIG
    68         .D FSIG^PSOUTLA("R",DA,75) F  S D=$O(FSIG(D)) W !,FSIG(D) Q:'$O(FSIG(D))
    69         E  D EN3^PSOUTLA1(DA,75) S D=0 F  S D=$O(BSIG(D)) W !,BSIG(D) Q:'$O(BSIG(D))
    70         K D,BSIG
    71         ;
    72         ;W !!,$S((P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! S PHYS=$S($D(^VA(200,+P(4),0)):$P(^(0),"^"),1:"Unknown") W PHYS K PHYS
    73         W !!,$S((P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),!
    74         S PHYS=$$GET1^DIQ(200,+P(4),.01,"I")
    75         I PHYS="" S PHYS="Unknown"
    76         W PHYS K PHYS
    77         ;
    78         ;W ?25,$S($D(^VA(200,+P(16),0)):$P(^(0),"^"),1:"Unknown"),!,"# of Refills: "_$G(P(9))
    79         W ?25
    80         S PSOAFENT=$$GET1^DIQ(200,+P(16),.01,"I")
    81         I PSOAFENT="" S PHYS="Unknown"
    82         W PSOAFENT,!,"# of Refills: "_$G(P(9))
    83         ;
    84         I $G(RX) S RXFL(RX)=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(RX,1,ZZZ)) Q:'ZZZ  S RXFL(RX)=ZZZ
    85         K PSOELSE I '$G(POERR) S PSOELSE=1 D @$S($P($G(PSOPAR),"^",26):"^PSORXL",1:"Q^PSORXL")
    86         I '$G(PSOELSE) D
    87         .S RXRP($P(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE
    88         .I $G(PSODISP)=1 S RXRP($P(PSOLST(ORN),"^",2),"RP")=1
    89         .I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=DA_"," Q
    90         .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
    91         .I $L(PSORX("PSOL",PSOX2))+$L(DA)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_DA_","
    92         .E  S PSORX("PSOL",PSOX2+1)=DA_","
    93         K PCOMX,PSPOP,PPL,COPIES,SIDE,PCOM,IOP,PSL,PSNP,PSOELSE,ZZZ
    94 PAUSE   K RX,PPL,ZD(+$G(DA)),DA I $G(POERR) K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E",DIR("A",1)=" ",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DUOUT,DTOUT S VALMBCK="R"
    95         D ULR K PSORPLRX
    96         Q
    97         ;
    98 ACT     K DIR S DIR("A")="Comments: ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX)
    99         D ^DIR K DIR Q:$D(DIRUT)!($D(DIROUT))  S (PCOM,PCOMX)=X
    100         I '$D(PSOCLC) S PSOCLC=DUZ
    101 ACT1    S RXF=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J  S RXF=J S:J>5 RXF=J+1
    102         S IR=0 F J=0:0 S J=$O(^PSRX(DA,"A",J)) Q:'J  S IR=J
    103         S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
    104         D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,PCOM,XX,%,%H,%I,RXF
    105         S:$P(^PSRX(DA,2),"^",15)&($G(ST)'="C") $P(^PSRX(DA,2),"^",14)=1
    106         Q
    107         ;
    108 KILL    K QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,DA,DIC,I,J,JJJ,K,RX,RXF,X,Y,Z,DFN,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSOMSG,PSORPLRX D KVA^VADPT Q
    109         ;
    110 ULR     ;
    111         I $G(PSORPLRX) D PSOUL^PSSLOCK(PSORPLRX)
    112         Q
     1PSOAFRPT ;VFA/HMS autofinish reprint of a prescription label ;1/30/07  19:40
     2 ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 39
     3 ; Copyright (C) 2007 WorldVistA
     4 ;
     5 ; This program is free software; you can redistribute it and/or modify
     6 ; it under the terms of the GNU General Public License as published by
     7 ; the Free Software Foundation; either version 2 of the License, or
     8 ; (at your option) any later version.
     9 ;
     10 ; This program is distributed in the hope that it will be useful,
     11 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     12 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     13 ; GNU General Public License for more details.
     14 ;
     15 ; You should have received a copy of the GNU General Public License
     16 ; along with this program; if not, write to the Free Software
     17 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     18 ;'Modified' MAS Patient Look-up Check Cross-References June 1987
     19 ;External reference to ^PSDRUG supported by DBIA 221
     20 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
     21BCK I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q
     22 S PSOAFYN="Y"
     23 N PSODISP S PSORPLRX=$P(PSOLST(ORN),"^",2)
     24 ;
     25 ;S PSOZAF="" S PSOZAF=$O(^VA(200,"B","AUTOFINISH,RX",PSOZAF)) ;vfah
     26 S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX"
     27 D ^DIC K DIC
     28 S PSOZAF=+Y
     29 I $P($G(^PSRX(PSORPLRX,"OR1")),"^",5)'=$G(PSOZAF) S VALMBCK="",VALMSG="Re-Print option is only available for Autofinshed Rxs",QFLG=1 D ULR,KILL K PSOZAF Q  ;vfah
     30 ;
     31 D PSOL^PSSLOCK(PSORPLRX) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG Q
     32 I $G(POERR) K QFLG D  I $G(QFLG) D ULR G KILL
     33 .D FULL^VALM1 S X=$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),Y=$P(PSOLST(ORN),"^",2)_"^"_X,Y(0)=$G(^PSRX($P(PSOLST(ORN),"^",2),0))
     34 .I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial Rx has been requested!",QFLG=1 Q
     35 .I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!",QFLG=1 Q
     36 .I $D(RXRS($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="Rx is being pulled from suspense!",QFLG=1 Q
     37 .S RX=$P(PSOLST(ORN),"^",2) D VALID^PSORXRP1 S:$G(QFLG) VALMBCK="",VALMSG="A New Label has been requested already!"
     38 S (PPL,DA,RX)=+Y,PDA=Y(0),RXF=0,ZD(DA)=DT,REPRINT=1,STA=+$G(^PSRX(+Y,"STA"))
     39 I $P(^PSRX(RX,"STA"),"^")=14 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued by Provider.",QFLG=1 D ULR,KILL Q
     40 I $P(^PSRX(RX,"STA"),"^")=15 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued due to editing.",QFLG=1 D ULR,KILL Q
     41 I $P(^PSRX(RX,"STA"),"^")=16 S VALMBCK="",VALMSG="Cannot Reprint! Placed on HOLD by Provider.",QFLG=1 D ULR,KILL Q
     42 I DT>$P(^PSRX(RX,2),"^",6) D  G PAUSE
     43 .W !,$C(7),"Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 D
     44 ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM) K COMM
     45 S DFN=$P(PDA,"^",2) D DEM^VADPT I $P(VADM(6),"^",2)]"" D  G PAUSE
     46 .W $C(7),!!,$P(^DPT($P(PDA,"^",2),0),"^")_" Died "_$P(VADM(6),"^",2)_".",!
     47 .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A")
     48 .D ACT1,ULR,KILL
     49 S X=$O(^PS(52.5,"B",DA,0)) I X,'$G(^PS(52.5,X,"P")) W !,$C(7),"RX MAY NOT BE PRINTED using this option, use SUSPENSE FUNCTIONS Options." K X G PAUSE
     50 S PSX=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J  S PSX=J
     51 K X
     52 I $D(^PS(52.4,DA)) W !,"Prescription is Non-Verified",!! G PAUSE
     53 S DFN=$P(^PSRX(DA,0),"^",2) I $D(^PS(52.4,"AREF",DFN,DA)) W !,"Prescription is waiting for others to be verified",!! G PAUSE
     54 I $G(PSODIV),$D(^PSRX(DA,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=DA D CHK1^PSOUTLA G:$G(POERR)&(PSPOP) PAUSE G:PSPOP PAUSE
     55 I STA=3 W !?3,"Prescription is on Hold" G PAUSE
     56 I STA=4 W !?3,"Prescription is Pending Due to Drug Interactions" G PAUSE
     57 I STA=12 W !?3,"Prescription is Discontinued" G PAUSE
     58 S COPIES=1
     59 S SIDE=0
     60 S PSODISP=0
     61 I $D(DIRUT) D ULR G KILL
     62 D ACT I $D(DIRUT) D ULR,KILL G PAUSE
     63 Q:$G(POERR)&($D(PCOM))  G PAUSE:$D(PCOM)
     64 F I=1,2,4,6,7,9,13,16 S P(I)=$P(PDA,"^",I)
     65 S P(6)=+P(6) I $D(^PSRX(DA,"TN")),^("TN")]"" S P(6)=^("TN")
     66 W !!,"Rx # "_P(1),?23,$E(P(13),4,5)_"/"_$E(P(13),6,7)_"/"_$E(P(13),2,3),!,$S($D(^DPT(+P(2),0)):$P(^(0),"^"),1:"Not on File"),?30,"#"_P(7),!
     67 I $P($G(^PSRX(DA,"SIG")),"^",2) S D=0 D  K D,FSIG
     68 .D FSIG^PSOUTLA("R",DA,75) F  S D=$O(FSIG(D)) W !,FSIG(D) Q:'$O(FSIG(D))
     69 E  D EN3^PSOUTLA1(DA,75) S D=0 F  S D=$O(BSIG(D)) W !,BSIG(D) Q:'$O(BSIG(D))
     70 K D,BSIG
     71 ;
     72 ;W !!,$S((P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! S PHYS=$S($D(^VA(200,+P(4),0)):$P(^(0),"^"),1:"Unknown") W PHYS K PHYS
     73 W !!,$S((P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),!
     74 S PHYS=$$GET1^DIQ(200,+P(4),.01,"I")
     75 I PHYS="" S PHYS="Unknown"
     76 W PHYS K PHYS
     77 ;
     78 ;W ?25,$S($D(^VA(200,+P(16),0)):$P(^(0),"^"),1:"Unknown"),!,"# of Refills: "_$G(P(9))
     79 W ?25
     80 S PSOAFENT=$$GET1^DIQ(200,+P(16),.01,"I")
     81 I PSOAFENT="" S PHYS="Unknown"
     82 W PSOAFENT,!,"# of Refills: "_$G(P(9))
     83 ;
     84 I $G(RX) S RXFL(RX)=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(RX,1,ZZZ)) Q:'ZZZ  S RXFL(RX)=ZZZ
     85 K PSOELSE I '$G(POERR) S PSOELSE=1 D @$S($P($G(PSOPAR),"^",26):"^PSORXL",1:"Q^PSORXL")
     86 I '$G(PSOELSE) D
     87 .S RXRP($P(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE
     88 .I $G(PSODISP)=1 S RXRP($P(PSOLST(ORN),"^",2),"RP")=1
     89 .I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=DA_"," Q
     90 .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
     91 .I $L(PSORX("PSOL",PSOX2))+$L(DA)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_DA_","
     92 .E  S PSORX("PSOL",PSOX2+1)=DA_","
     93 K PCOMX,PSPOP,PPL,COPIES,SIDE,PCOM,IOP,PSL,PSNP,PSOELSE,ZZZ
     94PAUSE K RX,PPL,ZD(+$G(DA)),DA I $G(POERR) K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E",DIR("A",1)=" ",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DUOUT,DTOUT S VALMBCK="R"
     95 D ULR K PSORPLRX
     96 Q
     97 ;
     98ACT K DIR S DIR("A")="Comments: ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX)
     99 D ^DIR K DIR Q:$D(DIRUT)!($D(DIROUT))  S (PCOM,PCOMX)=X
     100 I '$D(PSOCLC) S PSOCLC=DUZ
     101ACT1 S RXF=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J  S RXF=J S:J>5 RXF=J+1
     102 S IR=0 F J=0:0 S J=$O(^PSRX(DA,"A",J)) Q:'J  S IR=J
     103 S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
     104 D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,PCOM,XX,%,%H,%I,RXF
     105 S:$P(^PSRX(DA,2),"^",15)&($G(ST)'="C") $P(^PSRX(DA,2),"^",14)=1
     106 Q
     107 ;
     108KILL K QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,DA,DIC,I,J,JJJ,K,RX,RXF,X,Y,Z,DFN,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSOMSG,PSORPLRX D KVA^VADPT Q
     109 ;
     110ULR ;
     111 I $G(PSORPLRX) D PSOUL^PSSLOCK(PSORPLRX)
     112 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFSET.m

    r613 r623  
    1 PSOAFSET        ;VFA/HMS autofinish site parameter set up ;1/30/07  19:41
    2         ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 41
    3         ; Copyright (C) 2007 WorldVistA
    4         ;
    5         ; This program is free software; you can redistribute it and/or modify
    6         ; it under the terms of the GNU General Public License as published by
    7         ; the Free Software Foundation; either version 2 of the License, or
    8         ; (at your option) any later version.
    9         ;
    10         ; This program is distributed in the hope that it will be useful,
    11         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    12         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    13         ; GNU General Public License for more details.
    14         ;
    15         ; You should have received a copy of the GNU General Public License
    16         ; along with this program; if not, write to the Free Software
    17         ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    18         ;'Modified' MAS Patient Look-up Check Cross-References June 1987
    19 VERS    ;
    20         ;Is taken from PSOLSET ;vfah
    21         ;Reference to ^PS(59.7 supported by DBIA 694
    22         ;Reference to ^PSX(550 supported by DBIA 2230
    23         ;Reference to ^%ZIS supported by DBIA 3435
    24         ;
    25         ;Called by PSOORFIN if using AutoFinish,Rx
    26         S PSOBAR1="",PSOBARS=0 ;make sure we have one
    27         S PSOCNT=0 F I=0:0 S I=$O(^PS(59,I)) Q:'I  S PSOCNT=PSOCNT+1,Y=I
    28         S PSOPAR=$G(^PS(59,PSOSITE,1)),PSOPAR7=$G(^PS(59,PSOSITE,"IB")),PSOSYS=$G(^PS(59.7,1,40.1)) D CUTDATE^PSOFUNC ;HMS From DIV3
    29         S PSOPINST=$P($G(^PS(59,PSOSITE,"INI")),"^")
    30         S (SITE,DA)=$P(^XMB(1,1,"XUS"),"^",17),DIC="4",DIQ(0)="IE",DR=".01;99",DIQ="PSXUTIL" D EN^DIQ1 S S3=$G(PSXUTIL(4,SITE,99,"I")),S2=$G(PSXUTIL(4,SITE,.01,"E")) K DA,DIC,DIQ(0),DR
    31         S PSXSYS=+$O(^PSX(550,"C",""))_"^"_$G(S3)_"^"_$G(S2),PSOINST=S3
    32         K S3,S2,S1,PSXUTIL
    33         I $G(PSXSYS) D
    34         .K:($P($G(^PSX(550,+PSXSYS,0)),"^",2)'="A") PSXSYS
    35         .S Y=$$VERSION^XPDUTL("PSO") I Y>6.0 S PSXVER=1
    36         E  K PSXSYS
    37         S PSODIV=$S(($P(PSOSYS,"^",2))&('$P(PSOSYS,"^",3)):0,1:1)
    38         ;
    39         ;I $D(DUZ),$D(^VA(200,+DUZ,0)) S PSOCLC=DUZ
    40         I $D(DUZ) S DIC="^VA(200,",DIC(0)="NQEZ",X=DUZ
    41         D ^DIC K DIC
    42         I +Y S PSOCLC=DUZ
    43         ;
    44 PLBL    Q  ;HMS No printer selection PSOAFSET ends here
    45 LBL     S %ZIS="MNQ",%ZIS("A")="Select LABEL PRINTER: " S:$G(PSOCLBL)&($D(PSOLAP))!($G(SUSPT)) %ZIS("B")=$S($G(SUSPT):PSLION,1:PSOLAP)
    46         D ^%ZIS K %ZIS,IO("Q"),IOP G:POP EXIT S @$S($G(SUSPT):"PSLION",1:"PSOLAP")=ION,PSOPIOST=$G(IOST(0))
    47         N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
    48         S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19),PSOIOS=IOS D ^%ZISC
    49 LASK    I $G(PSOPIOST),$D(^%ZIS(2,PSOPIOST,55,"B","LL")) G EXIT
    50         K DIR S DIR("A")="OK to assume label alignment is correct",DIR("B")="YES",DIR(0)="Y",DIR("?")="Enter Y if labels are aligned, N if they need to be aligned." D ^DIR G:Y!($D(DIRUT)) EXIT
    51 P2      S IOP=$G(PSOLAP) D ^%ZIS K IOP I POP W $C(7),!?5,"Printer is busy.",! G LASK
    52         U IO(0) W !,"Align labels so that a perforation is at the top of the",!,"print head and the left side is at column zero."
    53         W ! K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E" D ^DIR K DIR,DTOUT,DUOUT Q:$D(DIRUT)  D ^PSOLBLT D ^%ZISC
    54         K DIRUT,DIR S DIR("A")="Is this correct",DIR("B")="YES",DIR(0)="Y",DIR("?")="Enter Y if labels are aligned correctly, N if they need to be aligned." D ^DIR G:Y!($D(DIRUT)) EXIT
    55         G P2
    56 LEAVE   S XQUIT="" G FINAL
    57 Q       W !?10,$C(7),"Default printer for labels must be entered." G LBL
    58         ;
    59 EXIT    D ^%ZISC Q:$G(PSOCLBL)
    60         D:'$G(PSOBFLAG) GROUP K I,IOP,X,Y,%ZIS,DIC,J,DIR,X,Y,DTOUT,DIROUT,DIRUT,DUOUT Q
    61         ;
    62 FINAL   ;exit action from main menu - kill and quit
    63         K SITE,PSOCP,PSNP,PSL,PRCA,PSLION,PSOPINST
    64         K GROUPCNT,DISGROUP,PSOCAP,PSOINST,PSOION,PSONULBL,PSOSITE7,PFIO,PSOIOS,X,Y,PSOSYS,PSODIV,PSOPAR,PSOPAR7,PSOLAP,PSOPROP,PSOCLC,PSOCNT
    65         K PSODTCUT,PSOSITE,PSOPRPAS,PSOBAR1,PSOBAR0,PSOBARS,SIG,DIR,DIRUT,DTOUT,DIROUT,DUOUT,I,%ZIS,DIC,J,PSOREL
    66         Q
    67 GROUP   ;display group
    68         S GROUPCNT=0,AGROUP="" I $D(^PS(59.3,0)) F  S AGROUP=$O(^PS(59.3,"B",AGROUP)) Q:AGROUP=""  D
    69         .S GROUPCNT=GROUPCNT+1 I GROUPCNT=1 S AGROUP1=AGROUP
    70         S:GROUPCNT=1 GRPNME=AGROUP1,II="" G:GROUPCNT>1 GROUP1
    71         Q:'$D(GRPNME)  F  S II=$O(^PS(59.3,"B",GRPNME,II)) Q:II=""  S DISGROUP=II
    72         K AGROUP,AGROUP1,GRPNME,II
    73         Q
    74 GROUP1  W ! S DIC("A")="Bingo Board Display: ",DIC=59.3,DIC(0)="AEMQZ",DIR(0)="Y",DIR("?")="Enter 'Y' to select Bingo Board Display or 'N' to EXIT"
    75         S:$P($G(^PS(59,PSOSITE,1)),"^",20) DIC("B")=$P($G(^PS(59,PSOSITE,1)),"^",20)
    76         D ^DIC K DIC Q:$D(DTOUT)!($D(DUOUT))
    77         I +Y<0 W $C(7) S DIR("A",1)="A 'BINGO BOARD DISPLAY' should be selected!",DIR("A")="Do you want to try again",DIR("B")="YES",DIR("?")="A display group must be defined in order to run Bingo Board." D ^DIR Q:"Y"'[$E(X)  G GROUP
    78         S DISGROUP=+Y
    79         K DIR,DIC,AGROUP,AGROUP1,GRPNME,II
    80         Q
     1PSOAFSET ;VFA/HMS autofinish site parameter set up ;1/30/07  19:41
     2 ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 39
     3 ; Copyright (C) 2007 WorldVistA
     4 ;
     5 ; This program is free software; you can redistribute it and/or modify
     6 ; it under the terms of the GNU General Public License as published by
     7 ; the Free Software Foundation; either version 2 of the License, or
     8 ; (at your option) any later version.
     9 ;
     10 ; This program is distributed in the hope that it will be useful,
     11 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     12 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     13 ; GNU General Public License for more details.
     14 ;
     15 ; You should have received a copy of the GNU General Public License
     16 ; along with this program; if not, write to the Free Software
     17 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     18 ;'Modified' MAS Patient Look-up Check Cross-References June 1987
     19VERS ;
     20 ;Is taken from PSOLSET ;vfah
     21 ;Reference to ^PS(59.7 supported by DBIA 694
     22 ;Reference to ^PSX(550 supported by DBIA 2230
     23 ;Reference to ^%ZIS supported by DBIA 3435
     24 ;
     25 ;Called by PSOORFIN if using AutoFinish,Rx
     26 S PSOBAR1="",PSOBARS=0 ;make sure we have one
     27 S PSOCNT=0 F I=0:0 S I=$O(^PS(59,I)) Q:'I  S PSOCNT=PSOCNT+1,Y=I
     28 S PSOPAR=$G(^PS(59,PSOSITE,1)),PSOPAR7=$G(^PS(59,PSOSITE,"IB")),PSOSYS=$G(^PS(59.7,1,40.1)) D CUTDATE^PSOFUNC ;HMS From DIV3
     29 S PSOPINST=$P($G(^PS(59,PSOSITE,"INI")),"^")
     30 S (SITE,DA)=$P(^XMB(1,1,"XUS"),"^",17),DIC="4",DIQ(0)="IE",DR=".01;99",DIQ="PSXUTIL" D EN^DIQ1 S S3=$G(PSXUTIL(4,SITE,99,"I")),S2=$G(PSXUTIL(4,SITE,.01,"E")) K DA,DIC,DIQ(0),DR
     31 S PSXSYS=+$O(^PSX(550,"C",""))_"^"_$G(S3)_"^"_$G(S2),PSOINST=S3
     32 K S3,S2,S1,PSXUTIL
     33 I $G(PSXSYS) D
     34 .K:($P($G(^PSX(550,+PSXSYS,0)),"^",2)'="A") PSXSYS
     35 .S Y=$$VERSION^XPDUTL("PSO") I Y>6.0 S PSXVER=1
     36 E  K PSXSYS
     37 S PSODIV=$S(($P(PSOSYS,"^",2))&('$P(PSOSYS,"^",3)):0,1:1)
     38 ;
     39 ;I $D(DUZ),$D(^VA(200,+DUZ,0)) S PSOCLC=DUZ
     40 I $D(DUZ) S DIC="^VA(200,",DIC(0)="NQEZ",X=DUZ
     41 D ^DIC K DIC
     42 I +Y S PSOCLC=DUZ
     43 ;
     44PLBL Q  ;HMS No printer selection PSOAFSET ends here
     45LBL S %ZIS="MNQ",%ZIS("A")="Select LABEL PRINTER: " S:$G(PSOCLBL)&($D(PSOLAP))!($G(SUSPT)) %ZIS("B")=$S($G(SUSPT):PSLION,1:PSOLAP)
     46 D ^%ZIS K %ZIS,IO("Q"),IOP G:POP EXIT S @$S($G(SUSPT):"PSLION",1:"PSOLAP")=ION,PSOPIOST=$G(IOST(0))
     47 N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
     48 S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19),PSOIOS=IOS D ^%ZISC
     49LASK I $G(PSOPIOST),$D(^%ZIS(2,PSOPIOST,55,"B","LL")) G EXIT
     50 K DIR S DIR("A")="OK to assume label alignment is correct",DIR("B")="YES",DIR(0)="Y",DIR("?")="Enter Y if labels are aligned, N if they need to be aligned." D ^DIR G:Y!($D(DIRUT)) EXIT
     51P2 S IOP=$G(PSOLAP) D ^%ZIS K IOP I POP W $C(7),!?5,"Printer is busy.",! G LASK
     52 U IO(0) W !,"Align labels so that a perforation is at the top of the",!,"print head and the left side is at column zero."
     53 W ! K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E" D ^DIR K DIR,DTOUT,DUOUT Q:$D(DIRUT)  D ^PSOLBLT D ^%ZISC
     54 K DIRUT,DIR S DIR("A")="Is this correct",DIR("B")="YES",DIR(0)="Y",DIR("?")="Enter Y if labels are aligned correctly, N if they need to be aligned." D ^DIR G:Y!($D(DIRUT)) EXIT
     55 G P2
     56LEAVE S XQUIT="" G FINAL
     57Q W !?10,$C(7),"Default printer for labels must be entered." G LBL
     58 ;
     59EXIT D ^%ZISC Q:$G(PSOCLBL)
     60 D:'$G(PSOBFLAG) GROUP K I,IOP,X,Y,%ZIS,DIC,J,DIR,X,Y,DTOUT,DIROUT,DIRUT,DUOUT Q
     61 ;
     62FINAL ;exit action from main menu - kill and quit
     63 K SITE,PSOCP,PSNP,PSL,PRCA,PSLION,PSOPINST
     64 K GROUPCNT,DISGROUP,PSOCAP,PSOINST,PSOION,PSONULBL,PSOSITE7,PFIO,PSOIOS,X,Y,PSOSYS,PSODIV,PSOPAR,PSOPAR7,PSOLAP,PSOPROP,PSOCLC,PSOCNT
     65 K PSODTCUT,PSOSITE,PSOPRPAS,PSOBAR1,PSOBAR0,PSOBARS,SIG,DIR,DIRUT,DTOUT,DIROUT,DUOUT,I,%ZIS,DIC,J,PSOREL
     66 Q
     67GROUP ;display group
     68 S GROUPCNT=0,AGROUP="" I $D(^PS(59.3,0)) F  S AGROUP=$O(^PS(59.3,"B",AGROUP)) Q:AGROUP=""  D
     69 .S GROUPCNT=GROUPCNT+1 I GROUPCNT=1 S AGROUP1=AGROUP
     70 S:GROUPCNT=1 GRPNME=AGROUP1,II="" G:GROUPCNT>1 GROUP1
     71 Q:'$D(GRPNME)  F  S II=$O(^PS(59.3,"B",GRPNME,II)) Q:II=""  S DISGROUP=II
     72 K AGROUP,AGROUP1,GRPNME,II
     73 Q
     74GROUP1 W ! S DIC("A")="Bingo Board Display: ",DIC=59.3,DIC(0)="AEMQZ",DIR(0)="Y",DIR("?")="Enter 'Y' to select Bingo Board Display or 'N' to EXIT"
     75 S:$P($G(^PS(59,PSOSITE,1)),"^",20) DIC("B")=$P($G(^PS(59,PSOSITE,1)),"^",20)
     76 D ^DIC K DIC Q:$D(DTOUT)!($D(DUOUT))
     77 I +Y<0 W $C(7) S DIR("A",1)="A 'BINGO BOARD DISPLAY' should be selected!",DIR("A")="Do you want to try again",DIR("B")="YES",DIR("?")="A display group must be defined in order to run Bingo Board." D ^DIR Q:"Y"'[$E(X)  G GROUP
     78 S DISGROUP=+Y
     79 K DIR,DIC,AGROUP,AGROUP1,GRPNME,II
     80 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBINGO.m

    r613 r623  
    1 PSOBINGO        ;BHAM ISC/LC - BINGO BOARD OPTION DRIVER ;8/1/07 1:45pm
    2         ;;7.0;OUTPATIENT PHARMACY;**12,28,56,125,152,232,268,275**;DEC 1997;Build 8
    3         ;External Ref. to ^PS(55 is supp. by DBIA# 2228
    4         ;External Ref. to ^PSDRUG(, is supp. by DBIA# 221
    5         ;
    6         ;*232 add ATIC xref set/kill code here
    7         ;*275 BA xref sometimes gets corrupted, kill bad BA xref and quit
    8         ;
    9         S (FLAG,FLAG1)=0,(TRIPS,JOES,ADV,DGP)="" G:'$G(PSOAP) END D:'$D(PSOPAR) ^PSOLSET G:'$D(PSOPAR) END
    10 BEG     ;PSOAP=1 NEW ENTRY; 2=DISPLAY; 3=REMOVE
    11         D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) G:PSOAP=1 NEW I PSOAP=3 D BCRMV^PSOBING1 G:'$D(X) END
    12         I PSOAP=3 S DIC=52.11,DIC(0)="EMQZ",DIC("S")="I '$P($G(^PS(52.11,Y,0)),U,8)" D ^DIC K DIC G:+Y'>0 BEG G:($G(DTOUT))!($G(DUOUT)) END S DA=+Y,NAM=Y(0,0)
    13         I PSOAP=2 W !! K DIC,DIE,DLAYGO S (DIC,DIE)=52.11,DIC(0)="AEMQZ",DIC("A")="Enter Patient Name to Display: ",DIC("S")="I $P($G(^PS(52.11,Y,0)),U,4)=PSOSITE&'$P($G(^PS(52.11,Y,0)),U,7)"
    14         I PSOAP=2 D ^DIC K DIC G:+Y'>0!($G(DTOUT))!($G(DUOUT)) END S (DA,ODA)=+Y,NAM=Y(0,0)
    15         I PSOAP=3 D STUF,REMOVE1 G BEG
    16         I PSOAP=2,($P($G(^PS(52.11,DA,0)),"^",7)]"") W !!,NAM,"  is already in the display queue.",$C(7) G BEG
    17         I PSOAP=2,$P($P($G(^PS(52.11,DA,0)),"^",5),".")'=DT S Y=$P($P($G(^PS(52.11,DA,0)),"^",5),".") D DD^%DT W !!,$C(7),NAM," was entered on "_Y_".",!,"It can't be displayed and is now deleted." S DIK="^PS(52.11," D ^DIK K DIK G BEG
    18         I PSOAP=2&($P(^PS(52.11,ODA,0),"^",4)'=+PSOSITE) W !!,$C(7),NAM," was entered under the "_$P(^PS(59,$P(^(0),"^",4),0),"^")_" division." G BEG
    19         I PSOAP=2 S PSODRF=0 D CREF^PSOBING1 G:PSODRF BEG D  G BEG
    20         .S NM=$P(^DPT($P(^PS(52.11,ODA,0),"^"),0),"^"),DR="6////"_$E(TM1_"0000",1,4)_";8////"_NM_""
    21         .D PASS,SETUP S DA=ODA D STATS1^PSOBRPRT,WTIME^PSOBING1
    22 NEW     ;Init lookup
    23         W !! K DIC S DIC=2,DIC(0)="AEMQZ",DIC("A")="Enter Patient Name : " D ^DIC K DIC G:Y<0!($G(DUOUT))!($G(DTOUT)) END S (DA,ADA,DFN)=+Y D DEM^VADPT Q:VAERR  S NAM=VADM(1),SSN=$P(VADM(2),"^")
    24         K DD,DO S:$D(DISGROUP) DGP=$P($G(^PS(59.3,DISGROUP,0)),"^") S (DIC,DIE)="^PS(52.11,",X=ADA,DIC("DR")=$S($G(GROUPCNT)=1&($G(DISGROUP)):"2////"_DISGROUP_"",1:"2//^S X=DGP")
    25         S DIC(0)="LMNQZ",DLAYGO=59.3 D FILE^DICN K DD,DO,DIC G:Y'>0 NEW
    26         S JOES=$P(Y(0),"^",3),ADV=$P($G(^PS(59.3,JOES,0)),"^",2),DA=+Y
    27         I $G(DTOUT)!($G(DUOUT))!(X="") D WARN G NEW
    28 TIC     K TFLAG I ADV="T" S DIR(0)="NA^1:999999:0",DIR("A")="TICKET #:",DIR("?")="Ticket # must be numeric and unique" D ^DIR I $D(DUOUT)!($D(DTOUT))!($D(DIRUT)) D WARN G BEG
    29         S TFLAG=1 I PSOAP=1,$G(ADV)="T" W !! S TIC=+Y D
    30         .F TIEN=0:0 S TIEN=$O(^PS(52.11,"C",TIC,TIEN)) Q:'TIEN  I DA'=TIEN,($G(PSOSITE)=+$P(^PS(52.11,TIEN,0),"^",4)) D
    31         ..S TDFN=$P(^PS(52.11,TIEN,0),"^"),TSSN=$P(^PS(52.11,TIEN,1),"^",2),TFLAG=0 W !,$C(7),$P(^DPT(TDFN,0),"^")_" ("_TSSN_") was issued ticket # "_TIC,". Try again!",!
    32         .K TDFN,TIEN,TSSN Q:'TFLAG
    33         G:'TFLAG TIC I ADV="T" S DR="1////"_TIC_";3////"_PSOSITE_";4////"_TM_";5////"_$E(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////0",FLAG1=1 G PASS
    34         S DR="3////"_PSOSITE_";4////"_TM_";5////"_$E(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////0"
    35 PASS    S NFLAG=1 L +^PS(52.11,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) E  W !!,$C(7),Y(0,0)," is being edited!",! Q
    36         D ^DIE L -^PS(52.11,DA) I $G(DUOUT)!($G(DTOUT))!(X="") D WARN G BEG
    37         S:$G(PSOAP)=1 FLGG=0 G:$G(PSOAP)'=1 STRX1
    38 STRX    ;sto Rx #'s IN 52.11
    39         N BRXNUM,BBFTYP,BBFNUM,BBMW,MWDIR,II,FL,FLN,PR,PRN,PRNDT,FLNDT,Y
    40 STRX0   S DIR(0)="FO^1:11",DIR("A")="Enter Rx #",DIR("?")="^D HELP^PSOBINGO",DIR("??")="^D HELP2^PSOBINGO" D ^DIR G:X=""&($G(FLGG)) STRX1 I $D(DIRUT) D WARN G BEG
    41         S DIC=52,DIC(0)="EQM",DIC("S")="I $P($G(^PSRX(Y,0)),U,2)=ADA" D ^DIC K DIC I $D(DUOUT)!($D(DTOUT)) D WARN G BEG
    42         G:Y=-1 STRX0
    43         I $G(Y)<0&('$G(FLGG)) D WARN G BEG
    44         I $G(Y)<0&($G(FLGG)) G STRX1
    45         S BRXNUM=$P(Y,"^")
    46         I $D(^PSRX(BRXNUM,1,0)) F II=0:0 S II=$O(^PSRX(BRXNUM,1,II)) Q:'II  S FLN=II
    47         I $D(FLN) S FLNDT=$P(^PSRX(BRXNUM,1,FLN,0),"^"),FL="F"
    48         I $D(^PSRX(BRXNUM,"P",0)) F II=0:0 S II=$O(^PSRX(BRXNUM,"P",II)) Q:'II  S PRN=II
    49         I $D(PRN) S PRNDT=$P(^PSRX(BRXNUM,"P",PRN,0),"^"),PR="P"
    50         S:$D(FLN)!($D(PRN)) BBFTYP=$S($G(PRNDT)>$G(FLNDT):PR,1:"F")
    51         I $G(BBFTYP)="P" S BBFNUM=PRN,BBMW=$P(^PSRX(BRXNUM,"P",PRN,0),"^",2)
    52         I $G(BBFTYP)="F" S BBFNUM=FLN,BBMW=$P(^PSRX(BRXNUM,1,FLN,0),"^",2)
    53         I '$D(BBFTYP) S BBFTYP="F",BBFNUM=0,BBMW=$P(^PSRX(BRXNUM,0),"^",11)
    54 MW      ;
    55         I $G(BBMW)="M" W !?5,$C(7),"Routing is set for Mail" D DIR
    56         I $D(MWDIR) K BRXNUM,BBFTYP,BBFNUM,BBMW,MWDIR,II,FL,FLN,PR,PRN,PRNDT,FLNDT,Y G STRX
    57         ;
    58         S X=BRXNUM,DIC("DR")="1////"_BBFTYP_";2////"_BBFNUM_"",DLAYGO=52.11
    59         S DA(1)=DA,DIC="^PS(52.11,"_DA(1)_",2,",DIC(0)="L",DIC("P")=$P(^DD(52.11,12,0),"^",2) K DD,DO D FILE^DICN K Y,DD,DO,X,BRXNUM,BBFTYP,BBFNUM,II,FL,PR,PRNDT,FLNDT S FLGG=1 G STRX
    60         ;
    61 STRX1   D:PSOAP=1&($G(ADV)="N") CHKUP,NOTE G:'NFLAG BEG D STUF G:FLAG BEG Q:PSOAP=2
    62 SETUP   S ZZZ=0 I '$D(^PS(59.2,DT,0)) K DD,DIC,DO,DA S X=DT,DIC="^PS(59.2,",DIC(0)="",DINUM=X,DLAYGO=59.2 D FILE^DICN K DD,DO S ZZZ=1 Q:Y'>0
    63         I ZZZ=1 K DD,DO S DLAYGO=59.2,DA(1)=+Y,DIC=DIC_DA(1)_",1,",(DINUM,X)=PSOSITE,DIC(0)="",DIC("P")=$P(^DD(59.2,1,0),"^",2) D FILE^DICN K DD,DO,DIC,DA Q:Y'>0
    64         Q:PSOAP=2&($P($G(^PS(59.2,DT,1,PSOSITE,0)),"^"))  I ZZZ=0 K DD,DIC,DO,DA S DA(1)=DT,(DINUM,X)=PSOSITE,DIC="^PS(59.2,"_DT_",1,",DIC(0)="LZ",DLAYGO=59.2 D FILE^DICN K DD,DIC,DA,DO Q:PSOAP=2  G NEW
    65         G BEG
    66 STUF    S RX0=^PS(52.11,DA,0),JOES=$P(RX0,"^",4),TICK=$P($G(RX0),"^",2) Q:PSOAP=3  G:ADV="T"&($G(FLAG1)=1)&('$G(TICK)) WARN G:'$G(JOES)!($G(NAM)']"") WARN
    67         W:PSOAP=2 !!,"Patient added in display queue." W:PSOAP=1 !!,"Record is added." Q
    68 WARN    W !!!,$C(7),"Patient record incomplete!" S FLAG=1,DIK="^PS(52.11," D ^DIK G SHOW Q
    69 REMOVE  S DIK="^PS(52.11," D ^DIK
    70 SHOW    K DIK,DA,ADA W !!,"Record is removed."
    71         Q
    72 REMOVE1 ;
    73         Q:'$D(^PS(52.11,"ANAM",$P(^PS(52.11,DA,0),"^",3),$P(^(1),"^",3)_$P(^(1),"^",4)_" "_$P(^DPT(+$P(^PS(52.11,DA,0),"^"),0),"^"),DA))
    74         N DIE,DR I $D(^PS(52.11,"ANAM",$P(^PS(52.11,DA,0),"^",3),$P(^(1),"^",3)_$P(^(1),"^",4)_" "_$P(^DPT(+$P(^PS(52.11,DA,0),"^"),0),"^"),DA)) S DIE="^PS(52.11,",DR="7////1" D
    75         .D ^DIE
    76         .K ^PS(52.11,"ANAM",$P(^PS(52.11,DA,0),"^",3),$P(^(1),"^",3)_$P(^(1),"^",4)_" "_$P(^DPT(+$P(^PS(52.11,DA,0),"^"),0),"^"),DA)
    77         I $D(^PS(52.11,"ATIC",+$P(^PS(52.11,DA,0),"^",3),+$P(^(0),"^",2),DA)) S DIE="^PS(52.11,",DR="7////1" D
    78         .D ^DIE
    79         .K ^PS(52.11,"ATIC",+$P(^PS(52.11,DA,0),"^",3),+$P(^(0),"^",2),DA)
    80         Q
    81 CHKUP   ;Multi & dupe names
    82         S SDA=DA S:'$D(DFN) DFN=PSODFN G:$O(^PS(52.11,"B",DFN,0))=DA BROW F P=0:0 S P=$O(^PS(52.11,"B",DFN,P)) Q:'P!(P=DA)  S LAST=P
    83         Q:'$G(LAST)  S TRIPS=$P($G(^PS(52.11,LAST,1)),"^",4) I TRIPS]"" S TRIPS=$A(TRIPS),TRIPS=TRIPS+1,TRIPS=$C(TRIPS) S DR="11////"_TRIPS_"" D ^DIE S F1=1 G BROW
    84         K TRIPS
    85 FIRST   ;Set 1st dup
    86         S DR="11////A" D ^DIE K DR,CNT
    87 BROW    S DA=SDA,NOPE=0,CNT=0
    88         F NIEN=0:0 S NIEN=$O(^PS(52.11,"BA",NAM,NIEN)) Q:'NIEN!(NIEN=$G(DA))  D  Q:NOPE
    89         . ;add check for bad xref and kill        *275
    90         . I '$D(^PS(52.11,NIEN,0)) K ^PS(52.11,"BA",NAM,NIEN) Q
    91         . D:$D(^PS(52.11,"BI")) BICK Q:CNT>0
    92         . D SETNEW
    93         Q
    94 SETNEW  S SSN1=$O(^PS(52.11,"BA",NAM,NIEN,0)),ADFN=$P(^PS(52.11,NIEN,0),"^"),CNT=1 I SSN1=SSN S NOPE=1 Q
    95         S DR="10////1" D ^DIE S F1=1 Q
    96 BICK    ;Chks "BI" Xref & assigns seq#
    97         S SSN1=$O(^PS(52.11,"BA",NAM,NIEN,0)) I SSN1=SSN&('$P($G(^PS(52.11,SDA,1)),"^",3)) S NOPE=1 Q
    98         S CNT=0 I $D(^PS(52.11,"BI",DFN)) S CNT=$O(^(DFN,0)),DA=SDA,DR="10////"_CNT_"" D ^DIE S F1=1 Q
    99         F NDFN=0:0 S NDFN=$O(^PS(52.11,"BI",NDFN)) Q:'NDFN  S CNT=$O(^(NDFN,0))+1
    100         S DR="10////"_CNT_"" D ^DIE S F1=1 Q
    101 NOTE    S DFN=$P($G(^PS(52.11,DA,0)),"^"),NFLAG=1 W !!,?5,"NAME",?30,"SSN",?45,"ID",?50,"ORDER"
    102         F Z=0:0 S Z=$O(^PS(52.11,"B",DFN,Z)) Q:'Z  S ZDA=Z S NODE=$G(^PS(52.11,ZDA,1)),Z1=$P(NODE,"^"),Z2=$P(NODE,"^",3),Z3=$P(NODE,"^",4),Z4=$P(NODE,"^",2) W:NODE'="" !,?5,Z1,?30,Z4,?46,Z2,?52,Z3
    103         W !! S DIR(0)="F,O",DIR("A")="Press return to add the last prescription or '^' to remove it."
    104         S DIR("A",1)="Please advise the patient that the above ID # or ORDER Letter",DIR("A",2)="or both will be displayed with his/her name on the Bingo Display",DIR("A",3)=" "
    105         D ^DIR K DIR K NODE,Z1,Z2,Z3 I $G(DTOUT)!(Y="^") S NFLAG=0 D REMOVE
    106         Q
    107 DIR     K DIR,X,Y S DIR(0)="Y",DIR("A")="Continue ",DIR("B")="N",DIR("?")="Answer YES to continue, NO to bypass"
    108         D ^DIR K DIR S:$D(DIRUT)!('Y) MWDIR=1 K DIRUT,DTOUT,DUOUT,X,Y
    109         Q
    110 HELP2   S (PA,PD)="",PL=0 F  S PA=$O(^PS(55,ADA,"P","A",PA)) Q:'PA  D:DT-1<PA
    111         .F  S PD=$O(^PS(55,ADA,"P","A",PA,PD)) Q:'PD  S PL=PL+1 W !,$P(^PSRX(PD,0),"^"),"      ",$P(^PSDRUG($P(^PSRX(PD,0),"^",6),0),"^")
    112         .I $G(PL)>15 N DIR S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR K DIR S PL=0
    113         Q
    114 HELP    W !,"Enter the patient's Rx number.",!
    115         Q
    116 ATICSET ;Set ATIC xref                                                PSO*232
    117         Q:'+$P(^PS(52.11,DA,0),"^",3)
    118         Q:'+$P(^PS(52.11,DA,0),"^",2)
    119         I $P(^PS(59.3,$P(^PS(52.11,DA,0),"^",3),0),"^",2)["T" D
    120         .S ^PS(52.11,"ATIC",+$P(^PS(52.11,DA,0),"^",3),+$P(^(0),"^",2),DA)=""
    121         Q
    122 ATICKIL ;Kill ATIC xref                                               PSO*232
    123         Q:'+$P(^PS(52.11,DA,0),"^",3)
    124         Q:'+$P(^PS(52.11,DA,0),"^",2)
    125         I $P(^PS(59.3,$P(^PS(52.11,DA,0),"^",3),0),"^",2)["T" D
    126         .K ^PS(52.11,"ATIC",+$P(^PS(52.11,DA,0),"^",3),+$P(^(0),"^",2),DA)
    127         Q
    128         ;
    129 END     K %,ADA,ADFN,ADV,CNT,DA,DATE,DFN,DINUM,DLAYGO,DR,DTOUT,DUOUT,F1,FLAG,FLAG1,FLGG,JOES,LAST,NAM,NDFN,NIEN,NFLAG,NODE,NOPE,NM
    130         K PSODRF,ODA,P,PSOAP,RX0,TM,TM1,SDA,SSN,SSN1,RX0,TIC,TICK,TFLAG,VADM,X,Y,Z,Z1,Z2,Z3,Z4,ZDA,ZZZ,PL,PD,PA
    131         Q
     1PSOBINGO ;BHAM ISC/LC - BINGO BOARD OPTION DRIVER ;1/18/06 9:09am
     2 ;;7.0;OUTPATIENT PHARMACY;**12,28,56,125,152,232,268**;DEC 1997;Build 9
     3 ;External Ref. to ^PS(55 is supp. by DBIA# 2228
     4 ;External Ref. to ^PSDRUG(, is supp. by DBIA# 221
     5 ;
     6 ;PSO*7*232 add ATIC xref set/kill code here
     7 ;
     8 S (FLAG,FLAG1)=0,(TRIPS,JOES,ADV,DGP)="" G:'$G(PSOAP) END D:'$D(PSOPAR) ^PSOLSET G:'$D(PSOPAR) END
     9BEG ;PSOAP=1 NEW ENTRY; 2=DISPLAY; 3=REMOVE
     10 D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) G:PSOAP=1 NEW I PSOAP=3 D BCRMV^PSOBING1 G:'$D(X) END
     11 I PSOAP=3 S DIC=52.11,DIC(0)="EMQZ",DIC("S")="I '$P($G(^PS(52.11,Y,0)),U,8)" D ^DIC K DIC G:+Y'>0 BEG G:($G(DTOUT))!($G(DUOUT)) END S DA=+Y,NAM=Y(0,0)
     12 I PSOAP=2 W !! K DIC,DIE,DLAYGO S (DIC,DIE)=52.11,DIC(0)="AEMQZ",DIC("A")="Enter Patient Name to Display: ",DIC("S")="I $P($G(^PS(52.11,Y,0)),U,4)=PSOSITE&'$P($G(^PS(52.11,Y,0)),U,7)"
     13 I PSOAP=2 D ^DIC K DIC G:+Y'>0!($G(DTOUT))!($G(DUOUT)) END S (DA,ODA)=+Y,NAM=Y(0,0)
     14 I PSOAP=3 D STUF,REMOVE1 G BEG
     15 I PSOAP=2,($P($G(^PS(52.11,DA,0)),"^",7)]"") W !!,NAM,"  is already in the display queue.",$C(7) G BEG
     16 I PSOAP=2,$P($P($G(^PS(52.11,DA,0)),"^",5),".")'=DT S Y=$P($P($G(^PS(52.11,DA,0)),"^",5),".") D DD^%DT W !!,$C(7),NAM," was entered on "_Y_".",!,"It can't be displayed and is now deleted." S DIK="^PS(52.11," D ^DIK K DIK G BEG
     17 I PSOAP=2&($P(^PS(52.11,ODA,0),"^",4)'=+PSOSITE) W !!,$C(7),NAM," was entered under the "_$P(^PS(59,$P(^(0),"^",4),0),"^")_" division." G BEG
     18 I PSOAP=2 S PSODRF=0 D CREF^PSOBING1 G:PSODRF BEG D  G BEG
     19 .S NM=$P(^DPT($P(^PS(52.11,ODA,0),"^"),0),"^"),DR="6////"_$E(TM1_"0000",1,4)_";8////"_NM_""
     20 .D PASS,SETUP S DA=ODA D STATS1^PSOBRPRT,WTIME^PSOBING1
     21NEW ;Init lookup
     22 W !! K DIC S DIC=2,DIC(0)="AEMQZ",DIC("A")="Enter Patient Name : " D ^DIC K DIC G:Y<0!($G(DUOUT))!($G(DTOUT)) END S (DA,ADA,DFN)=+Y D DEM^VADPT Q:VAERR  S NAM=VADM(1),SSN=$P(VADM(2),"^")
     23 K DD,DO S:$D(DISGROUP) DGP=$P($G(^PS(59.3,DISGROUP,0)),"^") S (DIC,DIE)="^PS(52.11,",X=ADA,DIC("DR")=$S($G(GROUPCNT)=1&($G(DISGROUP)):"2////"_DISGROUP_"",1:"2//^S X=DGP")
     24 S DIC(0)="LMNQZ",DLAYGO=59.3 D FILE^DICN K DD,DO,DIC G:Y'>0 NEW
     25 S JOES=$P(Y(0),"^",3),ADV=$P($G(^PS(59.3,JOES,0)),"^",2),DA=+Y
     26 I $G(DTOUT)!($G(DUOUT))!(X="") D WARN G NEW
     27TIC K TFLAG I ADV="T" S DIR(0)="NA^1:999999:0",DIR("A")="TICKET #:",DIR("?")="Ticket # must be numeric and unique" D ^DIR I $D(DUOUT)!($D(DTOUT))!($D(DIRUT)) D WARN G BEG
     28 S TFLAG=1 I PSOAP=1,$G(ADV)="T" W !! S TIC=+Y D
     29 .F TIEN=0:0 S TIEN=$O(^PS(52.11,"C",TIC,TIEN)) Q:'TIEN  I DA'=TIEN,($G(PSOSITE)=+$P(^PS(52.11,TIEN,0),"^",4)) D
     30 ..S TDFN=$P(^PS(52.11,TIEN,0),"^"),TSSN=$P(^PS(52.11,TIEN,1),"^",2),TFLAG=0 W !,$C(7),$P(^DPT(TDFN,0),"^")_" ("_TSSN_") was issued ticket # "_TIC,". Try again!",!
     31 .K TDFN,TIEN,TSSN Q:'TFLAG
     32 G:'TFLAG TIC I ADV="T" S DR="1////"_TIC_";3////"_PSOSITE_";4////"_TM_";5////"_$E(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////0",FLAG1=1 G PASS
     33 S DR="3////"_PSOSITE_";4////"_TM_";5////"_$E(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////0"
     34PASS S NFLAG=1 L +^PS(52.11,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) E  W !!,$C(7),Y(0,0)," is being edited!",! Q
     35 D ^DIE L -^PS(52.11,DA) I $G(DUOUT)!($G(DTOUT))!(X="") D WARN G BEG
     36 S:$G(PSOAP)=1 FLGG=0 G:$G(PSOAP)'=1 STRX1
     37STRX ;sto Rx #'s IN 52.11
     38 N BRXNUM,BBFTYP,BBFNUM,BBMW,MWDIR,II,FL,FLN,PR,PRN,PRNDT,FLNDT,Y
     39STRX0 S DIR(0)="FO^1:11",DIR("A")="Enter Rx #",DIR("?")="^D HELP^PSOBINGO",DIR("??")="^D HELP2^PSOBINGO" D ^DIR G:X=""&($G(FLGG)) STRX1 I $D(DIRUT) D WARN G BEG
     40 S DIC=52,DIC(0)="EQM",DIC("S")="I $P($G(^PSRX(Y,0)),U,2)=ADA" D ^DIC K DIC I $D(DUOUT)!($D(DTOUT)) D WARN G BEG
     41 G:Y=-1 STRX0
     42 I $G(Y)<0&('$G(FLGG)) D WARN G BEG
     43 I $G(Y)<0&($G(FLGG)) G STRX1
     44 S BRXNUM=$P(Y,"^")
     45 I $D(^PSRX(BRXNUM,1,0)) F II=0:0 S II=$O(^PSRX(BRXNUM,1,II)) Q:'II  S FLN=II
     46 I $D(FLN) S FLNDT=$P(^PSRX(BRXNUM,1,FLN,0),"^"),FL="F"
     47 I $D(^PSRX(BRXNUM,"P",0)) F II=0:0 S II=$O(^PSRX(BRXNUM,"P",II)) Q:'II  S PRN=II
     48 I $D(PRN) S PRNDT=$P(^PSRX(BRXNUM,"P",PRN,0),"^"),PR="P"
     49 S:$D(FLN)!($D(PRN)) BBFTYP=$S($G(PRNDT)>$G(FLNDT):PR,1:"F")
     50 I $G(BBFTYP)="P" S BBFNUM=PRN,BBMW=$P(^PSRX(BRXNUM,"P",PRN,0),"^",2)
     51 I $G(BBFTYP)="F" S BBFNUM=FLN,BBMW=$P(^PSRX(BRXNUM,1,FLN,0),"^",2)
     52 I '$D(BBFTYP) S BBFTYP="F",BBFNUM=0,BBMW=$P(^PSRX(BRXNUM,0),"^",11)
     53MW ;
     54 I $G(BBMW)="M" W !?5,$C(7),"Routing is set for Mail" D DIR
     55 I $D(MWDIR) K BRXNUM,BBFTYP,BBFNUM,BBMW,MWDIR,II,FL,FLN,PR,PRN,PRNDT,FLNDT,Y G STRX
     56 ;
     57 S X=BRXNUM,DIC("DR")="1////"_BBFTYP_";2////"_BBFNUM_"",DLAYGO=52.11
     58 S DA(1)=DA,DIC="^PS(52.11,"_DA(1)_",2,",DIC(0)="L",DIC("P")=$P(^DD(52.11,12,0),"^",2) K DD,DO D FILE^DICN K Y,DD,DO,X,BRXNUM,BBFTYP,BBFNUM,II,FL,PR,PRNDT,FLNDT S FLGG=1 G STRX
     59 ;
     60STRX1 D:PSOAP=1&($G(ADV)="N") CHKUP,NOTE G:'NFLAG BEG D STUF G:FLAG BEG Q:PSOAP=2
     61SETUP S ZZZ=0 I '$D(^PS(59.2,DT,0)) K DD,DIC,DO,DA S X=DT,DIC="^PS(59.2,",DIC(0)="",DINUM=X,DLAYGO=59.2 D FILE^DICN K DD,DO S ZZZ=1 Q:Y'>0
     62 I ZZZ=1 K DD,DO S DLAYGO=59.2,DA(1)=+Y,DIC=DIC_DA(1)_",1,",(DINUM,X)=PSOSITE,DIC(0)="",DIC("P")=$P(^DD(59.2,1,0),"^",2) D FILE^DICN K DD,DO,DIC,DA Q:Y'>0
     63 Q:PSOAP=2&($P($G(^PS(59.2,DT,1,PSOSITE,0)),"^"))  I ZZZ=0 K DD,DIC,DO,DA S DA(1)=DT,(DINUM,X)=PSOSITE,DIC="^PS(59.2,"_DT_",1,",DIC(0)="LZ",DLAYGO=59.2 D FILE^DICN K DD,DIC,DA,DO Q:PSOAP=2  G NEW
     64 G BEG
     65STUF S RX0=^PS(52.11,DA,0),JOES=$P(RX0,"^",4),TICK=$P($G(RX0),"^",2) Q:PSOAP=3  G:ADV="T"&($G(FLAG1)=1)&('$G(TICK)) WARN G:'$G(JOES)!($G(NAM)']"") WARN
     66 W:PSOAP=2 !!,"Patient added in display queue." W:PSOAP=1 !!,"Record is added." Q
     67WARN W !!!,$C(7),"Patient record incomplete!" S FLAG=1,DIK="^PS(52.11," D ^DIK G SHOW Q
     68REMOVE S DIK="^PS(52.11," D ^DIK
     69SHOW K DIK,DA,ADA W !!,"Record is removed."
     70 Q
     71REMOVE1 ;
     72 Q:'$D(^PS(52.11,"ANAM",$P(^PS(52.11,DA,0),"^",3),$P(^(1),"^",3)_$P(^(1),"^",4)_" "_$P(^DPT(+$P(^PS(52.11,DA,0),"^"),0),"^"),DA))
     73 N DIE,DR I $D(^PS(52.11,"ANAM",$P(^PS(52.11,DA,0),"^",3),$P(^(1),"^",3)_$P(^(1),"^",4)_" "_$P(^DPT(+$P(^PS(52.11,DA,0),"^"),0),"^"),DA)) S DIE="^PS(52.11,",DR="7////1" D
     74 .D ^DIE
     75 .K ^PS(52.11,"ANAM",$P(^PS(52.11,DA,0),"^",3),$P(^(1),"^",3)_$P(^(1),"^",4)_" "_$P(^DPT(+$P(^PS(52.11,DA,0),"^"),0),"^"),DA)
     76 I $D(^PS(52.11,"ATIC",+$P(^PS(52.11,DA,0),"^",3),+$P(^(0),"^",2),DA)) S DIE="^PS(52.11,",DR="7////1" D
     77 .D ^DIE
     78 .K ^PS(52.11,"ATIC",+$P(^PS(52.11,DA,0),"^",3),+$P(^(0),"^",2),DA)
     79 Q
     80CHKUP ;Multi & dupe names
     81 S SDA=DA S:'$D(DFN) DFN=PSODFN G:$O(^PS(52.11,"B",DFN,0))=DA BROW F P=0:0 S P=$O(^PS(52.11,"B",DFN,P)) Q:'P!(P=DA)  S LAST=P
     82 Q:'$G(LAST)  S TRIPS=$P($G(^PS(52.11,LAST,1)),"^",4) I TRIPS]"" S TRIPS=$A(TRIPS),TRIPS=TRIPS+1,TRIPS=$C(TRIPS) S DR="11////"_TRIPS_"" D ^DIE S F1=1 G BROW
     83 K TRIPS
     84FIRST ;Set 1st dup
     85 S DR="11////A" D ^DIE K DR,CNT
     86BROW S DA=SDA,NOPE=0,CNT=0 F NIEN=0:0 S NIEN=$O(^PS(52.11,"BA",NAM,NIEN)) Q:'NIEN!(NIEN=$G(DA))  D:$D(^PS(52.11,"BI")) BICK Q:CNT>0  D SETNEW Q:NOPE
     87 Q
     88SETNEW S SSN1=$O(^PS(52.11,"BA",NAM,NIEN,0)),ADFN=$P(^PS(52.11,NIEN,0),"^"),CNT=1 I SSN1=SSN S NOPE=1 Q
     89 S DR="10////1" D ^DIE S F1=1 Q
     90BICK ;Chks "BI" Xref & assigns seq#
     91 S SSN1=$O(^PS(52.11,"BA",NAM,NIEN,0)) I SSN1=SSN&('$P($G(^PS(52.11,SDA,1)),"^",3)) S NOPE=1 Q
     92 S CNT=0 I $D(^PS(52.11,"BI",DFN)) S CNT=$O(^(DFN,0)),DA=SDA,DR="10////"_CNT_"" D ^DIE S F1=1 Q
     93 F NDFN=0:0 S NDFN=$O(^PS(52.11,"BI",NDFN)) Q:'NDFN  S CNT=$O(^(NDFN,0))+1
     94 S DR="10////"_CNT_"" D ^DIE S F1=1 Q
     95NOTE S DFN=$P($G(^PS(52.11,DA,0)),"^"),NFLAG=1 W !!,?5,"NAME",?30,"SSN",?45,"ID",?50,"ORDER"
     96 F Z=0:0 S Z=$O(^PS(52.11,"B",DFN,Z)) Q:'Z  S ZDA=Z S NODE=$G(^PS(52.11,ZDA,1)),Z1=$P(NODE,"^"),Z2=$P(NODE,"^",3),Z3=$P(NODE,"^",4),Z4=$P(NODE,"^",2) W:NODE'="" !,?5,Z1,?30,Z4,?46,Z2,?52,Z3
     97 W !! S DIR(0)="F,O",DIR("A")="Press return to add the last prescription or '^' to remove it."
     98 S DIR("A",1)="Please advise the patient that the above ID # or ORDER Letter",DIR("A",2)="or both will be displayed with his/her name on the Bingo Display",DIR("A",3)=" "
     99 D ^DIR K DIR K NODE,Z1,Z2,Z3 I $G(DTOUT)!(Y="^") S NFLAG=0 D REMOVE
     100 Q
     101DIR K DIR,X,Y S DIR(0)="Y",DIR("A")="Continue ",DIR("B")="N",DIR("?")="Answer YES to continue, NO to bypass"
     102 D ^DIR K DIR S:$D(DIRUT)!('Y) MWDIR=1 K DIRUT,DTOUT,DUOUT,X,Y
     103 Q
     104HELP2 S (PA,PD)="",PL=0 F  S PA=$O(^PS(55,ADA,"P","A",PA)) Q:'PA  D:DT-1<PA
     105 .F  S PD=$O(^PS(55,ADA,"P","A",PA,PD)) Q:'PD  S PL=PL+1 W !,$P(^PSRX(PD,0),"^"),"      ",$P(^PSDRUG($P(^PSRX(PD,0),"^",6),0),"^")
     106 .I $G(PL)>15 N DIR S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR K DIR S PL=0
     107 Q
     108HELP W !,"Enter the patient's Rx number.",!
     109 Q
     110ATICSET ;Set ATIC xref                                                PSO*232
     111 Q:'+$P(^PS(52.11,DA,0),"^",3)
     112 Q:'+$P(^PS(52.11,DA,0),"^",2)
     113 I $P(^PS(59.3,$P(^PS(52.11,DA,0),"^",3),0),"^",2)["T" D
     114 .S ^PS(52.11,"ATIC",+$P(^PS(52.11,DA,0),"^",3),+$P(^(0),"^",2),DA)=""
     115 Q
     116ATICKIL ;Kill ATIC xref                                               PSO*232
     117 Q:'+$P(^PS(52.11,DA,0),"^",3)
     118 Q:'+$P(^PS(52.11,DA,0),"^",2)
     119 I $P(^PS(59.3,$P(^PS(52.11,DA,0),"^",3),0),"^",2)["T" D
     120 .K ^PS(52.11,"ATIC",+$P(^PS(52.11,DA,0),"^",3),+$P(^(0),"^",2),DA)
     121 Q
     122 ;
     123END K %,ADA,ADFN,ADV,CNT,DA,DATE,DFN,DINUM,DLAYGO,DR,DTOUT,DUOUT,F1,FLAG,FLAG1,FLGG,JOES,LAST,NAM,NDFN,NIEN,NFLAG,NODE,NOPE,NM
     124 K PSODRF,ODA,P,PSOAP,RX0,TM,TM1,SDA,SSN,SSN1,RX0,TIC,TICK,TFLAG,VADM,X,Y,Z,Z1,Z2,Z3,Z4,ZDA,ZZZ,PL,PD,PA
     125 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBPSU1.m

    r613 r623  
    1 PSOBPSU1        ;BIRM/MFR - BPS (ECME) Utilities 1 ;10/15/04
    2         ;;7.0;OUTPATIENT PHARMACY;**148,260,281**;DEC 1997;Build 41
    3         ;Reference to $$EN^BPSNCPDP supported by IA 4415
    4         ;References to $$NDCFMT^PSSNDCUT,$$GETNDC^PSSNDCUT supported by IA 4707
    5         ;References to $$ECMEON^BPSUTIL,$$CMOPON^BPSUTIL supported by IA 4410
    6         ;References to STORESP^IBNCPDP supported by IA 4299
    7         ;
    8 ECMESND(RX,RFL,DATE,FROM,NDC,CMOP,RVTX,OVRC,CNDC,RESP,IGSW,ALTX,CLA,PA) ; - Sends Rx Release information to ECME/IB and
    9         ;                                                       updates NDC in the DRUG/PRESCRIPTION files
    10         ;Reference to routine EN^BPSNCPDP supported by DBIA #4304
    11         ;Input: (r) RX   - Rx IEN (#52)
    12         ;       (o) RFL  - Refill #  (Default: most recent)
    13         ;       (r) DATE - Date of Service
    14         ;       (r) FROM - Function within OP (See BWHERE param. in EN^BPSNCPDP api)
    15         ;       (o) NDC  - NDC Number (If not passed, will be retrieved from DRUG file)
    16         ;       (o) CMOP - CMOP Prescription (1-YES/0-NO) (Default: 0)
    17         ;       (o) RVTX - REVERSE text (e.g., RX EDIT, RX RELEASE-NDC CHANGE, etc)
    18         ;       (o) OVRC - Set of 3 NCPDP override codes separated by "^":
    19         ;                  Piece 1: NCPDP Professional Service Code for overriding DUR REJECTS
    20         ;                  Piece 2: NCPDP Reason for Service Code for overriding DUR REJECTS
    21         ;                  Piece 3: NCPDP Result of Service Code for overriding DUR REJECTS
    22         ;       (o) CNDC - Changed NDC? 1 - Yes / 0 - No (Default: NO)
    23         ;       (o) IGSW - Ignore Switches (Master and CMOP)? 1 - Yes / 0 - No (Default: NO)
    24         ;       (o) ALTX - Alternative Text to be placed in the Rx ECME Activity Log
    25         ;       (o) CLA  - NCPDP Clarification Code for overriding DUR/RTS REJECTS
    26         ;       (o) PA   - NCPDP Prior Authorization Type and Number (separated by "^")
    27         ;Output:    RESP - Response from $$EN^BPSNCPDP api
    28         ;
    29         ; - Retrieving the NDC code from the DRUG file if not passed in, then save it in the DRUG file
    30         N ACT,NDCACT,DA
    31         ;
    32         I '$D(RFL) S RFL=$$LSTRFL(RX)
    33         ;
    34         ; - ECME is not turned ON for the Rx's Division
    35         I '$G(IGSW),'$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RFL)) S RESP="-1^ECME SWITCH OFF" Q
    36         ;
    37         ; - ECME CMOP is not turned ON for the Rx's Division
    38         I '$G(IGSW),$G(CMOP),'$$CMOPON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RFL)) S RESP="-1^CMOP SWITCH OFF" Q
    39         ;
    40         ; - Saving the NDC to be displayed on the ECME Activity Log
    41         I $G(CNDC) D
    42         . I $G(NDC)'="" S NDCACT=NDC Q
    43         . S NDCACT=$$GETNDC^PSONDCUT(RX,RFL)
    44         ;
    45         I $$NDCFMT^PSSNDCUT($G(NDC))="" D
    46         . S NDC=$$GETNDC^PSSNDCUT($$GET1^DIQ(52,RX,6,"I"),$$RXSITE^PSOBPSUT(RX,RFL),+$G(CMOP))
    47         . I $G(NDC)'="" D SAVNDC^PSONDCUT(RX,RFL,NDC,+$G(CMOP),1)
    48         ;
    49         ; - Creating ECME Activity Log on the PRESCRIPTION file
    50         S ACT="Submitted" I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" S ACT="Reversal/Re-submit sent"
    51         S ACT=ACT_" to ECME:"
    52         ;
    53         ; - Marked any 'unresolved' REJECTS as 'resolved' (Reason: 1 - Claim re-submitted)
    54         N CLSCOM,COD1,COD2,COD3
    55         S COD2=$P($G(OVRC),"^"),COD1=$P($G(OVRC),"^",2),COD3=$P($G(OVRC),"^",3)
    56         I $G(COD3)'="" S CLSCOM="DUR Override Codes "_COD1_"/"_COD2_"/"_COD3_" submitted."
    57         I $G(CLA)'="" S CLSCOM="Clarification Code "_CLA_" submitted."
    58         I $G(PA)'="" S CLSCOM="Prior Authorization Code ("_$P(PA,"^")_"/"_$P(PA,"^",2)_") submitted."
    59         D CLSALL^PSOREJUT(RX,RFL,DUZ,1,$G(CLSCOM),$G(COD1),$G(COD2),$G(COD3),$G(CLA),$G(PA))
    60         ;
    61         ; - Call to ECME (NEWing STAT because ECME was overwriting it - Important variable for CMOP release PSXVND)
    62         N STAT
    63         I $G(RVTX)="",FROM="ED" S RVTX="RX EDITED"
    64         S RESP=$$EN^BPSNCPDP(RX,RFL,$$DOS(RX,RFL,.DATE),FROM,NDC,$G(RVTX),$G(OVRC),,$G(CLA),$G(PA))
    65         I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" D SAVNDC^PSONDCUT(RX,RFL,NDC,+$G(CMOP),1)
    66         ;
    67         ; - Reseting the Re-transmission flag
    68         D RETRXF^PSOREJU2(RX,RFL,0)
    69         ;
    70         ; - Logging ECME Activity Log to the PRESCRIPTION file
    71         I $G(ALTX)="" D
    72         . N X,ROUTE S (ROUTE,X)=""
    73         . S ROUTE=$S(FROM="RF":$$GET1^DIQ(52.1,RFL_","_RX_",",2),FROM="OF":$$GET1^DIQ(52,RX_",",11),1:"")
    74         . S:FROM="OF" X=ROUTE_" FILL(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
    75         . S:FROM="RF" X=ROUTE_" REFILL(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
    76         . S:FROM="RN" X="RX RENEWED(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
    77         . S:FROM="PL" X="PRINTED FROM SUSPENSE(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
    78         . S:FROM="PE"!(FROM="PP") X="PULLED FROM SUSPENSE(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
    79         . S:FROM="PC" X="CMOP TRANSMISSION(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
    80         . S:FROM="RRL" X="RELEASED RX PREVIOUSLY REVERSED"
    81         . S:FROM="ED" X="RX EDITED"
    82         . S:$G(RVTX)'="" X=RVTX
    83         . S:$G(OVRC)'="" X="DUR OVERRIDE CODES("_$G(COD1)_"/"_$G(COD2)_"/"_$G(COD3)_")"
    84         . S:$G(CNDC) X=X_"(NDC:"_NDCACT_")" S ACT=ACT_X
    85         . S ACT=ACT_$$STS(RX,RFL,RESP)
    86         I $G(ALTX)'="" S ACT=ACT_ALTX_$$STS(RX,RFL,RESP)
    87         I +RESP=2 S ACT="Not ECME Billable: "_$P(RESP,"^",2)
    88         I +RESP=10 S ACT="ECME reversed/NOT re-submitted: "_$P(RESP,"^",2)
    89         D RXACT^PSOBPSU2(RX,RFL,ACT,"M",DUZ)
    90         ;
    91         ; -Logs an ECME Activity Log if Rx Quantity is different than Billing Quantity
    92         I 'RESP,$T(NCPDPQTY^PSSBPSUT)'="" D
    93         . N DRUG,RXQTY,BLQTY,BLDU,Z
    94         . S DRUG=$$GET1^DIQ(52,RX,6,"I")
    95         . S RXQTY=$S('RFL:$$GET1^DIQ(52,RX,7,"I"),1:$$GET1^DIQ(52.1,RFL_","_RX,1))/1
    96         . S Z=$$NCPDPQTY^PSSBPSUT(DRUG,RXQTY),BLQTY=Z/1,BLDU=$P(Z,"^",2)
    97         . I RXQTY'=BLQTY D
    98         . . D RXACT^PSOBPSU2(RX,RFL,"BILLING QUANTITY submitted: "_$J(BLQTY,0,$L($P(BLQTY,".",2)))_" ("_BLDU_")","M",DUZ)
    99         ;
    100         Q
    101         ;
    102 REVERSE(RX,RFL,FROM,RSN,RTXT,IGRL,NDC)  ; - Reverse a claim and close all OPEN/UNRESOLVED Rejects
    103         ;Input: (r) RX   - Rx IEN (#52)
    104         ;       (o) RFL  - Refill #  (Default: most recent)
    105         ;       (r) FROM - Function within OP (See BWHERE param. in EN^BPSNCPDP api)
    106         ;       (o) RSN  - Close Reason (2:RX ON HOLD;4: RX RETURNED TO STOCK,5:RX DELETED,etc...)
    107         ;       (o) RTXT - Close Reason TEXT (Usually no passed if RSN is passed)
    108         ;       (o) IGRL - Ignore RELEASE DATE, reverse anyway 
    109         ;       (o) NDC  - NDC number related to the reversal (Note: might be an invalid NDC)
    110         ;
    111         I '$D(RFL) S RFL=$$LSTRFL(RX)
    112         ;
    113         I $$STATUS^PSOBPSUT(RX,RFL)="" Q
    114         ;
    115         N RESP,STS,ACT,STAT,DA,STATUS,NOACT S RSN=+$G(RSN),RTXT=$G(RTXT)
    116         I RTXT="",RSN D
    117         . S:RSN=2 RTXT="RX PLACED ON HOLD" S:RSN=3 RTXT="RX SUSPENDED" S:RSN=4 RTXT="RX RETURNED TO STOCK"
    118         . S:RSN=5 RTXT="RX DELETED" S:RSN=7 RTXT="RX DISCONTINUED" S:RSN=8 RTXT="RX EDITED"
    119         ;
    120         D CLSALL^PSOREJUT(RX,RFL,DUZ,RSN,RTXT)
    121         ;
    122         I '$G(IGRL),$$RXRLDT^PSOBPSUT(RX,RFL) Q
    123         ;
    124         ; - Reseting the Re-transmission flag if Rx is being suspended
    125         I RSN=3!($$GET1^DIQ(52,RX,100,"I")=5) D RETRXF^PSOREJU2(RX,RFL,1)
    126         ;
    127         S STATUS=$$STATUS^PSOBPSUT(RX,RFL),NOACT=0
    128         I STATUS'="E PAYABLE",STATUS'="IN PROGRESS",STATUS'="E REVERSAL REJECTED",STATUS'="E REVERSAL STRANDED",STATUS'="E DUPLICATE" S NOACT=1
    129         ;
    130         S RESP=$$EN^BPSNCPDP(RX,RFL,$$DOS(RX,RFL),FROM,$$GETNDC^PSONDCUT(RX,RFL),RTXT)
    131         ;
    132         ; - Logging ECME Activity Log
    133         I '$G(NOACT) D
    134         . S ACT="Reversal sent to ECME: "_RTXT_$S($G(NDC)'="":" ("_NDC_")",1:"")_$$STS(RX,RFL,+RESP)
    135         . D RXACT^PSOBPSU2(RX,RFL,ACT,"M",DUZ)
    136         ;
    137         Q
    138         ;
    139 DOS(RX,RFL,DATE)        ; Return the Date Of Service for ECME
    140         ;Input: (r) RX   - Rx IEN (#52)
    141         ;       (o) RFL  - Refill #  (Default: most recent)
    142         ;       (o) DATE - Possible Date Of Service
    143         ;Output:    DOS  - Actual Date Of Service
    144         ;
    145         I '$D(RFL) S RFL=$$LSTRFL(RX)
    146         ;
    147         ; - Retrieving FILL DATE from the PRESCRIPTION file if not passed
    148         I $G(DATE)="" S DATE=$$RXRLDT^PSOBPSUT(RX,RFL)
    149         ; - Retrieving FILL DATE from the PRESCRIPTION file if not passed
    150         I 'DATE S DATE=$$RXFLDT^PSOBPSUT(RX,RFL)
    151         ; - Future Date not allowed
    152         I DATE>DT!'DATE S DATE=DT
    153         ;
    154         Q (DATE\1)
    155         ;
    156 RELEASE(RX,RFL,USR)     ; - Notifies IB that the Rx was RELEASED
    157         ;Input: (r) RX   - Rx IEN (#52)
    158         ;       (o) RFL  - Refill #  (Default: most recent)
    159         ;       (o) USR  - User responsible for releasing the Rx (Default: .5 - Postmaster)
    160         ;
    161         N IBAR,RXAR,FLDT,RFAR
    162         ;
    163         S:'$D(RFL) RFL=$$LSTRFL(RX)
    164         S:'$D(USR) USR=.5
    165         ;
    166         D GETS^DIQ(52,RX_",",".01;2;6;7;8;22","I","RXAR")
    167         S DFN=+$G(RXAR(52,RX_",",2,"I"))
    168         S IBAR("PRESCRIPTION")=RX,IBAR("RX NO")=$G(RXAR(52,RX_",",.01,"I"))
    169         S IBAR("CLAIMID")=$E((RX#10000000)+10000000,2,8),IBAR("USER")=USR
    170         S IBAR("DRUG")=RXAR(52,RX_",",6,"I"),IBAR("NDC")=$$GETNDC^PSONDCUT(RX,RFL)
    171         S FLDT=$$RXFLDT^PSOBPSUT(RX,RFL) I FLDT>DT S FLDT=DT
    172         S IBAR("FILL NUMBER")=RFL,IBAR("FILL DATE")=FLDT
    173         S IBAR("QTY")=$G(RXAR(52,RX_",",7,"I")),IBAR("DAYS SUPPLY")=$G(RXAR(52,RX_",",8,"I"))
    174         ;
    175         I RFL D
    176         . D GETS^DIQ(52.1,RFL_","_RX_",",".01;1;1.1","I","RFAR")
    177         . S IBAR("QTY")=$G(RFAR(52.1,RFL_","_RX_",",1,"I"))
    178         . S IBAR("DAYS SUPPLY")=$G(RFAR(52.1,RFL_","_RX_",",1.1,"I"))
    179         ;
    180         S IBAR("STATUS")="RELEASED" D STORESP^IBNCPDP(DFN,.IBAR)
    181         ;
    182         Q
    183         ;
    184 LSTRFL(RX)      ;  - Returns the latest fill for the Prescription
    185         ; Input: (r) RX     - Rx IEN (#52)
    186         ;Output:     LSTRFL - Most recent refill #
    187         N I,LSTRFL
    188         S (I,LSTRFL)=0 F  S I=$O(^PSRX(RX,1,I)) Q:'I  S LSTRFL=I
    189         Q LSTRFL
    190         ;
    191 ECMEACT(RX,RFL,COMM,USR)        ; - Add an Activity to the ECME Activity Log (PRESCRIPTION file)
    192         ;Input: (r) RX   - Rx IEN (#52)
    193         ;       (o) RFL  - Refill #  (Default: most recent)
    194         ;       (r) COMM - Comments (up to 75 characters)
    195         ;       (o) USR  - User logging the comments (Default: DUZ)
    196         ;
    197         S:'$D(RFL) RFL=$$LSTRFL^PSOBPSU1(RX)
    198         D RXACT^PSOBPSU2(RX,RFL,COMM,"M",+$G(USR))
    199         Q
    200         ;
    201 STS(RX,RFL,RSP) ; Adds the Status to the ECME Activity Log according to Rx/fill claim status Response
    202         N STS
    203         S STS=$S($$STATUS^PSOBPSUT(RX,RFL)'="IN PROGRESS"&($$STATUS^PSOBPSUT(RX,RFL)'=""):"-"_$$STATUS^PSOBPSUT(RX,RFL),1:"")
    204         S:+RSP=1 STS="-NO SUBMISSION THROUGH ECME" S:+RSP=3 STS="-NO REVERSAL NEEDED" S:+RSP=4 STS="-NOT PROCESSED"
    205         S:+RSP=5 STS="-SOFTWARE ERROR"
    206         I +RSP=2,$$STATUS^PSOBPSUT(RX,RFL)'="" S STS="-NOT BILLABLE:"_$P(RSP,"^",2)
    207         Q STS
     1PSOBPSU1 ;BIRM/MFR - BPS (ECME) Utilities 1 ;10/15/04
     2 ;;7.0;OUTPATIENT PHARMACY;**148,260**;DEC 1997;Build 84
     3 ;Reference to $$EN^BPSNCPDP supported by IA 4415
     4 ;References to $$NDCFMT^PSSNDCUT,$$GETNDC^PSSNDCUT supported by IA 4707
     5 ;References to $$ECMEON^BPSUTIL,$$CMOPON^BPSUTIL supported by IA 4410
     6 ;References to STORESP^IBNCPDP supported by IA 4299
     7 ;
     8ECMESND(RX,RFL,DATE,FROM,NDC,CMOP,RVTX,OVRC,CNDC,RESP,IGSW,ALTX,CLA,PA) ; - Sends Rx Release information to ECME/IB and
     9 ;                                                       updates NDC in the DRUG/PRESCRIPTION files
     10 ;Reference to routine EN^BPSNCPDP supported by DBIA #4304
     11 ;Input: (r) RX   - Rx IEN (#52)
     12 ;       (o) RFL  - Refill #  (Default: most recent)
     13 ;       (r) DATE - Date of Service
     14 ;       (r) FROM - Function within OP (See BWHERE param. in EN^BPSNCPDP api)
     15 ;       (o) NDC  - NDC Number (If not passed, will be retrieved from DRUG file)
     16 ;       (o) CMOP - CMOP Prescription (1-YES/0-NO) (Default: 0)
     17 ;       (o) RVTX - REVERSE text (e.g., RX EDIT, RX RELEASE-NDC CHANGE, etc)
     18 ;       (o) OVRC - Set of 3 NCPDP override codes separated by "^":
     19 ;                  Piece 1: NCPDP Professional Service Code for overriding DUR REJECTS
     20 ;                  Piece 2: NCPDP Reason for Service Code for overriding DUR REJECTS
     21 ;                  Piece 3: NCPDP Result of Service Code for overriding DUR REJECTS
     22 ;       (o) CNDC - Changed NDC? 1 - Yes / 0 - No (Default: NO)
     23 ;       (o) IGSW - Ignore Switches (Master and CMOP)? 1 - Yes / 0 - No (Default: NO)
     24 ;       (o) ALTX - Alternative Text to be placed in the Rx ECME Activity Log
     25 ;       (o) CLA  - NCPDP Clarification Code for overriding DUR/RTS REJECTS
     26 ;       (o) PA   - NCPDP Prior Authorization Type and Number (separated by "^")
     27 ;Output:    RESP - Response from $$EN^BPSNCPDP api
     28 ;
     29 ; - Retrieving the NDC code from the DRUG file if not passed in, then save it in the DRUG file
     30 N ACT,NDCACT,DA
     31 ;
     32 I '$D(RFL) S RFL=$$LSTRFL(RX)
     33 ;
     34 ; - ECME is not turned ON for the Rx's Division
     35 I '$G(IGSW),'$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RFL)) S RESP="-1^ECME SWITCH OFF" Q
     36 ;
     37 ; - ECME CMOP is not turned ON for the Rx's Division
     38 I '$G(IGSW),$G(CMOP),'$$CMOPON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RFL)) S RESP="-1^CMOP SWITCH OFF" Q
     39 ;
     40 ; - Saving the NDC to be displayed on the ECME Activity Log
     41 I $G(CNDC) D
     42 . I $G(NDC)'="" S NDCACT=NDC Q
     43 . S NDCACT=$$GETNDC^PSONDCUT(RX,RFL)
     44 ;
     45 I $$NDCFMT^PSSNDCUT($G(NDC))="" D
     46 . S NDC=$$GETNDC^PSSNDCUT($$GET1^DIQ(52,RX,6,"I"),$$RXSITE^PSOBPSUT(RX,RFL),+$G(CMOP))
     47 . I $G(NDC)'="" D SAVNDC^PSONDCUT(RX,RFL,NDC,+$G(CMOP))
     48 ;
     49 ; - Creating ECME Activity Log on the PRESCRIPTION file
     50 S ACT="Submitted" I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" S ACT="Reversal/Re-submit sent"
     51 S ACT=ACT_" to ECME:"
     52 ;
     53 ; - Marked any 'unresolved' REJECTS as 'resolved' (Reason: 1 - Claim re-submitted)
     54 N CLSCOM,COD1,COD2,COD3
     55 S COD2=$P($G(OVRC),"^"),COD1=$P($G(OVRC),"^",2),COD3=$P($G(OVRC),"^",3)
     56 I $G(COD3)'="" S CLSCOM="DUR Override Codes "_COD1_"/"_COD2_"/"_COD3_" submitted."
     57 I $G(CLA)'="" S CLSCOM="Clarification Code "_CLA_" submitted."
     58 I $G(PA)'="" S CLSCOM="Prior Authorization Code ("_$P(PA,"^")_"/"_$P(PA,"^",2)_") submitted."
     59 D CLSALL^PSOREJUT(RX,RFL,DUZ,1,$G(CLSCOM),$G(COD1),$G(COD2),$G(COD3),$G(CLA),$G(PA))
     60 ;
     61 ; - Call to ECME (NEWing STAT because ECME was overwriting it - Important variable for CMOP release PSXVND)
     62 N STAT
     63 I $G(RVTX)="",FROM="ED" S RVTX="RX EDITED"
     64 S RESP=$$EN^BPSNCPDP(RX,RFL,$$DOS(RX,RFL,.DATE),FROM,NDC,$G(RVTX),$G(OVRC),,$G(CLA),$G(PA))
     65 ;
     66 ; - Reseting the Re-transmission flag
     67 D RETRXF^PSOREJU2(RX,RFL,0)
     68 ;
     69 ; - Logging ECME Activity Log to the PRESCRIPTION file
     70 I $G(ALTX)="" D
     71 . N X S X=""
     72 . S:FROM="OF" X="WINDOW FILL(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
     73 . S:FROM="RF" X="WINDOW REFILL(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
     74 . S:FROM="RN" X="RX RENEWED(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
     75 . S:FROM="PL" X="SUSP LABEL PRINTED(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
     76 . S:FROM="PE"!(FROM="PP") X="PULLED FROM SUSPENSE(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
     77 . S:FROM="PC" X="CMOP TRANSMISSION(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
     78 . S:FROM="RRL" X="RELEASED RX PREVIOUSLY REVERSED"
     79 . S:FROM="ED" X="RX EDITED"
     80 . S:$G(RVTX)'="" X=RVTX
     81 . S:$G(OVRC)'="" X="DUR OVERRIDE CODES("_$G(COD1)_"/"_$G(COD2)_"/"_$G(COD3)_")"
     82 . S:$G(CNDC) X=X_"(NDC:"_NDCACT_")" S ACT=ACT_X
     83 . S ACT=ACT_$$STS(RX,RFL,RESP)
     84 I $G(ALTX)'="" S ACT=ACT_ALTX_$$STS(RX,RFL,RESP)
     85 I +RESP=2 S ACT="Not ECME Billable: "_$P(RESP,"^",2)
     86 I +RESP=10 S ACT="ECME reversed/NOT re-submitted: "_$P(RESP,"^",2)
     87 D RXACT^PSOBPSU2(RX,RFL,ACT,"M",DUZ)
     88 ;
     89 ; -Logs an ECME Activity Log if Rx Quantity is different than Billing Quantity
     90 I 'RESP,$T(NCPDPQTY^PSSBPSUT)'="" D
     91 . N DRUG,RXQTY,BLQTY,BLDU,Z
     92 . S DRUG=$$GET1^DIQ(52,RX,6,"I")
     93 . S RXQTY=$S('RFL:$$GET1^DIQ(52,RX,7,"I"),1:$$GET1^DIQ(52.1,RFL_","_RX,1))/1
     94 . S Z=$$NCPDPQTY^PSSBPSUT(DRUG,RXQTY),BLQTY=Z/1,BLDU=$P(Z,"^",2)
     95 . I RXQTY'=BLQTY D
     96 . . D RXACT^PSOBPSU2(RX,RFL,"BILLING QUANTITY submitted: "_$J(BLQTY,0,$L($P(BLQTY,".",2)))_" ("_BLDU_")","M",DUZ)
     97 ;
     98 Q
     99 ;
     100REVERSE(RX,RFL,FROM,RSN,RTXT,IGRL,NDC) ; - Reverse a claim and close all OPEN/UNRESOLVED Rejects
     101 ;Input: (r) RX   - Rx IEN (#52)
     102 ;       (o) RFL  - Refill #  (Default: most recent)
     103 ;       (r) FROM - Function within OP (See BWHERE param. in EN^BPSNCPDP api)
     104 ;       (o) RSN  - Close Reason (2:RX ON HOLD;4: RX RETURNED TO STOCK,5:RX DELETED,etc...)
     105 ;       (o) RTXT - Close Reason TEXT (Usually no passed if RSN is passed)
     106 ;       (o) IGRL - Ignore RELEASE DATE, reverse anyway 
     107 ;       (o) NDC  - NDC number related to the reversal (Note: might be an invalid NDC)
     108 ;
     109 I '$D(RFL) S RFL=$$LSTRFL(RX)
     110 ;
     111 I $$STATUS^PSOBPSUT(RX,RFL)="" Q
     112 ;
     113 N RESP,STS,ACT,STAT,DA,STATUS,NOACT S RSN=+$G(RSN),RTXT=$G(RTXT)
     114 I RTXT="",RSN D
     115 . S:RSN=2 RTXT="RX PLACED ON HOLD" S:RSN=3 RTXT="RX SUSPENDED" S:RSN=4 RTXT="RX RETURNED TO STOCK"
     116 . S:RSN=5 RTXT="RX DELETED" S:RSN=7 RTXT="RX DISCONTINUED" S:RSN=8 RTXT="RX EDITED"
     117 ;
     118 D CLSALL^PSOREJUT(RX,RFL,DUZ,RSN,RTXT)
     119 ;
     120 I '$G(IGRL),$$RXRLDT^PSOBPSUT(RX,RFL) Q
     121 ;
     122 ; - Reseting the Re-transmission flag if Rx is being suspended
     123 I RSN=3!($$GET1^DIQ(52,RX,100,"I")=5) D RETRXF^PSOREJU2(RX,RFL,1)
     124 ;
     125 S STATUS=$$STATUS^PSOBPSUT(RX,RFL),NOACT=0
     126 I STATUS'="E PAYABLE",STATUS'="IN PROGRESS",STATUS'="E REVERSAL REJECTED",STATUS'="E REVERSAL STRANDED",STATUS'="E DUPLICATE" S NOACT=1
     127 ;
     128 S RESP=$$EN^BPSNCPDP(RX,RFL,$$DOS(RX,RFL),FROM,$$GETNDC^PSONDCUT(RX,RFL),RTXT)
     129 ;
     130 ; - Logging ECME Activity Log
     131 I '$G(NOACT) D
     132 . S ACT="Reversal sent to ECME: "_RTXT_$S($G(NDC)'="":" ("_NDC_")",1:"")_$$STS(RX,RFL,+RESP)
     133 . D RXACT^PSOBPSU2(RX,RFL,ACT,"M",DUZ)
     134 ;
     135 Q
     136 ;
     137DOS(RX,RFL,DATE) ; Return the Date Of Service for ECME
     138 ;Input: (r) RX   - Rx IEN (#52)
     139 ;       (o) RFL  - Refill #  (Default: most recent)
     140 ;       (o) DATE - Possible Date Of Service
     141 ;Output:    DOS  - Actual Date Of Service
     142 ;
     143 I '$D(RFL) S RFL=$$LSTRFL(RX)
     144 ;
     145 ; - Retrieving FILL DATE from the PRESCRIPTION file if not passed
     146 I $G(DATE)="" S DATE=$$RXRLDT^PSOBPSUT(RX,RFL)
     147 ; - Retrieving FILL DATE from the PRESCRIPTION file if not passed
     148 I 'DATE S DATE=$$RXFLDT^PSOBPSUT(RX,RFL)
     149 ; - Future Date not allowed
     150 I DATE>DT!'DATE S DATE=DT
     151 ;
     152 Q (DATE\1)
     153 ;
     154RELEASE(RX,RFL,USR) ; - Notifies IB that the Rx was RELEASED
     155 ;Input: (r) RX   - Rx IEN (#52)
     156 ;       (o) RFL  - Refill #  (Default: most recent)
     157 ;       (o) USR  - User responsible for releasing the Rx (Default: .5 - Postmaster)
     158 ;
     159 N IBAR,RXAR,FLDT,RFAR
     160 ;
     161 S:'$D(RFL) RFL=$$LSTRFL(RX)
     162 S:'$D(USR) USR=.5
     163 ;
     164 D GETS^DIQ(52,RX_",",".01;2;6;7;8;22","I","RXAR")
     165 S DFN=+$G(RXAR(52,RX_",",2,"I"))
     166 S IBAR("PRESCRIPTION")=RX,IBAR("RX NO")=$G(RXAR(52,RX_",",.01,"I"))
     167 S IBAR("CLAIMID")=$E((RX#10000000)+10000000,2,8),IBAR("USER")=USR
     168 S IBAR("DRUG")=RXAR(52,RX_",",6,"I"),IBAR("NDC")=$$GETNDC^PSONDCUT(RX,RFL)
     169 S FLDT=$$RXFLDT^PSOBPSUT(RX,RFL) I FLDT>DT S FLDT=DT
     170 S IBAR("FILL NUMBER")=RFL,IBAR("FILL DATE")=FLDT
     171 S IBAR("QTY")=$G(RXAR(52,RX_",",7,"I")),IBAR("DAYS SUPPLY")=$G(RXAR(52,RX_",",8,"I"))
     172 ;
     173 I RFL D
     174 . D GETS^DIQ(52.1,RFL_","_RX_",",".01;1;1.1","I","RFAR")
     175 . S IBAR("QTY")=$G(RFAR(52.1,RFL_","_RX_",",1,"I"))
     176 . S IBAR("DAYS SUPPLY")=$G(RFAR(52.1,RFL_","_RX_",",1.1,"I"))
     177 ;
     178 S IBAR("STATUS")="RELEASED" D STORESP^IBNCPDP(DFN,.IBAR)
     179 ;
     180 Q
     181 ;
     182LSTRFL(RX) ;  - Returns the latest fill for the Prescription
     183 ; Input: (r) RX     - Rx IEN (#52)
     184 ;Output:     LSTRFL - Most recent refill #
     185 N I,LSTRFL
     186 S (I,LSTRFL)=0 F  S I=$O(^PSRX(RX,1,I)) Q:'I  S LSTRFL=I
     187 Q LSTRFL
     188 ;
     189ECMEACT(RX,RFL,COMM,USR) ; - Add an Activity to the ECME Activity Log (PRESCRIPTION file)
     190 ;Input: (r) RX   - Rx IEN (#52)
     191 ;       (o) RFL  - Refill #  (Default: most recent)
     192 ;       (r) COMM - Comments (up to 75 characters)
     193 ;       (o) USR  - User logging the comments (Default: DUZ)
     194 ;
     195 S:'$D(RFL) RFL=$$LSTRFL^PSOBPSU1(RX)
     196 D RXACT^PSOBPSU2(RX,RFL,COMM,"M",+$G(USR))
     197 Q
     198 ;
     199STS(RX,RFL,RSP) ; Adds the Status to the ECME Activity Log according to Rx/fill claim status Response
     200 N STS
     201 S STS=$S($$STATUS^PSOBPSUT(RX,RFL)'="IN PROGRESS"&($$STATUS^PSOBPSUT(RX,RFL)'=""):"-"_$$STATUS^PSOBPSUT(RX,RFL),1:"")
     202 S:+RSP=1 STS="-NO SUBMISSION THROUGH ECME" S:+RSP=3 STS="-NO REVERSAL NEEDED" S:+RSP=4 STS="-NOT PROCESSED"
     203 S:+RSP=5 STS="-SOFTWARE ERROR"
     204 I +RSP=2,$$STATUS^PSOBPSUT(RX,RFL)'="" S STS="-NOT BILLABLE:"_$P(RSP,"^",2)
     205 Q STS

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBPSUT.m

    r613 r623  
    1 PSOBPSUT        ;BIRM/MFR - BPS (ECME) Utilities ; 07 Jun 2005  8:39 PM
    2         ;;7.0;OUTPATIENT PHARMACY;**148,247,260,281**;DEC 1997;Build 41
    3         ;Reference to $$ECMEON^BPSUTIL supported by IA 4410
    4         ;Reference to IBSEND^BPSECMP2 supported by IA 4411
    5         ;Reference to $$STATUS^BPSOSRX supported by IA 4412
    6         ;Reference to $$NDCFMT^PSSNDCUT supported by IA 4707
    7         ;Reference to $$CLAIM^BPSBUTL supported by IA 4719
    8         ;Reference to ^PS(55 supported by IA 2228
    9         ;Reference to ^PSDRUG( supported by IA 221
    10         ;Reference to ^PSDRUG("AQ" supported by IA 3165
    11         ;
    12 ECME(RX)        ; Returns "e" if Rx/Refill is Electronically Billable (3rd party)
    13         Q $S($$STATUS^BPSOSRX(RX,$$LSTRFL^PSOBPSU1(RX))'="":"e",1:"")
    14         ;
    15 STATUS(RX,RFL)  ; Returns the Rx's ECME Status (calls STATUS^BPSOSRX)
    16         ; Input:  (r) RX  - Rx IEN (#52)
    17         ;         (o) RFL - Refill # (Default: most recent)
    18         I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
    19         Q $P($$STATUS^BPSOSRX(RX,RFL),"^")
    20         ;
    21 SUBMIT(RX,RFL,IGRL,IGCMP)       ; Returns whether the Rx should be submitted to ECME at the moment or not
    22         ; Input:  (r) RX   - Rx IEN (#52)
    23         ;         (o) RFL  - Refill # (Def.: most recent)
    24         ;         (o) IGRL - Ignore Release Date? (1-YES/0-NO) (Def.: 0 - NO)
    25         ;         (o) IGCMP- Ignore CMOP/Suspense check? (1-YES/0-NO) (Def.: 0 - NO)
    26         ;
    27         ; - Get the REFILL # (multiple IEN)
    28         N STATUS
    29         I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
    30         ; - Not the latest fill for the prescription
    31         I RFL'=$$LSTRFL^PSOBPSU1(RX) Q 0
    32         ; - Status not ACTIVE, DISCONTINUED, or EXPIRED
    33         S STATUS=$$GET1^DIQ(52,RX,100,"I")
    34         I STATUS'=0&(STATUS'=11)&(STATUS'=12) Q 0
    35         ; Will suspend for CMOP
    36         I '$G(IGCMP),$$CMOP(RX,RFL) Q 0
    37         ; - ECME turned OFF for Rx's site
    38         I '$$ECMEON^BPSUTIL($$RXSITE(RX,RFL)) Q 0
    39         ; - Rx is RELEASED - Do not submit
    40         I '$G(IGRL),$$RXRLDT(RX,RFL) Q 0
    41         ; - Future Fill/AUTO SUSPENSE ON - will suspend
    42         I '$G(IGCMP),$$RXFLDT(RX,RFL)>DT,$$GET1^DIQ(59,$$RXSITE(RX,RFL),.16,"I") Q 0
    43         Q 1
    44         ;
    45 CMOP(RX,RFL)    ; Returns if the Rx will be a CMOP Rx or not
    46         ; Input:  (r) RX  - Rx IEN (#52)
    47         ;         (o) RFL - Refill # (Default: most recent)
    48         ; Output: 1 - CMOP / 0 - NON-CMOP
    49         ;
    50         N DFN,CMOP,MAIL,MAILEXP,DRUG,WARNS,STATUS,MW,A
    51         ; Get the REFILL # (multiple IEN)
    52         I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
    53         ; MAIL=MAIL Code, MAILEXP=Mail Code Expiration Date
    54         S CMOP=0
    55         S DFN=$$GET1^DIQ(52,RX,2,"I"),MAIL=$$GET1^DIQ(55,DFN,.03,"I"),MAILEXP=$$GET1^DIQ(55,DFN,.05,"I")
    56         I MAIL>1,MAILEXP=""!(MAILEXP>DT) G QCMOP
    57         ; Get drug IEN and cheDRUG if CMOP  ,$S($G(MAILEXP)=""!($G(MAILEXP)>DT):1,1:0)
    58         S DRUG=$$GET1^DIQ(52,RX,6,"I") G QCMOP:'DRUG,QCMOP:'$D(^PSDRUG("AQ",DRUG))
    59         ; Not marked for O.P.
    60         I $$GET1^DIQ(50,DRUG,63)'["O" G QCMOP
    61         ; Drug Warning >11
    62         S WARNS=$$GET1^DIQ(50,DRUG,8) I $L(WARNS)>11 G QCMOP
    63         ; If tradename
    64         I $$GET1^DIQ(52,RX,6.5)'="" G QCMOP
    65         ; If Cancelled, Expired, Deleted, Hold
    66         S STATUS=$$GET1^DIQ(52,RX,100,"I") I STATUS>9!(STATUS=4)!(STATUS=3) G QCMOP
    67         ; Rx RELEASED
    68         I $$RXRLDT^PSOBPSUT(RX,RFL) G QCMOP
    69         ; MAIL/WINDOW
    70         S MW=$S('RFL:$$GET1^DIQ(52,RX,11,"I"),1:$$GET1^DIQ(52.1,RFL_","_RX,2,"I"))
    71         ; IF WINDOW/ORIGINAL/FUTURE FILL SETS MW = MAIL
    72         I MW="W",$$RXFLDT^PSOBPSUT(RX,RFL)>DT S MW="M"
    73         ; If not MAIL
    74         I MW'="M" G QCMOP
    75         S CMOP=1
    76         ;
    77 QCMOP   Q CMOP
    78         ;
    79 RXRLDT(RX,RFL)  ; Returns the Rx Release Date
    80         ; Input:  (r) RX  - Rx IEN (#52)
    81         ;         (o) RFL - Refill # (Default: most recent)
    82         ;       
    83         ; Output:  RXRLDT - Rx Release Date
    84         N RXRLDT
    85         I '$G(RX) Q ""
    86         S RXRLDT=$$GET1^DIQ(52,RX,31,"I")
    87         I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
    88         I RFL S RXRLDT=$$GET1^DIQ(52.1,RFL_","_RX,17,"I")
    89         Q RXRLDT
    90         ;
    91 RXFLDT(RX,RFL)  ; Returns the Rx Fill Date
    92         ; Input:  (r) RX  - Rx IEN (#52)
    93         ;         (o) RFL - Refill # (Default: most recent)     
    94         ; Output:  RXFLDT - Rx Fill Date
    95         N RXFLDT
    96         I '$G(RX) Q ""
    97         S RXFLDT=$$GET1^DIQ(52,RX,22,"I")
    98         I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
    99         I RFL S RXFLDT=$$GET1^DIQ(52.1,RFL_","_RX,.01,"I")
    100         Q RXFLDT
    101         ;
    102 RXSUDT(RX,RFL)  ; Returns the prescription/fill Suspense Date for the RX/Reject passed in
    103         ;Input: (r) RX   - Rx IEN (#52)
    104         ;       (o) RFL  - Refill IEN (#52.1)
    105         ;Output: SUSPENSE DATE (External format) or <NULL>, if not suspended
    106         ;
    107         I $G(^PSRX(RX,"STA"))'=5 Q ""
    108         N SURX,SURFL
    109         S SURX=$O(^PS(52.5,"B",RX,0)) I 'SURX Q ""
    110         I $$GET1^DIQ(52.5,SURX,.05,"I") Q ""
    111         S SURFL=+$$GET1^DIQ(52.5,SURX,9) I RFL'=SURFL Q ""
    112         Q $$GET1^DIQ(52.5,SURX,.02,"I")
    113         ;
    114 RXSITE(RX,RFL)  ; Returns the Rx DIVISION
    115         ; Input:  (r) RX  - Rx IEN (#52)
    116         ;         (o) RFL - Refill #
    117         ; Output:  SITE - Rx Fill Date
    118         ;       
    119         N SITE
    120         I '$G(RX) Q ""
    121         I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
    122         I RFL S SITE=$$GET1^DIQ(52.1,RFL_","_RX,8,"I")
    123         I 'RFL!'$G(SITE) S SITE=$$GET1^DIQ(52,RX,20,"I")
    124         Q SITE
    125         ;
    126 MANREL(RX,RFL,PID)      ; ePharmacy Manual Rx Release
    127         ;Input: (r) RX  - Rx IEN (#52)
    128         ;       (o) RFL - Refill # (Default: most recent)
    129         ;       (o) PID - Displays PID/Drug/Rx in the NDC prompts
    130         ;Output: "" (null - OK to Release) OR "^" (User entered "^", or no valid NDC on file for ePharmacy Rx)
    131         ;       
    132         N ACTION
    133         ;
    134         I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
    135         ;
    136         ; - Checking for REJECTS before proceeding to Rx Release
    137         I $$FIND^PSOREJUT(RX,RFL) D  I ACTION="Q"!(ACTION="^") W ! Q "^"
    138         . S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","OIQ","Q")
    139         ;
    140         ; - ePharmacy switch is OFF
    141         I '$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RFL)) Q ""
    142         ;
    143         ; - Not an ePharmacy Rx
    144         I $$STATUS^PSOBPSUT(RX,RFL)="" Q ""
    145         ;
    146         ; - NDC editing before Rx release
    147         S ACTION=$$CHGNDC^PSONDCUT(RX,RFL,$G(PID)) I ACTION="^" D  Q "^"
    148         . W !!,$C(7),"A valid NDC must be entered before the Release function can be completed.",! H 1
    149         ;
    150         ; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects (After possible NDC edit)
    151         I $$FIND^PSOREJUT(RX,RFL) D  I ACTION="Q"!(ACTION="^") W ! Q "^"
    152         . S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","OIQ","Q")
    153         ;
    154         ; - Notifying IB of a Rx RELEASE event
    155         D RELEASE^PSOBPSU1(RX,RFL,DUZ)
    156         ;
    157         Q ""
    158         ;
    159 AUTOREL(RX,RFL,RLDT,NDC,SRC,STS,HNG)    ; Sends Rx Release information to ECME/IB and updates NDC
    160         ;                                 in the DRUG/PRESCRIPTION files
    161         ;Input: (r) RX  - Rx IEN (#52)
    162         ;       (o) RFL - Refill #  (Default: most recent)
    163         ;       (r) RLDT- Release Date
    164         ;       (r) NDC - NDC Number (Must be 11 digits)
    165         ;       (o) SRC - SOURCE: "C" - CMOP / "A" - OPAI
    166         ;       (o) STS - Status: (S)uccessful/(U)nsuccessful Release (Default: "S" - Successful)
    167         ;       (o) HNG - HANG time after resubmission and before checking the status of the claim (Default: 0)
    168         ;       
    169         N RXNDC,SITE
    170         ;
    171         I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
    172         ;
    173         S:'$D(STS) STS="S" S:'$D(SRC) SRC="" S HNG=+$G(HNG)
    174         S RXNDC=$$GETNDC^PSONDCUT(RX,RFL)
    175         ;
    176         ; - Saves the NDC from CMOP/Automated Dispensing Machine in the Prescription file
    177         I $$NDCFMT^PSSNDCUT(NDC)'="" D SAVNDC^PSONDCUT(RX,RFL,$$NDCFMT^PSSNDCUT(NDC),$S(SRC="C":1,1:0))
    178         ;
    179         ; - Not an ePharmacy Rx
    180         I $$STATUS^PSOBPSUT(RX,RFL)="" Q ""
    181         ;
    182         ; - Unsuccessful Release
    183         I STS="U" D  Q
    184         . D REVERSE^PSOBPSU1(RX,RFL,"CRLX",,"UNSUCCESSFUL "_$S(SRC="C":"CMOP",1:"EXT INTERFACE")_" RELEASE",1)
    185         ;
    186         ; - Notifying IB of a Rx RELEASE event
    187         D RELEASE^PSOBPSU1(RX,RFL)
    188         ;
    189         ; - Invalid NDC from Automated Dispensing Machine
    190         I SRC="A",$$NDCFMT^PSSNDCUT(NDC)="" D  Q
    191         . D REVERSE^PSOBPSU1(RX,RFL,"CRLR",,"INVALID EXT INTERFACE NDC",1,NDC)
    192         ;
    193         ; - Invalid NDC number for CMOP
    194         I SRC="C",$$NDCFMT^PSSNDCUT(NDC)="" D  Q
    195         . D REVERSE^PSOBPSU1(RX,RFL,"CRLR",,"INVALID CMOP NDC",1,NDC)
    196         ;
    197         ; - If NDC not equal RXNDC, issue reversal and submit new claim
    198         I SRC="A",$$NDCFMT^PSSNDCUT(NDC)'=RXNDC D  Q
    199         . D ECMESND^PSOBPSU1(RX,RFL,RLDT,"CRLB",$$NDCFMT^PSSNDCUT(NDC),,"AUTO RELEASE",,1,,1)
    200         . H HNG
    201         . ; - If new claim returned PAYABLE, save new NDC in the DRUG/PRESCRIPTION files
    202         . I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" D SAVNDC^PSONDCUT(RX,RFL,$$NDCFMT^PSSNDCUT(NDC),0,1)
    203         ;
    204         ; - If NDC not equal RXNDC, issue reversal and submit new claim
    205         I SRC="C",$$NDCFMT^PSSNDCUT(NDC)'=RXNDC D  Q
    206         . ; - Reverse/Resubmit with correct NDC
    207         . D ECMESND^PSOBPSU1(RX,RFL,RLDT,"CRLB",$$NDCFMT^PSSNDCUT(NDC),1,"CMOP RELEASE",,1,,1)
    208         . ; - Wait for a response from the Payer for the submission above
    209         . H HNG
    210         . ; - If new claim returned PAYABLE, save new NDC in the DRUG/PRESCRIPTION files
    211         . I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" D SAVNDC^PSONDCUT(RX,RFL,$$NDCFMT^PSSNDCUT(NDC),1,1)
    212         ;
    213         ; - Calls ECME api responsible for notifying IB to create a BILL
    214         D IBSEND(RX,RFL)
    215         ;
    216         Q
    217         ;
    218 IBSEND(RX,RFL)  ; Rx Release: Calls ECME, which will call  IB to create a bill
    219         ;Input: (r) RX  - Rx IEN (#52)
    220         ;       (o) RFL - Refill #  (Default: most recent)
    221         ;
    222         I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
    223         ;
    224         ; - ECME turned OFF for Rx's site
    225         I '$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RFL)) Q
    226         ;
    227         ; - Not an ePharmacy Rx
    228         I $$STATUS^PSOBPSUT(RX,RFL)="" Q ""
    229         ;
    230         ; - Calls ECME previously reversed, re-submit the claim to the payer
    231         I $$STATUS^PSOBPSUT(RX,RFL)="E REVERSAL ACCEPTED"!($$STATUS^PSOBPSUT(RX,RFL)="IN PROGRESS") D  Q
    232         . D ECMESND^PSOBPSU1(RX,RFL,$$RXRLDT^PSOBPSUT(RX,RFL),"RRL")
    233         ;
    234         ; - Notifying ECME of a BILLING event
    235         I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" D  Q
    236         . N PSOCLAIM S PSOCLAIM=$$CLAIM^BPSBUTL(RX,RFL)
    237         . D IBSEND^BPSECMP2($P(PSOCLAIM,"^",2),$P(PSOCLAIM,"^",3),"BILL",DUZ)
    238         ;
    239         Q
    240         ;
    241 RETRX(RX,RFL)   ; - Re-transmit a claim for the prescription/fill?
    242         ;Input: (r) RX  - Rx IEN (#52)
    243         ;       (o) RFL - Refill # (Default: most recent)
    244         ;Output: 1 - Re-transmit  /  0 - Don't re-transmit
    245         I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
    246         ;
    247         I RFL Q +$$GET1^DIQ(52.1,RFL_","_RX,82,"I")
    248         Q +$$GET1^DIQ(52,RX,82,"I")
     1PSOBPSUT ;BIRM/MFR - BPS (ECME) Utilities ; 07 Jun 2005  8:39 PM
     2 ;;7.0;OUTPATIENT PHARMACY;**148,247,260**;DEC 1997;Build 84
     3 ;Reference to $$ECMEON^BPSUTIL supported by IA 4410
     4 ;Reference to IBSEND^BPSECMP2 supported by IA 4411
     5 ;Reference to $$STATUS^BPSOSRX supported by IA 4412
     6 ;Reference to $$NDCFMT^PSSNDCUT supported by IA 4707
     7 ;Reference to $$CLAIM^BPSBUTL supported by IA 4719
     8 ;Reference to ^PS(55 supported by IA 2228
     9 ;Reference to ^PSDRUG( supported by IA 221
     10 ;Reference to ^PSDRUG("AQ" supported by IA 3165
     11 ;
     12ECME(RX) ; Returns "e" if Rx/Refill is Electronically Billable (3rd party)
     13 Q $S($$STATUS^BPSOSRX(RX,$$LSTRFL^PSOBPSU1(RX))'="":"e",1:"")
     14 ;
     15STATUS(RX,RFL) ; Returns the Rx's ECME Status (calls STATUS^BPSOSRX)
     16 ; Input:  (r) RX  - Rx IEN (#52)
     17 ;         (o) RFL - Refill # (Default: most recent)
     18 I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
     19 Q $P($$STATUS^BPSOSRX(RX,RFL),"^")
     20 ;
     21SUBMIT(RX,RFL,IGRL,IGCMP) ; Returns whether the Rx should be submitted to ECME at the moment or not
     22 ; Input:  (r) RX   - Rx IEN (#52)
     23 ;         (o) RFL  - Refill # (Def.: most recent)
     24 ;         (o) IGRL - Ignore Release Date? (1-YES/0-NO) (Def.: 0 - NO)
     25 ;         (o) IGCMP- Ignore CMOP/Suspense check? (1-YES/0-NO) (Def.: 0 - NO)
     26 ;
     27 ; - Get the REFILL # (multiple IEN)
     28 I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
     29 ; - Not the latest fill for the prescription
     30 I RFL'=$$LSTRFL^PSOBPSU1(RX) Q 0
     31 ; - Status not ACTIVE
     32 I $$GET1^DIQ(52,RX,100,"I")'=0 Q 0
     33 ; Will suspend for CMOP
     34 I '$G(IGCMP),$$CMOP(RX,RFL) Q 0
     35 ; - ECME turned OFF for Rx's site
     36 I '$$ECMEON^BPSUTIL($$RXSITE(RX,RFL)) Q 0
     37 ; - Rx is RELEASED - Do not submit
     38 I '$G(IGRL),$$RXRLDT(RX,RFL) Q 0
     39 ; - Future Fill/AUTO SUSPENSE ON - will suspend
     40 I '$G(IGCMP),$$RXFLDT(RX,RFL)>DT,$$GET1^DIQ(59,$$RXSITE(RX,RFL),.16,"I") Q 0
     41 Q 1
     42 ;
     43CMOP(RX,RFL) ; Returns if the Rx will be a CMOP Rx or not
     44 ; Input:  (r) RX  - Rx IEN (#52)
     45 ;         (o) RFL - Refill # (Default: most recent)
     46 ; Output: 1 - CMOP / 0 - NON-CMOP
     47 ;
     48 N DFN,CMOP,MAIL,MAILEXP,DRUG,WARNS,STATUS,MW,A
     49 ; Get the REFILL # (multiple IEN)
     50 I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
     51 ; MAIL=MAIL Code, MAILEXP=Mail Code Expiration Date
     52 S CMOP=0
     53 S DFN=$$GET1^DIQ(52,RX,2,"I"),MAIL=$$GET1^DIQ(55,DFN,.03,"I"),MAILEXP=$$GET1^DIQ(55,DFN,.05,"I")
     54 I MAIL>1,MAILEXP=""!(MAILEXP>DT) G QCMOP
     55 ; Get drug IEN and cheDRUG if CMOP  ,$S($G(MAILEXP)=""!($G(MAILEXP)>DT):1,1:0)
     56 S DRUG=$$GET1^DIQ(52,RX,6,"I") G QCMOP:'DRUG,QCMOP:'$D(^PSDRUG("AQ",DRUG))
     57 ; Not marked for O.P.
     58 I $$GET1^DIQ(50,DRUG,63)'["O" G QCMOP
     59 ; Drug Warning >11
     60 S WARNS=$$GET1^DIQ(50,DRUG,8) I $L(WARNS)>11 G QCMOP
     61 ; If tradename
     62 I $$GET1^DIQ(52,RX,6.5)'="" G QCMOP
     63 ; If Cancelled, Expired, Deleted, Hold
     64 S STATUS=$$GET1^DIQ(52,RX,100,"I") I STATUS>9!(STATUS=4)!(STATUS=3) G QCMOP
     65 ; Rx RELEASED
     66 I $$RXRLDT^PSOBPSUT(RX,RFL) G QCMOP
     67 ; MAIL/WINDOW
     68 S MW=$S('RFL:$$GET1^DIQ(52,RX,11,"I"),1:$$GET1^DIQ(52.1,RFL_","_RX,2,"I"))
     69 ; IF WINDOW/ORIGINAL/FUTURE FILL SETS MW = MAIL
     70 I MW="W",$$RXFLDT^PSOBPSUT(RX,RFL)>DT S MW="M"
     71 ; If not MAIL
     72 I MW'="M" G QCMOP
     73 S CMOP=1
     74 ;
     75QCMOP Q CMOP
     76 ;
     77RXRLDT(RX,RFL) ; Returns the Rx Release Date
     78 ; Input:  (r) RX  - Rx IEN (#52)
     79 ;         (o) RFL - Refill # (Default: most recent)
     80 ;       
     81 ; Output:  RXRLDT - Rx Release Date
     82 N RXRLDT
     83 I '$G(RX) Q ""
     84 S RXRLDT=$$GET1^DIQ(52,RX,31,"I")
     85 I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
     86 I RFL S RXRLDT=$$GET1^DIQ(52.1,RFL_","_RX,17,"I")
     87 Q RXRLDT
     88 ;
     89RXFLDT(RX,RFL) ; Returns the Rx Fill Date
     90 ; Input:  (r) RX  - Rx IEN (#52)
     91 ;         (o) RFL - Refill # (Default: most recent)     
     92 ; Output:  RXFLDT - Rx Fill Date
     93 N RXFLDT
     94 I '$G(RX) Q ""
     95 S RXFLDT=$$GET1^DIQ(52,RX,22,"I")
     96 I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
     97 I RFL S RXFLDT=$$GET1^DIQ(52.1,RFL_","_RX,.01,"I")
     98 Q RXFLDT
     99 ;
     100RXSUDT(RX,RFL) ; Returns the prescription/fill Suspense Date for the RX/Reject passed in
     101 ;Input: (r) RX   - Rx IEN (#52)
     102 ;       (o) RFL  - Refill IEN (#52.1)
     103 ;Output: SUSPENSE DATE (External format) or <NULL>, if not suspended
     104 ;
     105 I $G(^PSRX(RX,"STA"))'=5 Q ""
     106 N SURX,SURFL
     107 S SURX=$O(^PS(52.5,"B",RX,0)) I 'SURX Q ""
     108 I $$GET1^DIQ(52.5,SURX,.05,"I") Q ""
     109 S SURFL=+$$GET1^DIQ(52.5,SURX,9) I RFL'=SURFL Q ""
     110 Q $$GET1^DIQ(52.5,SURX,.02,"I")
     111 ;
     112RXSITE(RX,RFL) ; Returns the Rx DIVISION
     113 ; Input:  (r) RX  - Rx IEN (#52)
     114 ;         (o) RFL - Refill #
     115 ; Output:  SITE - Rx Fill Date
     116 ;       
     117 N SITE
     118 I '$G(RX) Q ""
     119 I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
     120 I RFL S SITE=$$GET1^DIQ(52.1,RFL_","_RX,8,"I")
     121 I 'RFL!'$G(SITE) S SITE=$$GET1^DIQ(52,RX,20,"I")
     122 Q SITE
     123 ;
     124MANREL(RX,RFL,PID) ; ePharmacy Manual Rx Release
     125 ;Input: (r) RX  - Rx IEN (#52)
     126 ;       (o) RFL - Refill # (Default: most recent)
     127 ;       (o) PID - Displays PID/Drug/Rx in the NDC prompts
     128 ;Output: "" (null - OK to Release) OR "^" (User entered "^", or no valid NDC on file for ePharmacy Rx)
     129 ;       
     130 N ACTION
     131 ;
     132 I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
     133 ;
     134 ; - Checking for REJECTS before proceeding to Rx Release
     135 I $$FIND^PSOREJUT(RX,RFL) D  I ACTION="Q"!(ACTION="^") W ! Q "^"
     136 . S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","OIQ","Q")
     137 ;
     138 ; - ePharmacy switch is OFF
     139 I '$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RFL)) Q ""
     140 ;
     141 ; - Not an ePharmacy Rx
     142 I $$STATUS^PSOBPSUT(RX,RFL)="" Q ""
     143 ;
     144 ; - NDC editing before Rx release
     145 S ACTION=$$CHGNDC^PSONDCUT(RX,RFL,$G(PID)) I ACTION="^" D  Q "^"
     146 . W !!,$C(7),"A valid NDC must be entered before the Release function can be completed.",! H 1
     147 ;
     148 ; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects (After possible NDC edit)
     149 I $$FIND^PSOREJUT(RX,RFL) D  I ACTION="Q"!(ACTION="^") W ! Q "^"
     150 . S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","OIQ","Q")
     151 ;
     152 ; - Notifying IB of a Rx RELEASE event
     153 D RELEASE^PSOBPSU1(RX,RFL,DUZ)
     154 ;
     155 Q ""
     156 ;
     157AUTOREL(RX,RFL,RLDT,NDC,SRC,STS,HNG) ; Sends Rx Release information to ECME/IB and updates NDC
     158 ;                                 in the DRUG/PRESCRIPTION files
     159 ;Input: (r) RX  - Rx IEN (#52)
     160 ;       (o) RFL - Refill #  (Default: most recent)
     161 ;       (r) RLDT- Release Date
     162 ;       (r) NDC - NDC Number (Must be 11 digits)
     163 ;       (o) SRC - SOURCE: "C" - CMOP / "A" - OPAI
     164 ;       (o) STS - Status: (S)uccessful/(U)nsuccessful Release (Default: "S" - Successful)
     165 ;       (o) HNG - HANG time after resubmission and before checking the status of the claim (Default: 0)
     166 ;       
     167 N RXNDC,SITE
     168 ;
     169 I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
     170 ;
     171 S:'$D(STS) STS="S" S:'$D(SRC) SRC="" S HNG=+$G(HNG)
     172 S RXNDC=$$GETNDC^PSONDCUT(RX,RFL)
     173 ;
     174 ; - Saves the NDC from CMOP/Automated Dispensing Machine in the Prescription file
     175 I $$NDCFMT^PSSNDCUT(NDC)'="" D SAVNDC^PSONDCUT(RX,RFL,$$NDCFMT^PSSNDCUT(NDC),$S(SRC="C":1,1:0))
     176 ;
     177 ; - Not an ePharmacy Rx
     178 I $$STATUS^PSOBPSUT(RX,RFL)="" Q ""
     179 ;
     180 ; - Unsuccessful Release
     181 I STS="U" D  Q
     182 . D REVERSE^PSOBPSU1(RX,RFL,"CRLX",,"UNSUCCESSFUL "_$S(SRC="C":"CMOP",1:"EXT INTERFACE")_" RELEASE",1)
     183 ;
     184 ; - Notifying IB of a Rx RELEASE event
     185 D RELEASE^PSOBPSU1(RX,RFL)
     186 ;
     187 ; - Invalid NDC from Automated Dispensing Machine
     188 I SRC="A",$$NDCFMT^PSSNDCUT(NDC)="" D  Q
     189 . D REVERSE^PSOBPSU1(RX,RFL,"CRLR",,"INVALID EXT INTERFACE NDC",1,NDC)
     190 ;
     191 ; - Invalid NDC number for CMOP
     192 I SRC="C",$$NDCFMT^PSSNDCUT(NDC)="" D  Q
     193 . D REVERSE^PSOBPSU1(RX,RFL,"CRLR",,"INVALID CMOP NDC",1,NDC)
     194 ;
     195 ; - If NDC not equal RXNDC, issue reversal and submit new claim
     196 I SRC="A",$$NDCFMT^PSSNDCUT(NDC)'=RXNDC D  Q
     197 . D ECMESND^PSOBPSU1(RX,RFL,RLDT,"CRLB",$$NDCFMT^PSSNDCUT(NDC),,"AUTO RELEASE",,1,,1)
     198 . H HNG
     199 . ; - If new claim returned PAYABLE, save new NDC in the DRUG/PRESCRIPTION files
     200 . I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" D SAVNDC^PSONDCUT(RX,RFL,$$NDCFMT^PSSNDCUT(NDC),0,1)
     201 ;
     202 ; - If NDC not equal RXNDC, issue reversal and submit new claim
     203 I SRC="C",$$NDCFMT^PSSNDCUT(NDC)'=RXNDC D  Q
     204 . ; - Reverse/Resubmit with correct NDC
     205 . D ECMESND^PSOBPSU1(RX,RFL,RLDT,"CRLB",$$NDCFMT^PSSNDCUT(NDC),1,"CMOP RELEASE",,1,,1)
     206 . ; - Wait for a response from the Payer for the submission above
     207 . H HNG
     208 . ; - If new claim returned PAYABLE, save new NDC in the DRUG/PRESCRIPTION files
     209 . I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" D SAVNDC^PSONDCUT(RX,RFL,$$NDCFMT^PSSNDCUT(NDC),1,1)
     210 ;
     211 ; - Calls ECME api responsible for notifying IB to create a BILL
     212 D IBSEND(RX,RFL)
     213 ;
     214 Q
     215 ;
     216IBSEND(RX,RFL) ; Rx Release: Calls ECME, which will call  IB to create a bill
     217 ;Input: (r) RX  - Rx IEN (#52)
     218 ;       (o) RFL - Refill #  (Default: most recent)
     219 ;
     220 I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
     221 ;
     222 ; - ECME turned OFF for Rx's site
     223 I '$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RFL)) Q
     224 ;
     225 ; - Not an ePharmacy Rx
     226 I $$STATUS^PSOBPSUT(RX,RFL)="" Q ""
     227 ;
     228 ; - Calls ECME previously reversed, re-submit the claim to the payer
     229 I $$STATUS^PSOBPSUT(RX,RFL)="E REVERSAL ACCEPTED"!($$STATUS^PSOBPSUT(RX,RFL)="IN PROGRESS") D  Q
     230 . D ECMESND^PSOBPSU1(RX,RFL,$$RXRLDT^PSOBPSUT(RX,RFL),"RRL")
     231 ;
     232 ; - Notifying ECME of a BILLING event
     233 I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" D  Q
     234 . N PSOCLAIM S PSOCLAIM=$$CLAIM^BPSBUTL(RX,RFL)
     235 . D IBSEND^BPSECMP2($P(PSOCLAIM,"^",2),$P(PSOCLAIM,"^",3),"BILL",DUZ)
     236 ;
     237 Q
     238 ;
     239RETRX(RX,RFL) ; - Re-transmit a claim for the prescription/fill?
     240 ;Input: (r) RX  - Rx IEN (#52)
     241 ;       (o) RFL - Refill # (Default: most recent)
     242 ;Output: 1 - Re-transmit  /  0 - Don't re-transmit
     243 I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
     244 ;
     245 I RFL Q +$$GET1^DIQ(52.1,RFL_","_RX,82,"I")
     246 Q +$$GET1^DIQ(52,RX,82,"I")

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBUILD.m

    r613 r623  
    1 PSOBUILD        ;IHS/DSD/JCM - BUILD ARRAY OF PATIENTS CURRENT MEDS  [ 07/15/96  5:25 PM ] ;6/21/07 8:20am
    2         ;;7.0;OUTPATIENT PHARMACY;**23,82,119,132,235,206**;DEC 1997;Build 39
    3         ;External reference ^PS(50.606 supported by DBIA 2174
    4         ;External reference ^PS(50.7 supported by DBIA 2223
    5         ;External reference ^PS(55 supported by DBIA 2228
    6         ;External reference ^PSDRUG( supported by DBIA 221
    7         ; Input variables: PSODFN,DT,PSODTCUT
    8 START   N ORD K PSOSD I '$D(PSODFN)!('$D(DT)) G END
    9         D EOJ,INIT G:PSOQFLG END D BUILD
    10         S STA="ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUED^^DISCONTINUED^DISCONTINUED^HOLD"
    11         S DRG="" F I=0:0 S DRG=$O(PSOSD(DRG)) Q:DRG=""  I $G(PSOSD(DRG))]"" S PSOSD($P(STA,"^",$P(PSOSD(DRG),"^",2)+1),DRG)=PSOSD(DRG) D  K PSOSD(DRG)
    12         .S $P(PSOSD($P(STA,"^",$P(PSOSD(DRG),"^",2)+1),DRG),"^",9)=$G(^TMP("PS",$J,$P(STA,"^",$P(PSOSD(DRG),"^",2)+1),DRG))
    13         F PEN=0:0 S PEN=$O(^PS(52.41,"P",PSODFN,PEN)) Q:'PEN  S ORD=^PS(52.41,PEN,0),PSOOI=$P(ORD,"^",8),PSODD=+$P(ORD,"^",9) D:$P(ORD,"^",3)'="DC"&($P(ORD,"^",3)'="DE")&($P(ORD,"^",3)'="HD")
    14         .S DRG=$S(PSODD:$P($G(^PSDRUG(PSODD,0)),"^"),+PSOOI&('PSODD):$P(^PS(50.7,+PSOOI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,+PSOOI,0),"^",2),0),"^"),1:"") Q:DRG']""
    15         .I $D(PSOSD("PENDING",DRG)) S DRG=DRG_"^"_PEN
    16         .S PSOSD("PENDING",DRG)="*****^17^Z^Z^"_$S(PSODD:$P(^PSDRUG(PSODD,0),"^",2),1:"")_"^"_$P(^PS(52.41,PEN,0),"^",11)_"^"_$S($G(^PSDRUG(PSODD,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:"")
    17         .S PSOSD("PENDING",DRG)=PSOSD("PENDING",DRG)_"^"_$P(ORD,"^",10)_"^"_$P(ORD,"^",6)_"^"_PEN_"^"_$S($G(PSODD):$G(PSODD),1:""),PSOSD=+$G(PSOSD)+1 K PSOOI,PSODD
    18         F NVA=0:0 S NVA=$O(^PS(55,PSODFN,"NVA",NVA)) Q:'NVA  S NON=^PS(55,PSODFN,"NVA",NVA,0) D:'$P(^PS(55,PSODFN,"NVA",NVA,0),"^",7)
    19         .S PSODD=$P(NON,"^",2),PSOOI=$P(NON,"^")
    20         .S DRG=$S(PSODD:$P($G(^PSDRUG(PSODD,0)),"^"),+PSOOI&('PSODD):$P(^PS(50.7,+PSOOI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,+PSOOI,0),"^",2),0),"^"),1:"")
    21         .I $D(PSOSD("ZNONVA",DRG)) S DRG=DRG_"^"_NVA
    22         .S PSOSD("ZNONVA",DRG)="****^9^Z^Z^"_$S($P(NON,"^",2):$P(^PSDRUG($P(NON,"^",2),0),"^",2),1:"")_"^"_$P(NON,"^",3)_"^^"_$P(NON,"^",5)_"^"_$P(NON,"^",10)_"^"_NVA_"^"_$P(NON,"^",2)
    23         .I $P(NON,"^",2) S $P(PSOSD("ZNONVA",DRG),"^",7)=$S($G(^PSDRUG(PSODD,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:"")
    24         .S PSOSD=+$G(PSOSD)+1
    25 END     D EOJ
    26         Q
    27 INIT    ;
    28         K PSOSD,PSOMED S PSOQFLG=0,U="^",PSOBUILD("COUNT")=0 G:$D(PSODTCUT) INITX
    29         I '$D(^PS(53,"B","OUTPATIENT")) S PSOQFLG=1 G INITX
    30         S PSOX=$O(^PS(53,"B","OUTPATIENT","")) I 'PSOX S PSOQFLG=1 G INITX
    31         ;S DAYS=$S($D(DAYS360):360,1:45),X2=-$S($P($G(^PS(53,PSOX,0)),"^",3)+15>DAYS:$P($G(^(0)),"^",3)+15,1:DAYS),X1=DT D C^%DTC S PSODTCUT=X
    32         S X2=-120,X1=DT D C^%DTC S PSODTCUT=X
    33 INITX   K X,X1,X2,PSOX
    34         Q
    35         ;
    36 BUILD   ;build profiles
    37         F PSOEXPDT=(PSODTCUT-1):0 S PSOEXPDT=$O(^PS(55,PSODFN,"P","A",PSOEXPDT)) Q:'PSOEXPDT  F PSOBUILD("RX")=0:0 S PSOBUILD("RX")=$O(^PS(55,PSODFN,"P","A",PSOEXPDT,PSOBUILD("RX"))) Q:'PSOBUILD("RX")  I $D(^PSRX(PSOBUILD("RX"),0)) D GET
    38 BUILDX  I PSOBUILD("COUNT")>0 S PSOSD=PSOBUILD("COUNT")
    39         Q
    40 GET     ;data for profiles
    41         Q:'$P(^PSRX(PSOBUILD("RX"),0),"^",2)
    42         S (PSOSTF,PSOSTN)="",PSORX0=^PSRX(PSOBUILD("RX"),0),PSOST0=+^PSRX(PSOBUILD("RX"),"STA"),$P(PSORX0,"^",15)=PSOST0
    43         G:PSOST0=13 GETX S PSORX2=$G(^PSRX(PSOBUILD("RX"),2))
    44         S PSORX3=$G(^PSRX(PSOBUILD("RX"),3)) S:PSORX3="" PSORX3=$P(PSORX2,"^",2)
    45         S PSODRG=+$P(PSORX0,"^",6) G:'$D(^PSDRUG(PSODRG,0)) GETX S PSODRUG0=^PSDRUG(PSODRG,0),PSOVACL=$P(PSODRUG0,"^",2),PSODYS=$P(PSORX0,"^",8)
    46         ;
    47         I PSOST0<12!(PSOST0=16),PSOEXPDT<DT D:$P(PSORX0,"^",15)'=11
    48         .S PSOST0=11,$P(PSORX0,"^",15)=11 N DIE,DIC,DR,DA,PSOBEXDA S DIE=52,(DA,PSOBEXDA)=PSOBUILD("RX"),DR="100////11" D ^DIE K DIE,DIC,DR
    49         .D ECAN^PSOUTL(DA) K DA
    50         .S STAT="SC",PHARMST="ZE",COMM="Medication Expired on "_$E(PSOEXPDT,4,5)_"/"_$E(PSOEXPDT,6,7)_"/"_$E(PSOEXPDT,2,3) D EN^PSOHLSN1(PSOBEXDA,STAT,PHARMST,COMM) K COMM,STAT,PHARMST,PSOBEXDA
    51         I PSOST0=12,PSOEXPDT<DT S PSOST0=12
    52         I PSOST0=5 D  G GT1
    53         .I $O(^PS(52.5,"B",PSOBUILD("RX"),0)),'$D(^PS(52.5,+$O(^(0)),0)) D  Q
    54         ..S PSOST0=0 D FSTA
    55         ..K ^PS(52.5,"B",PSOBUILD("RX"),$O(^PS(52.5,"B",PSOBUILD("RX"),0)))
    56         .I '$O(^PS(52.5,"B",PSOBUILD("RX"),0)) S PSOST0=0 D FSTA
    57         I 'PSOST0 D STAT
    58 GT1     G GETX:$D(NOEXP)&(PSOST0=11)
    59         I $D(^PSDRUG(PSODRG,"I")),^("I")]"",DT>^("I") S PSOSTN=PSOSTN_"A" I $P($G(PSOPAR),"^",11)']"" S PSOSTF=PSOSTF_"A"
    60         S PSONDF=$S($G(^PSDRUG(PSODRG,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)
    61         I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" S PSOSTN=PSOSTN_"M"
    62         S CLOZPT=$S($P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1":1,1:0)
    63         I 'CLOZPT,($P(PSODRUG0,"^",3)["A")&($P(PSODRUG0,"^",3)'["B") S PSOSTN=PSOSTN_"B",PSOSTF=PSOSTF_"B"
    64         K CLOZPT I ($P(PSODRUG0,"^",3)["W")!($P(PSODRUG0,"^",3)[1)!($P(PSODRUG0,"^",3)[2) S PSOSTN=PSOSTN_"C"
    65         I $D(^PS(53,+$P(PSORX0,"^",3),0)),'$P(^(0),"^",5) S PSOSTN=PSOSTN_"D"
    66         I PSOST0=1 S PSOSTN=PSOSTN_"E"
    67         S PSOLC=$P(PSORX0,"^"),PSOLC=$E(PSOLC,$L(PSOLC)) I $A(PSOLC)>90 S PSOSTN=PSOSTN_"F"
    68         I PSOST0,PSOST0'=2,PSOST0'=6 S PSOSTF=PSOSTF_"Z"
    69         I $G(PSORX("BAR CODE")),PSOST0,PSOST0'=2,PSOST0'=5,PSOST0'=6,PSOST0'=11,PSOST0'=12 S PSOSTN=PSOSTN_"Z" G BARC
    70         I PSOST0,PSOST0'=2,PSOST0'=5,PSOST0'=6,PSOST0'=11,PSOST0'=12,PSOST0'=14 S PSOSTN=PSOSTN_"Z"
    71 BARC    S PSORFRM=$P(PSORX0,"^",9) F PSOJ=0:0 S PSOJ=$O(^PSRX(PSOBUILD("RX"),1,PSOJ)) Q:'PSOJ  S PSORFRM=PSORFRM-1
    72         S:PSORFRM<0 PSORFRM=0 S:PSORFRM=0 PSOSTF=PSOSTF_"G"
    73         S PSODRUGN=$P(PSODRUG0,"^") I $D(PSOSD(PSODRUGN)),PSOST0>10 Q:$P(PSOSD(PSODRUGN),"^",2)<11  Q:$P(PSOSD(PSODRUGN),"^",2)>10&($P(PSORX0,"^",13)<$P(^PSRX(+$P(PSOSD(PSODRUGN),"^"),0),"^",13))
    74         S:'$D(PSOSD(PSODRUGN)) PSOBUILD("COUNT")=PSOBUILD("COUNT")+1
    75         I $D(PSOSD(PSODRUGN)),$P(PSOSD(PSODRUGN),"^",2)<10,PSOST0<10 S PSOSD(PSODRUGN_"^"_PSOBUILD("RX"))=PSOBUILD("RX")_"^"_PSOST0_"^"_PSOSTN_"^"_PSOSTF_"^"_PSOVACL_"^"_PSORFRM_"^"_PSONDF_"^"_PSODYS,PSOBUILD("COUNT")=PSOBUILD("COUNT")+1
    76         E  S PSOSD(PSODRUGN)=PSOBUILD("RX")_"^"_PSOST0_"^"_PSOSTN_"^"_PSOSTF_"^"_PSOVACL_"^"_PSORFRM_"^"_PSONDF_"^"_PSODYS
    77 GETX    Q
    78 STAT    N X S X=+$O(^PS(52.5,"B",PSOBUILD("RX"),0))
    79         I X,$D(^PS(52.5,X,0)),$P($G(^PS(52.5,X,0)),"^",7)'="X",'$G(^PS(52.5,X,"P")) S PSOST0=5
    80         I PSOST0 D FSTA
    81         Q
    82 FSTA    S $P(PSORX0,"^",15)=PSOST0
    83         N DIE,DR,DA S DIE=52,DA=PSOBUILD("RX"),DR="100////"_PSOST0 D ^DIE K DIE,DR,DA
    84         Q
    85         ;
    86 EOJ     K ORD,PSOX,PSOEXPDT,PSODRG,PSODRUG0,PSOLC,PSONDF,PSOQFLG,PSORFRM,PSORX0,PSORX2,PSORX3,PSOST0,PSOSTF,PSOSTN,PSOJ,PSODRUGN,PSOVACL,PSOBUILD,PSODYS,PEN,DRG,NON,NVA
    87         Q
    88 INPAT(PSODFN)   ;entry point for inpat meds to view patient's outpat. meds
    89         D FULL^VALM1
    90         S INPAT=1,X2=-120,X1=DT D C^%DTC S PSODTCUT=X D START,^PSODSPL
    91         K PSOSD,DDH,PSCNT,PSOCT,PSODD,PSOOI,PSOPAR,PSOSTA,STP,STR,PSODTCUT,PSODFN,INPAT,DRG
    92         Q
     1PSOBUILD ;IHS/DSD/JCM - BUILD ARRAY OF PATIENTS CURRENT MEDS  [ 07/15/96  5:25 PM ]
     2 ;;7.0;OUTPATIENT PHARMACY;**23,82,119,132,235**;DEC 1997
     3 ;External reference ^PS(50.606 supported by DBIA 2174
     4 ;External reference ^PS(50.7 supported by DBIA 2223
     5 ;External reference ^PS(55 supported by DBIA 2228
     6 ;External reference ^PSDRUG( supported by DBIA 221
     7 ; Input variables: PSODFN,DT,PSODTCUT
     8START N ORD K PSOSD I '$D(PSODFN)!('$D(DT)) G END
     9 D EOJ,INIT G:PSOQFLG END D BUILD
     10 S STA="ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUED^^DISCONTINUED^DISCONTINUED^HOLD"
     11 S DRG="" F I=0:0 S DRG=$O(PSOSD(DRG)) Q:DRG=""  I $G(PSOSD(DRG))]"" S PSOSD($P(STA,"^",$P(PSOSD(DRG),"^",2)+1),DRG)=PSOSD(DRG) D  K PSOSD(DRG)
     12 .S $P(PSOSD($P(STA,"^",$P(PSOSD(DRG),"^",2)+1),DRG),"^",9)=$G(^TMP("PS",$J,$P(STA,"^",$P(PSOSD(DRG),"^",2)+1),DRG))
     13 F PEN=0:0 S PEN=$O(^PS(52.41,"P",PSODFN,PEN)) Q:'PEN  S ORD=^PS(52.41,PEN,0),PSOOI=$P(ORD,"^",8),PSODD=+$P(ORD,"^",9) D:$P(ORD,"^",3)'="DC"&($P(ORD,"^",3)'="DE")&($P(ORD,"^",3)'="HD")
     14 .S DRG=$S(PSODD:$P($G(^PSDRUG(PSODD,0)),"^"),+PSOOI&('PSODD):$P(^PS(50.7,+PSOOI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,+PSOOI,0),"^",2),0),"^"),1:"") Q:DRG']""
     15 .I $D(PSOSD("PENDING",DRG)) S DRG=DRG_"^"_PEN
     16 .S PSOSD("PENDING",DRG)="*****^17^Z^Z^"_$S(PSODD:$P(^PSDRUG(PSODD,0),"^",2),1:"")_"^"_$P(^PS(52.41,PEN,0),"^",11)_"^"_$S($G(^PSDRUG(PSODD,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:"")
     17 .S PSOSD("PENDING",DRG)=PSOSD("PENDING",DRG)_"^"_$P(ORD,"^",10)_"^"_$P(ORD,"^",6)_"^"_PEN_"^"_$S($G(PSODD):$G(PSODD),1:""),PSOSD=+$G(PSOSD)+1 K PSOOI,PSODD
     18 F NVA=0:0 S NVA=$O(^PS(55,PSODFN,"NVA",NVA)) Q:'NVA  S NON=^PS(55,PSODFN,"NVA",NVA,0) D:'$P(^PS(55,PSODFN,"NVA",NVA,0),"^",7)
     19 .S PSODD=$P(NON,"^",2),PSOOI=$P(NON,"^")
     20 .S DRG=$S(PSODD:$P($G(^PSDRUG(PSODD,0)),"^"),+PSOOI&('PSODD):$P(^PS(50.7,+PSOOI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,+PSOOI,0),"^",2),0),"^"),1:"")
     21 .I $D(PSOSD("ZNONVA",DRG)) S DRG=DRG_"^"_NVA
     22 .S PSOSD("ZNONVA",DRG)="****^9^Z^Z^"_$S($P(NON,"^",2):$P(^PSDRUG($P(NON,"^",2),0),"^",2),1:"")_"^"_$P(NON,"^",3)_"^^"_$P(NON,"^",5)_"^"_$P(NON,"^",10)_"^"_NVA_"^"_$P(NON,"^",2)
     23 .I $P(NON,"^",2) S $P(PSOSD("ZNONVA",DRG),"^",7)=$S($G(^PSDRUG(PSODD,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:"")
     24 .S PSOSD=+$G(PSOSD)+1
     25END D EOJ
     26 Q
     27INIT ;
     28 K PSOSD,PSOMED S PSOQFLG=0,U="^",PSOBUILD("COUNT")=0 G:$D(PSODTCUT) INITX
     29 I '$D(^PS(53,"B","OUTPATIENT")) S PSOQFLG=1 G INITX
     30 S PSOX=$O(^PS(53,"B","OUTPATIENT","")) I 'PSOX S PSOQFLG=1 G INITX
     31 ;S DAYS=$S($D(DAYS360):360,1:45),X2=-$S($P($G(^PS(53,PSOX,0)),"^",3)+15>DAYS:$P($G(^(0)),"^",3)+15,1:DAYS),X1=DT D C^%DTC S PSODTCUT=X
     32 S X2=-120,X1=DT D C^%DTC S PSODTCUT=X
     33INITX K X,X1,X2,PSOX
     34 Q
     35 ;
     36BUILD ;build profiles
     37 F PSOEXPDT=(PSODTCUT-1):0 S PSOEXPDT=$O(^PS(55,PSODFN,"P","A",PSOEXPDT)) Q:'PSOEXPDT  F PSOBUILD("RX")=0:0 S PSOBUILD("RX")=$O(^PS(55,PSODFN,"P","A",PSOEXPDT,PSOBUILD("RX"))) Q:'PSOBUILD("RX")  I $D(^PSRX(PSOBUILD("RX"),0)) D GET
     38BUILDX I PSOBUILD("COUNT")>0 S PSOSD=PSOBUILD("COUNT")
     39 Q
     40GET ;data for profiles
     41 Q:'$P(^PSRX(PSOBUILD("RX"),0),"^",2)
     42 S (PSOSTF,PSOSTN)="",PSORX0=^PSRX(PSOBUILD("RX"),0),PSOST0=+^PSRX(PSOBUILD("RX"),"STA"),$P(PSORX0,"^",15)=PSOST0
     43 G:PSOST0=13 GETX S PSORX2=$G(^PSRX(PSOBUILD("RX"),2))
     44 S PSORX3=$G(^PSRX(PSOBUILD("RX"),3)) S:PSORX3="" PSORX3=$P(PSORX2,"^",2)
     45 S PSODRG=+$P(PSORX0,"^",6) G:'$D(^PSDRUG(PSODRG,0)) GETX S PSODRUG0=^PSDRUG(PSODRG,0),PSOVACL=$P(PSODRUG0,"^",2),PSODYS=$P(PSORX0,"^",8)
     46 ;
     47 I PSOST0<12,PSOEXPDT<DT D:$P(PSORX0,"^",15)'=11
     48 .S PSOST0=11,$P(PSORX0,"^",15)=11 N DIE,DIC,DR,DA,PSOBEXDA S DIE=52,(DA,PSOBEXDA)=PSOBUILD("RX"),DR="100////11" D ^DIE K DIE,DIC,DR
     49 .D ECAN^PSOUTL(DA) K DA
     50 .S STAT="SC",PHARMST="ZE",COMM="Medication Expired on "_$E(PSOEXPDT,4,5)_"/"_$E(PSOEXPDT,6,7)_"/"_$E(PSOEXPDT,2,3) D EN^PSOHLSN1(PSOBEXDA,STAT,PHARMST,COMM) K COMM,STAT,PHARMST,PSOBEXDA
     51 I PSOST0=12,PSOEXPDT<DT S PSOST0=12
     52 I PSOST0=5 D  G GT1
     53 .I $O(^PS(52.5,"B",PSOBUILD("RX"),0)),'$D(^PS(52.5,+$O(^(0)),0)) D  Q
     54 ..S PSOST0=0 D FSTA
     55 ..K ^PS(52.5,"B",PSOBUILD("RX"),$O(^PS(52.5,"B",PSOBUILD("RX"),0)))
     56 .I '$O(^PS(52.5,"B",PSOBUILD("RX"),0)) S PSOST0=0 D FSTA
     57 I 'PSOST0 D STAT
     58GT1 G GETX:$D(NOEXP)&(PSOST0=11)
     59 I $D(^PSDRUG(PSODRG,"I")),^("I")]"",DT>^("I") S PSOSTN=PSOSTN_"A" I $P($G(PSOPAR),"^",11)']"" S PSOSTF=PSOSTF_"A"
     60 S PSONDF=$S($G(^PSDRUG(PSODRG,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)
     61 I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" S PSOSTN=PSOSTN_"M"
     62 S CLOZPT=$S($P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1":1,1:0)
     63 I 'CLOZPT,$P(PSODRUG0,"^",3)["A",$P(PSODRUG0,"^",3)'["B" S PSOSTN=PSOSTN_"B",PSOSTF=PSOSTF_"B"
     64 K CLOZPT I $P(PSODRUG0,"^",3)["W" S PSOSTN=PSOSTN_"C"
     65 I $D(^PS(53,+$P(PSORX0,"^",3),0)),'$P(^(0),"^",5) S PSOSTN=PSOSTN_"D"
     66 I PSOST0=1 S PSOSTN=PSOSTN_"E"
     67 S PSOLC=$P(PSORX0,"^"),PSOLC=$E(PSOLC,$L(PSOLC)) I $A(PSOLC)>90 S PSOSTN=PSOSTN_"F"
     68 I PSOST0,PSOST0'=2,PSOST0'=6 S PSOSTF=PSOSTF_"Z"
     69 I $G(PSORX("BAR CODE")),PSOST0,PSOST0'=2,PSOST0'=5,PSOST0'=6,PSOST0'=11,PSOST0'=12 S PSOSTN=PSOSTN_"Z" G BARC
     70 I PSOST0,PSOST0'=2,PSOST0'=5,PSOST0'=6,PSOST0'=11,PSOST0'=12,PSOST0'=14 S PSOSTN=PSOSTN_"Z"
     71BARC S PSORFRM=$P(PSORX0,"^",9) F PSOJ=0:0 S PSOJ=$O(^PSRX(PSOBUILD("RX"),1,PSOJ)) Q:'PSOJ  S PSORFRM=PSORFRM-1
     72 S:PSORFRM<0 PSORFRM=0 S:PSORFRM=0 PSOSTF=PSOSTF_"G"
     73 S PSODRUGN=$P(PSODRUG0,"^") I $D(PSOSD(PSODRUGN)),PSOST0>10 Q:$P(PSOSD(PSODRUGN),"^",2)<11  Q:$P(PSOSD(PSODRUGN),"^",2)>10&($P(PSORX0,"^",13)<$P(^PSRX(+$P(PSOSD(PSODRUGN),"^"),0),"^",13))
     74 S:'$D(PSOSD(PSODRUGN)) PSOBUILD("COUNT")=PSOBUILD("COUNT")+1
     75 I $D(PSOSD(PSODRUGN)),$P(PSOSD(PSODRUGN),"^",2)<10,PSOST0<10 S PSOSD(PSODRUGN_"^"_PSOBUILD("RX"))=PSOBUILD("RX")_"^"_PSOST0_"^"_PSOSTN_"^"_PSOSTF_"^"_PSOVACL_"^"_PSORFRM_"^"_PSONDF_"^"_PSODYS,PSOBUILD("COUNT")=PSOBUILD("COUNT")+1
     76 E  S PSOSD(PSODRUGN)=PSOBUILD("RX")_"^"_PSOST0_"^"_PSOSTN_"^"_PSOSTF_"^"_PSOVACL_"^"_PSORFRM_"^"_PSONDF_"^"_PSODYS
     77GETX Q
     78STAT N X S X=+$O(^PS(52.5,"B",PSOBUILD("RX"),0))
     79 I X,$D(^PS(52.5,X,0)),$P($G(^PS(52.5,X,0)),"^",7)'="X",'$G(^PS(52.5,X,"P")) S PSOST0=5
     80 I PSOST0 D FSTA
     81 Q
     82FSTA S $P(PSORX0,"^",15)=PSOST0
     83 N DIE,DR,DA S DIE=52,DA=PSOBUILD("RX"),DR="100////"_PSOST0 D ^DIE K DIE,DR,DA
     84 Q
     85 ;
     86EOJ K ORD,PSOX,PSOEXPDT,PSODRG,PSODRUG0,PSOLC,PSONDF,PSOQFLG,PSORFRM,PSORX0,PSORX2,PSORX3,PSOST0,PSOSTF,PSOSTN,PSOJ,PSODRUGN,PSOVACL,PSOBUILD,PSODYS,PEN,DRG,NON,NVA
     87 Q
     88INPAT(PSODFN) ;entry point for inpat meds to view patient's outpat. meds
     89 D FULL^VALM1
     90 S INPAT=1,X2=-120,X1=DT D C^%DTC S PSODTCUT=X D START,^PSODSPL
     91 K PSOSD,DDH,PSCNT,PSOCT,PSODD,PSOOI,PSOPAR,PSOSTA,STP,STR,PSODTCUT,PSODFN,INPAT,DRG
     92 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN2.m

    r613 r623  
    1 PSOCAN2 ;BHAM ISC/JMB - modular rx cancel with speed ability drug check ; 10/23/06 11:30am
    2         ;;7.0;OUTPATIENT PHARMACY;**8,18,62,46,88,164,235,148,259,281**;DEC 1997;Build 41
    3         ;External reference to ^PSDRUG supported by dbia 221
    4 REINS   N DODR
    5         I $P(^PSRX(DA,2),"^",6)<DT D  Q
    6         .S Y=$P(^PSRX(DA,2),"^",6) X ^DD("DD")
    7         .W !!,"Rx: "_$P(^PSRX(DA,0),"^")_" Drug: "_$S($D(^PSDRUG($P(^PSRX(DA,0),"^",6),0)):$P(^(0),"^"),1:""),!,"Expired "_Y_" and cannot be Reinstated!",!
    8         .D PAUSE^VALM1
    9         I $D(^PSRX("APSOD",$P(^PSRX(DA,0),"^",2),DA)) S PSCAN($P(^PSRX(DA,0),"^"))=DA_"^R",DODR=1 D AUTOD G ACT
    10         I $P(PSOPAR,"^",2),'$D(^XUSEC("PSORPH",DUZ)) D VERIFY D  D AREC^PSOCAN1 Q
    11         .S RX1=$P(^PSRX(DA,0),"^") S:'$D(PSCAN(RX1)) PSCAN(RX1)=DA_"^R" K RX1
    12 ACT     W ! F I=1:1:80 W "="
    13         D ^PSOBUILD S DRG=+$P(^PSRX(DA,0),"^",6),DRG=$S($D(^PSDRUG(DRG,0)):$P(^(0),"^"),1:""),HOLDRX=RX
    14         W !!,RX_"  "_DRG D DRGDRG S RX=HOLDRX K HOLDRX Q:$P(^PSRX(+PSCAN(RX),"STA"),"^")'=12!($G(PSORX("DFLG")))  S DA=+PSCAN(RX),REA=$P(PSCAN(RX),"^",2) D CAN^PSOCAN W !
    15         N RXIEN S RXIEN=DA
    16         ;Takes action on reinstated Rx's
    17         S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF  S RFCNT=RF
    18         S (LPRT,LREF)="" F LL=0:0 S LL=$O(^PSRX(DA,"L",LL)) Q:'LL  S LPRT=$P($G(^PSRX(DA,"L",LL,0)),"."),LREF=$P($G(^(0)),"^",2)
    19         I 'RFCNT S FDT=$S($P($G(^PSRX(DA,2)),"^",2)'="":$P($G(^PSRX(DA,2)),"^",2),1:$P($G(^PSRX(DA,2)),"^")) S RELDT=$P(^(2),"^",13),RELDT=$P(RELDT,".")
    20         I RFCNT S FDT=$P($G(^PSRX(DA,1,RFCNT,0)),"^"),RELDT=$P(^(0),"^",18),RELDT=$P(RELDT,".")
    21         S Y=FDT D DD^%DT S XFDT=Y I RELDT'="" S Y=RELDT D DD^%DT S XRELDT=Y
    22         I LPRT'="" S Y=LPRT D DD^%DT S XLPDT=Y
    23         ;If Rx was released, do nothing
    24         I RELDT'="" W !,RX_" Reinstated -- ",!?3,$S('RFCNT:"Filled",1:"Refilled # "_LREF)_": "_XFDT,?32,"Printed: "_$S(LREF=RFCNT:XLPDT,1:""),?56,"Released: "_$G(XRELDT) H 3 Q
    25         ;If Rx not released, check fill/refill date for action
    26         I $G(PSXSYS) D REINS^PSOCMOPA I $G(XFLAG) K XFLAG Q
    27         W !,"Prescription #"_RX_" REINSTATED!"
    28         ;
    29         I $$SUBMIT^PSOBPSUT(RXIEN) D
    30         . N ACTION
    31         . D ECMESND^PSOBPSU1(RXIEN,,,$S($O(^PSRX(RXIEN,1,0)):"RF",1:"OF"))
    32         . I $$FIND^PSOREJUT(RXIEN) S ACTION=$$HDLG^PSOREJU1(RXIEN,,"79,88","OF","IOQ","Q")
    33         ;
    34         W !?3,"Prescription #",RX," "
    35         I FDT<DT D
    36         .W $S('RFCNT:"Filled",1:"Refilled # "_LREF)_":  "_XFDT,?32,"Printed: "_$S(LREF=RFCNT:XLPDT,1:""),?56,"Released:"
    37         .S DIR("A")="     ** Do you want to print the label now",DIR("B")="N",DIR(0)="Y",DIR("?")="Enter 'Y' to print the label now.  If 'N' is entered, the label may be reprinted through reprint at a later date."
    38         .D ^DIR K DIR Q:$G(DIRUT)!('Y)  S PPL=DA D Q^PSORXL Q
    39         I FDT=DT W $S('RFCNT:"Filled",1:"Refilled # "_LREF)_": "_XFDT,?32,"Printed: "_$S(LREF=RFCNT:XLPDT,1:"")
    40         I  W ?56,"Released:",!?5,"Either print the label using the reprint option ",!?7,"or check later to see if the label has been printed." Q
    41         I FDT>DT W $S('RFCNT:"Filled",1:"Refilled # "_LREF)_": "_XFDT,?32,"Printed: "_$S(LREF=RFCNT:XLPDT,1:"")
    42         I  W ?56,"Released:" I '$G(DODR) W !?5,"Placing Rx on suspense.  Please wait..." D SUS
    43         K DODR
    44         Q
    45 SUS     ;Adds rec to suspense
    46         S ACT=1,RXN=DA,RX0=^PSRX(DA,0),RXS=$O(^PS(52.5,"B",DA,0)) I RXS S DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN
    47         S RXP=$S($D(RXP):RXP,1:0),DIC="^PS(52.5,",DIC(0)="L",X=RXN,DIC("DR")=".02///"_FDT_";.03///"_$P(RX0,"^",2)_";.04///M;.05///"_RXP_";.06////"_$G(PSOSITE)_";2///0" K DD,DO D FILE^DICN
    48         I +$G(Y),$G(RFCNT)'="" S $P(^PS(52.5,+Y,0),"^",13)=$G(RFCNT)
    49         S DA=RXN,$P(^PSRX(DA,"STA"),"^")=5,LFD=$E($P(^PSRX(DA,3),"^"),4,5)_"-"_$E($P(^(3),"^"),6,7)_"-"_$E($P(^(3),"^"),2,3)
    50         S ACOM="RX Placed on Suspense until "_LFD D AREC^PSOCAN1 S ST="SC",PHST="ZS" D EN^PSOHLSN1(DA,ST,PHST,ACOM) K ST,PHST
    51         Q
    52 DRGDRG  ;Checks for drug/drug interaction, duplicate drug and class
    53         Q:$P(^PSRX(DA,2),"^",6)<DT
    54         S STA="ACTIVE^NON-VERIFIED^R^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUED^^DISCONTINUED^DISCONTINUED^HOLD"
    55         S STAT=$P(STA,"^",$P(^PSRX(DA,"STA"),"^")+1)
    56         S X=$P(^PSRX(DA,0),"^",6),DIC="^PSDRUG(",DIC(0)="MZO" D ^DIC K DIC Q:$D(DTOUT)!(Y<0)
    57         K HOLD S NAME=$P(Y(0),"^") I +$G(PSOSD(STAT,NAME))=+PSCAN(RX) S HOLD(STAT,NAME)=$G(PSOSD(STAT,NAME)) K PSOSD(STAT,NAME)
    58         S:$G(PSONEW("OLD VAL"))=+Y PSODRG("QFLG")=1
    59         K PSOY S PSOY=Y,PSOY(0)=Y(0)
    60         S PSORENW("OIRXN")=DA D SET^PSODRG,POST^PSODRG S REA=$P(PSCAN($P(^PSRX(PSORENW("OIRXN"),0),"^")),"^",2)
    61         W ! S:$G(HOLD(STAT,NAME))]"" PSOSD(STAT,NAME)=$G(HOLD(STAT,NAME)) K HOLD,STA,STAT,PSORENW("OIRXN")
    62         Q
    63 VERIFY  ;Put in non-verify file
    64         S PSRXDA=DA,DIC="^PS(52.4,",DLAYGO=52.4,(X,DINUM)=PSRXDA,DIC(0)="ML",DIC("DR")="1////"_PSODFN_";2////"_DUZ_";4////"_DT
    65         K DD,DO D FILE^DICN K DIC,DLAYGO,DINUM
    66         S DA=PSRXDA S $P(^PSRX(DA,"STA"),"^")=1
    67         S ST="SC",PHST="IP",VCOM="Put in non-verified status" D EN^PSOHLSN1(DA,ST,PHST,VCOM) K ST,PHST,VCOM
    68         Q
    69 HLD     N PSDTEST,PDA,CMOP,SUSD I $P(^PSRX(DA,"STA"),"^")=3 D
    70         .S ACOM=$S(REA="C":"Discontinued",1:"Reinstated")_" while on hold during Rx cancel. " K:$P(^PSRX(DA,"H"),"^") ^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA) S ^PSRX(DA,"H")=""
    71         .I $P(^PSRX(DA,0),"^",13),'$O(^PSRX(DA,1,0)) S DIE=52,DR="22///"_$E($P(^PSRX(DA,0),"^",13),1,7) D ^DIE K DIE,DR Q
    72         .S (IFN,SUSD)=0 F  S IFN=$O(^PSRX(DA,1,IFN)) Q:'IFN  S SUSD=IFN,RFDT=$P(^PSRX(DA,1,IFN,0),"^")
    73         .Q:'$G(SUSD)  I '$P(^PSRX(DA,1,SUSD,0),"^",18) S PSDTEST=0 D  I 'PSDTEST K ^PSRX(DA,1,SUSD),^PSRX("AD",RFDT,DA,SUSD),^PSRX(DA,1,"B",RFDT,SUSD),IFN,SUSD,RFDT
    74         ..F PDA=0:0 S PDA=$O(^PSRX(DA,"L",PDA)) Q:'PDA  I $P($G(^PSRX(DA,"L",PDA,0)),"^",2)=SUSD S PSDTEST=1
    75         ..K CMOP D ^PSOCMOPA I $G(CMOP(CMOP("L")))="",$G(CMOP("S"))'="L" Q
    76         ..S PSDTEST=1
    77         Q
    78 REF     S IFN=0 F  S IFN=$O(^PSRX(DA,1,IFN)) Q:'IFN  I $P($G(^PSRX(DA,1,IFN,0)),"^")=SUSD,'$P(^(0),"^",18) D
    79         .D DELREF I $G(PSORFDEL) K PSORFDEL Q
    80         .;PSO*7*259;CHECK IF REFILL RELEASED OR LABEL PRINTED
    81         .I $P($G(^PSRX(DA,1,IFN,0)),"^",18)]"" Q  ;REFILL RELEASED
    82         .N PSONODEL,PSOLBL S PSONODEL=0
    83         .I $P(^PSRX(DA,"STA"),"^")=5 D REF^PSOCAN4 Q:PSONODEL
    84         .S PSOLBL="" F  S PSOLBL=$O(^PSRX(DA,"L",PSOLBL),-1) Q:'PSOLBL  Q:PSONODEL  Q:$P(^PSRX(DA,"L",PSOLBL,0),"^",2)<IFN  I $P(^PSRX(DA,"L",PSOLBL,0),"^",2)=IFN S PSONODEL=1
    85         .Q:PSONODEL
    86         .K PSORFDEL K ^PSRX(DA,1,IFN),^PSRX("AD",SUSD,DA,IFN),^PSRX(DA,1,"B",SUSD,IFN)
    87         .S $P(^PSRX(DA,1,0),"^",4)=$P(^PSRX(DA,1,0),"^",4)-1,DA(1)=DA
    88         .S NODE=0 D SPR^PSOUTL K DA(1),RF,NODE
    89         S IFN=0 F  S IFN=$O(^PSRX(DA,1,IFN)) Q:'IFN  I '$O(^PSRX(DA,1,IFN)) S $P(^PSRX(DA,3),"^")=+$P(^PSRX(DA,1,IFN,0),"^"),$P(^(3),"^",2)=SUSD
    90         I '$O(^PSRX(DA,1,0)) S $P(^PSRX(DA,3),"^")=$P(^PSRX(DA,2),"^",2),$P(^PSRX(DA,3),"^",2)=SUSD
    91         K IFN,SUSD
    92         Q
    93 KILL    K %,ACNT,ACOM,ACT,ALL,BCNUM,CMOP,CNT,DA,DAYS360,DEAD,DRG,DIRUT,DR,DRUG,DTOUT,DUOUT,FDT,HOLD,I,II,IN,IT,JJ,LC,LFD,LINE,LL,LPRT,LREF,LSI,NAME,NDF,NOEXP,NSF,OUT,RXSP,EN,WARN K:'$G(POERR) INCOM
    94         K PSODRUG,PCNT,POP,PPL,PS,PSFROM,PSINV,PLINE,PSI,PSINV,PSOCAN,PSOCMOP,PSODFN,PSODRG,PSOOPT,PSOSD,PSPOP,PSRXDA,PSS,PSVC,PSONOOR
    95         K REA,RELDT,RF,RFDATE,RFCNT,RFL,RFL1,RFLL,RP,RX,RX0,RXCNT,RXDA,RXN,RXNUM,RXP,RXREC,RXREF,RXS,SDATE,SPCANC,SS,STAT,SUB,X,XFDT,XLPDT,XRELDT,Y D KVA^VADPT Q
    96 DELREF  ;
    97         N RDL,PSCNODE
    98         S PSORFDEL=0
    99         F RDL=0:0 S RDL=$O(^PSRX(DA,4,RDL)) Q:'RDL  I $G(IFN)=$P($G(^PSRX(DA,4,RDL,0)),"^",3) S PSCNODE=$G(^(0))
    100         I $G(PSCNODE)="" Q
    101         I +$P(PSCNODE,"^",4)<3 S PSORFDEL=1
    102         Q
    103 AUTOD   ;reinstates Rxs dc'd by date of death
    104         I $G(^PSRX(DA,"DDSTA"))']"" K ^PSRX("APSOD",+$P(^PSRX(DA,0),"^",2),DA),DODR Q
    105         S DODS=$P(^PSRX(DA,"DDSTA"),"^"),DODD=$P(^("DDSTA"),"^",2,245)
    106         S FILE=$P(DODS,";"),STA=$P(DODS,";",2)
    107         I FILE=52.4 D  Q
    108         .S RXN=DA,^PS(52.4,DA,0)=DODD,DIK="^PS(52.4," D IX^DIK K DIK,DA S DA=RXN,$P(^PSRX(DA,"STA"),"^")=STA
    109         .S ST="SC",PHST="IP",ACOM="Date of Death Deleted. Returned to Non-Verified status."
    110         .K ^PSRX("APSOD",$P(^PSRX(DA,0),"^",2),DA),^PSRX(DA,"DDSTA")
    111         .S DA=RXN D LOG D EN^PSOHLSN1(DA,ST,PHST,ACOM) K ST,PHST,ACOM,RXN
    112         I FILE=52.5 D  Q
    113         .;Adds rec to suspense
    114         .S RXN=DA,RXS=$O(^PS(52.5,"B",DA,0)) I RXS S DA=RXS,DIK="^PS(52.5," D ^DIK
    115         .S DIC="^PS(52.5,",DIC(0)="L",X=RXN K DD,DO D FILE^DICN S DA=+Y
    116         .S ^PS(52.5,DA,0)=DODD,^PS(52.5,DA,"P")=0,LFD=$E($P(^PS(52.5,DA,0),"^",2),4,5)_"-"_$E($P(^(0),"^",2),6,7)_"-"_$E($P(^(0),"^",2),2,3)
    117         .S DIK="^PS(52.5," D IX^DIK K DIK,DA S DA=RXN,$P(^PSRX(DA,"STA"),"^")=STA
    118         .S ACOM="Date of Death Deleted. RX Placed on Suspense until "_LFD
    119         .K ^PSRX("APSOD",PSODFN,DA),^PSRX(DA,"DDSTA")
    120         .I STA=5 S ST="SC",PHST="ZS" D LOG D EN^PSOHLSN1(DA,ST,PHST,ACOM) K ST,PHST,ACOM,LFD
    121         I FILE=52 S ^PSRX(DA,"STA")=STA I STA=3!(STA=16) D  Q
    122         .S ^PSRX(DA,"H")=DODD,^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA)=""
    123         .S ACOM="Date of Death Deleted. Medication Returned to"_$S(STA=16:" Provider",1:"")_" Hold Status "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)_"."
    124         .D LOG,EN^PSOHLSN1(DA,"OH","",ACOM) K ACOM
    125         .K ^PSRX("APSOD",PSODFN,DA),^PSRX(DA,"DDSTA")
    126         S ACOM="Date of Death Deleted. Prescription Reinstated." D EN^PSOHLSN1(DA,"SC","CM",ACOM),LOG K ACOM
    127         Q
    128 LOG     K ACNT F SUB=0:0 S SUB=$O(^PSRX(DA,"A",SUB)) Q:'SUB  S ACNT=$G(ACNT)+1
    129         S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF  S RFCNT=$G(RFCNT)+1 S:RF>5 RFCNT=$G(RFCNT)+1
    130         S ACNT=$G(ACNT)+1
    131         D NOW^%DTC S ^PSRX(DA,"A",0)="^52.3DA^"_ACNT_"^"_ACNT S ^PSRX(DA,"A",ACNT,0)=%_"^R^"_DUZ_"^"_RFCNT_"^"_ACOM
    132         K ^PSRX("APSOD",PSODFN,DA),ACNT,RFCNT,RF,%
    133         S $P(^PSRX(DA,3),"^")=$P(^PSRX(DA,3),"^",5),$P(^(3),"^",2)=$P(^(3),"^",8)
    134         S $P(^PSRX(DA,3),"^",5)="",$P(^(3),"^",8)=""
    135         Q
    136 NVER    ;Called from PSOCAN3, needs DA defined
    137         N PSONVC,PSONVCP,PSONVCC
    138         S PSONVC="SC",PSONVCP="IP",PSONVCC="Put in non-verified status" D EN^PSOHLSN1(DA,PSONVC,PSONVCP,PSONVCC)
    139         Q
    140 RMB(IDX)        ;remove Rx if found in array BBRX() (Bingo Board)
    141         N ST4,ST5,ST6,K
    142         S ST4=BBRX(IDX) Q:ST4'[(DA_",")
    143         S ST6=""
    144         F K=1:1 S ST5=$P(ST4,",",K) Q:'ST5  D
    145         . S:ST5'=DA ST6=ST6_$S('ST6:"",1:",")_ST5
    146         . S:ST6]"" BBRX(IDX)=ST6_"," K:ST6="" BBRX(IDX)
    147         I '$D(BBRX) K BINGCRT
    148         Q
     1PSOCAN2 ;BHAM ISC/JMB - modular rx cancel with speed ability drug check ; 10/23/06 11:30am
     2 ;;7.0;OUTPATIENT PHARMACY;**8,18,62,46,88,164,235,148,259**;DEC 1997;Build 5
     3 ;External reference to ^PSDRUG supported by dbia 221
     4REINS N DODR
     5 I $P(^PSRX(DA,2),"^",6)<DT D  Q
     6 .S Y=$P(^PSRX(DA,2),"^",6) X ^DD("DD")
     7 .W !!,"Rx: "_$P(^PSRX(DA,0),"^")_" Drug: "_$S($D(^PSDRUG($P(^PSRX(DA,0),"^",6),0)):$P(^(0),"^"),1:""),!,"Expired "_Y_" and cannot be Reinstated!",!
     8 .D PAUSE^VALM1
     9 I $D(^PSRX("APSOD",$P(^PSRX(DA,0),"^",2),DA)) S PSCAN($P(^PSRX(DA,0),"^"))=DA_"^R",DODR=1 D AUTOD G ACT
     10 I $P(PSOPAR,"^",2),'$D(^XUSEC("PSORPH",DUZ)) D VERIFY D  D AREC^PSOCAN1 Q
     11 .S RX1=$P(^PSRX(DA,0),"^") S:'$D(PSCAN(RX1)) PSCAN(RX1)=DA_"^R" K RX1
     12ACT W ! F I=1:1:80 W "="
     13 D ^PSOBUILD S DRG=+$P(^PSRX(DA,0),"^",6),DRG=$S($D(^PSDRUG(DRG,0)):$P(^(0),"^"),1:""),HOLDRX=RX
     14 W !!,RX_"  "_DRG D DRGDRG S RX=HOLDRX K HOLDRX Q:$P(^PSRX(+PSCAN(RX),"STA"),"^")'=12!($G(PSORX("DFLG")))  S DA=+PSCAN(RX),REA=$P(PSCAN(RX),"^",2) D CAN^PSOCAN W !
     15 N RXIEN S RXIEN=DA
     16 ;Takes action on reinstated Rx's
     17 S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF  S RFCNT=RF
     18 S (LPRT,LREF)="" F LL=0:0 S LL=$O(^PSRX(DA,"L",LL)) Q:'LL  S LPRT=$P($G(^PSRX(DA,"L",LL,0)),"."),LREF=$P($G(^(0)),"^",2)
     19 I 'RFCNT S FDT=$S($P($G(^PSRX(DA,2)),"^",2)'="":$P($G(^PSRX(DA,2)),"^",2),1:$P($G(^PSRX(DA,2)),"^")) S RELDT=$P(^(2),"^",13),RELDT=$P(RELDT,".")
     20 I RFCNT S FDT=$P($G(^PSRX(DA,1,RFCNT,0)),"^"),RELDT=$P(^(0),"^",18),RELDT=$P(RELDT,".")
     21 S Y=FDT D DD^%DT S XFDT=Y I RELDT'="" S Y=RELDT D DD^%DT S XRELDT=Y
     22 I LPRT'="" S Y=LPRT D DD^%DT S XLPDT=Y
     23 ;If Rx was released, do nothing
     24 I RELDT'="" W !,RX_" Reinstated -- ",!?3,$S('RFCNT:"Filled",1:"Refilled # "_LREF)_": "_XFDT,?32,"Printed: "_$S(LREF=RFCNT:XLPDT,1:""),?56,"Released: "_$G(XRELDT) H 3 Q
     25 ;If Rx not released, check fill/refill date for action
     26 I $G(PSXSYS) D REINS^PSOCMOPA I $G(XFLAG) K XFLAG Q
     27 W !,"Prescription #"_RX_" REINSTATED!"
     28 ;
     29 I $$SUBMIT^PSOBPSUT(RXIEN) D
     30 . N ACTION
     31 . D ECMESND^PSOBPSU1(RXIEN,,,$S($O(^PSRX(RXIEN,1,0)):"RF",1:"OF"))
     32 . I $$FIND^PSOREJUT(RXIEN) S ACTION=$$HDLG^PSOREJU1(RXIEN,,"79,88","OF","IOQ","I")
     33 ;
     34 W !?3,"Prescription #",RX," "
     35 I FDT<DT D
     36 .W $S('RFCNT:"Filled",1:"Refilled # "_LREF)_":  "_XFDT,?32,"Printed: "_$S(LREF=RFCNT:XLPDT,1:""),?56,"Released:"
     37 .S DIR("A")="     ** Do you want to print the label now",DIR("B")="N",DIR(0)="Y",DIR("?")="Enter 'Y' to print the label now.  If 'N' is entered, the label may be reprinted through reprint at a later date."
     38 .D ^DIR K DIR Q:$G(DIRUT)!('Y)  S PPL=DA D Q^PSORXL Q
     39 I FDT=DT W $S('RFCNT:"Filled",1:"Refilled # "_LREF)_": "_XFDT,?32,"Printed: "_$S(LREF=RFCNT:XLPDT,1:"")
     40 I  W ?56,"Released:",!?5,"Either print the label using the reprint option ",!?7,"or check later to see if the label has been printed." Q
     41 I FDT>DT W $S('RFCNT:"Filled",1:"Refilled # "_LREF)_": "_XFDT,?32,"Printed: "_$S(LREF=RFCNT:XLPDT,1:"")
     42 I  W ?56,"Released:" I '$G(DODR) W !?5,"Placing Rx on suspense.  Please wait..." D SUS
     43 K DODR
     44 Q
     45SUS ;Adds rec to suspense
     46 S ACT=1,RXN=DA,RX0=^PSRX(DA,0),RXS=$O(^PS(52.5,"B",DA,0)) I RXS S DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN
     47 S RXP=$S($D(RXP):RXP,1:0),DIC="^PS(52.5,",DIC(0)="L",X=RXN,DIC("DR")=".02///"_FDT_";.03///"_$P(RX0,"^",2)_";.04///M;.05///"_RXP_";.06////"_$G(PSOSITE)_";2///0" K DD,DO D FILE^DICN
     48 I +$G(Y),$G(RFCNT)'="" S $P(^PS(52.5,+Y,0),"^",13)=$G(RFCNT)
     49 S DA=RXN,$P(^PSRX(DA,"STA"),"^")=5,LFD=$E($P(^PSRX(DA,3),"^"),4,5)_"-"_$E($P(^(3),"^"),6,7)_"-"_$E($P(^(3),"^"),2,3)
     50 S ACOM="RX Placed on Suspense until "_LFD D AREC^PSOCAN1 S ST="SC",PHST="ZS" D EN^PSOHLSN1(DA,ST,PHST,ACOM) K ST,PHST
     51 Q
     52DRGDRG ;Checks for drug/drug interaction, duplicate drug and class
     53 Q:$P(^PSRX(DA,2),"^",6)<DT
     54 S STA="ACTIVE^NON-VERIFIED^R^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUED^^DISCONTINUED^DISCONTINUED^HOLD"
     55 S STAT=$P(STA,"^",$P(^PSRX(DA,"STA"),"^")+1)
     56 S X=$P(^PSRX(DA,0),"^",6),DIC="^PSDRUG(",DIC(0)="MZO" D ^DIC K DIC Q:$D(DTOUT)!(Y<0)
     57 K HOLD S NAME=$P(Y(0),"^") I +$G(PSOSD(STAT,NAME))=+PSCAN(RX) S HOLD(STAT,NAME)=$G(PSOSD(STAT,NAME)) K PSOSD(STAT,NAME)
     58 S:$G(PSONEW("OLD VAL"))=+Y PSODRG("QFLG")=1
     59 K PSOY S PSOY=Y,PSOY(0)=Y(0)
     60 S PSORENW("OIRXN")=DA D SET^PSODRG,POST^PSODRG S REA=$P(PSCAN($P(^PSRX(PSORENW("OIRXN"),0),"^")),"^",2)
     61 W ! S:$G(HOLD(STAT,NAME))]"" PSOSD(STAT,NAME)=$G(HOLD(STAT,NAME)) K HOLD,STA,STAT,PSORENW("OIRXN")
     62 Q
     63VERIFY ;Put in non-verify file
     64 S PSRXDA=DA,DIC="^PS(52.4,",DLAYGO=52.4,(X,DINUM)=PSRXDA,DIC(0)="ML",DIC("DR")="1////"_PSODFN_";2////"_DUZ_";4////"_DT
     65 K DD,DO D FILE^DICN K DIC,DLAYGO,DINUM
     66 S DA=PSRXDA S $P(^PSRX(DA,"STA"),"^")=1
     67 S ST="SC",PHST="IP",VCOM="Put in non-verified status" D EN^PSOHLSN1(DA,ST,PHST,VCOM) K ST,PHST,VCOM
     68 Q
     69HLD N PSDTEST,PDA,CMOP,SUSD I $P(^PSRX(DA,"STA"),"^")=3 D
     70 .S ACOM=$S(REA="C":"Discontinued",1:"Reinstated")_" while on hold during Rx cancel. " K:$P(^PSRX(DA,"H"),"^") ^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA) S ^PSRX(DA,"H")=""
     71 .I $P(^PSRX(DA,0),"^",13),'$O(^PSRX(DA,1,0)) S DIE=52,DR="22///"_$E($P(^PSRX(DA,0),"^",13),1,7) D ^DIE K DIE,DR Q
     72 .S (IFN,SUSD)=0 F  S IFN=$O(^PSRX(DA,1,IFN)) Q:'IFN  S SUSD=IFN,RFDT=$P(^PSRX(DA,1,IFN,0),"^")
     73 .Q:'$G(SUSD)  I '$P(^PSRX(DA,1,SUSD,0),"^",18) S PSDTEST=0 D  I 'PSDTEST K ^PSRX(DA,1,SUSD),^PSRX("AD",RFDT,DA,SUSD),^PSRX(DA,1,"B",RFDT,SUSD),IFN,SUSD,RFDT
     74 ..F PDA=0:0 S PDA=$O(^PSRX(DA,"L",PDA)) Q:'PDA  I $P($G(^PSRX(DA,"L",PDA,0)),"^",2)=SUSD S PSDTEST=1
     75 ..K CMOP D ^PSOCMOPA I $G(CMOP(CMOP("L")))="",$G(CMOP("S"))'="L" Q
     76 ..S PSDTEST=1
     77 Q
     78REF S IFN=0 F  S IFN=$O(^PSRX(DA,1,IFN)) Q:'IFN  I $P($G(^PSRX(DA,1,IFN,0)),"^")=SUSD,'$P(^(0),"^",18) D
     79 .D DELREF I $G(PSORFDEL) K PSORFDEL Q
     80 .;PSO*7*259;CHECK IF REFILL RELEASED OR LABEL PRINTED
     81 .I $P($G(^PSRX(DA,1,IFN,0)),"^",18)]"" Q  ;REFILL RELEASED
     82 .N PSONODEL,PSOLBL S PSONODEL=0
     83 .I $P(^PSRX(DA,"STA"),"^")=5 D REF^PSOCAN4 Q:PSONODEL
     84 .S PSOLBL="" F  S PSOLBL=$O(^PSRX(DA,"L",PSOLBL),-1) Q:'PSOLBL  Q:PSONODEL  Q:$P(^PSRX(DA,"L",PSOLBL,0),"^",2)<IFN  I $P(^PSRX(DA,"L",PSOLBL,0),"^",2)=IFN S PSONODEL=1
     85 .Q:PSONODEL
     86 .K PSORFDEL K ^PSRX(DA,1,IFN),^PSRX("AD",SUSD,DA,IFN),^PSRX(DA,1,"B",SUSD,IFN)
     87 .S $P(^PSRX(DA,1,0),"^",4)=$P(^PSRX(DA,1,0),"^",4)-1,DA(1)=DA
     88 .S NODE=0 D SPR^PSOUTL K DA(1),RF,NODE
     89 S IFN=0 F  S IFN=$O(^PSRX(DA,1,IFN)) Q:'IFN  I '$O(^PSRX(DA,1,IFN)) S $P(^PSRX(DA,3),"^")=+$P(^PSRX(DA,1,IFN,0),"^"),$P(^(3),"^",2)=SUSD
     90 I '$O(^PSRX(DA,1,0)) S $P(^PSRX(DA,3),"^")=$P(^PSRX(DA,2),"^",2),$P(^PSRX(DA,3),"^",2)=SUSD
     91 K IFN,SUSD
     92 Q
     93KILL K %,ACNT,ACOM,ACT,ALL,BCNUM,CMOP,CNT,DA,DAYS360,DEAD,DRG,DIRUT,DR,DRUG,DTOUT,DUOUT,FDT,HOLD,I,II,IN,IT,JJ,LC,LFD,LINE,LL,LPRT,LREF,LSI,NAME,NDF,NOEXP,NSF,OUT,RXSP,EN,WARN K:'$G(POERR) INCOM
     94 K PSODRUG,PCNT,POP,PPL,PS,PSFROM,PSINV,PLINE,PSI,PSINV,PSOCAN,PSOCMOP,PSODFN,PSODRG,PSOOPT,PSOSD,PSPOP,PSRXDA,PSS,PSVC,PSONOOR
     95 K REA,RELDT,RF,RFDATE,RFCNT,RFL,RFL1,RFLL,RP,RX,RX0,RXCNT,RXDA,RXN,RXNUM,RXP,RXREC,RXREF,RXS,SDATE,SPCANC,SS,STAT,SUB,X,XFDT,XLPDT,XRELDT,Y D KVA^VADPT Q
     96DELREF ;
     97 N RDL,PSCNODE
     98 S PSORFDEL=0
     99 F RDL=0:0 S RDL=$O(^PSRX(DA,4,RDL)) Q:'RDL  I $G(IFN)=$P($G(^PSRX(DA,4,RDL,0)),"^",3) S PSCNODE=$G(^(0))
     100 I $G(PSCNODE)="" Q
     101 I +$P(PSCNODE,"^",4)<3 S PSORFDEL=1
     102 Q
     103AUTOD ;reinstates Rxs dc'd by date of death
     104 I $G(^PSRX(DA,"DDSTA"))']"" K ^PSRX("APSOD",+$P(^PSRX(DA,0),"^",2),DA),DODR Q
     105 S DODS=$P(^PSRX(DA,"DDSTA"),"^"),DODD=$P(^("DDSTA"),"^",2,245)
     106 S FILE=$P(DODS,";"),STA=$P(DODS,";",2)
     107 I FILE=52.4 D  Q
     108 .S RXN=DA,^PS(52.4,DA,0)=DODD,DIK="^PS(52.4," D IX^DIK K DIK,DA S DA=RXN,$P(^PSRX(DA,"STA"),"^")=STA
     109 .S ST="SC",PHST="IP",ACOM="Date of Death Deleted. Returned to Non-Verified status."
     110 .K ^PSRX("APSOD",$P(^PSRX(DA,0),"^",2),DA),^PSRX(DA,"DDSTA")
     111 .S DA=RXN D LOG D EN^PSOHLSN1(DA,ST,PHST,ACOM) K ST,PHST,ACOM,RXN
     112 I FILE=52.5 D  Q
     113 .;Adds rec to suspense
     114 .S RXN=DA,RXS=$O(^PS(52.5,"B",DA,0)) I RXS S DA=RXS,DIK="^PS(52.5," D ^DIK
     115 .S DIC="^PS(52.5,",DIC(0)="L",X=RXN K DD,DO D FILE^DICN S DA=+Y
     116 .S ^PS(52.5,DA,0)=DODD,^PS(52.5,DA,"P")=0,LFD=$E($P(^PS(52.5,DA,0),"^",2),4,5)_"-"_$E($P(^(0),"^",2),6,7)_"-"_$E($P(^(0),"^",2),2,3)
     117 .S DIK="^PS(52.5," D IX^DIK K DIK,DA S DA=RXN,$P(^PSRX(DA,"STA"),"^")=STA
     118 .S ACOM="Date of Death Deleted. RX Placed on Suspense until "_LFD
     119 .K ^PSRX("APSOD",PSODFN,DA),^PSRX(DA,"DDSTA")
     120 .I STA=5 S ST="SC",PHST="ZS" D LOG D EN^PSOHLSN1(DA,ST,PHST,ACOM) K ST,PHST,ACOM,LFD
     121 I FILE=52 S ^PSRX(DA,"STA")=STA I STA=3!(STA=16) D  Q
     122 .S ^PSRX(DA,"H")=DODD,^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA)=""
     123 .S ACOM="Date of Death Deleted. Medication Returned to"_$S(STA=16:" Provider",1:"")_" Hold Status "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)_"."
     124 .D LOG,EN^PSOHLSN1(DA,"OH","",ACOM) K ACOM
     125 .K ^PSRX("APSOD",PSODFN,DA),^PSRX(DA,"DDSTA")
     126 S ACOM="Date of Death Deleted. Prescription Reinstated." D EN^PSOHLSN1(DA,"SC","CM",ACOM),LOG K ACOM
     127 Q
     128LOG K ACNT F SUB=0:0 S SUB=$O(^PSRX(DA,"A",SUB)) Q:'SUB  S ACNT=$G(ACNT)+1
     129 S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF  S RFCNT=$G(RFCNT)+1 S:RF>5 RFCNT=$G(RFCNT)+1
     130 S ACNT=$G(ACNT)+1
     131 D NOW^%DTC S ^PSRX(DA,"A",0)="^52.3DA^"_ACNT_"^"_ACNT S ^PSRX(DA,"A",ACNT,0)=%_"^R^"_DUZ_"^"_RFCNT_"^"_ACOM
     132 K ^PSRX("APSOD",PSODFN,DA),ACNT,RFCNT,RF,%
     133 S $P(^PSRX(DA,3),"^")=$P(^PSRX(DA,3),"^",5),$P(^(3),"^",2)=$P(^(3),"^",8)
     134 S $P(^PSRX(DA,3),"^",5)="",$P(^(3),"^",8)=""
     135 Q
     136NVER ;Called from PSOCAN3, needs DA defined
     137 N PSONVC,PSONVCP,PSONVCC
     138 S PSONVC="SC",PSONVCP="IP",PSONVCC="Put in non-verified status" D EN^PSOHLSN1(DA,PSONVC,PSONVCP,PSONVCC)
     139 Q
     140RMB(IDX) ;remove Rx if found in array BBRX() (Bingo Board)
     141 N ST4,ST5,ST6,K
     142 S ST4=BBRX(IDX) Q:ST4'[(DA_",")
     143 S ST6=""
     144 F K=1:1 S ST5=$P(ST4,",",K) Q:'ST5  D
     145 . S:ST5'=DA ST6=ST6_$S('ST6:"",1:",")_ST5
     146 . S:ST6]"" BBRX(IDX)=ST6_"," K:ST6="" BBRX(IDX)
     147 I '$D(BBRX) K BINGCRT
     148 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN3.m

    r613 r623  
    1 PSOCAN3 ;BIR/RTR/SAB - auto dc rxs due to death ;9/18/06 2:59pm
    2         ;;7.0;OUTPATIENT PHARMACY;**15,24,27,32,36,94,88,117,131,146,139,132,223,235,148,249,225**;DEC 1997;Build 29
    3         ;External reference to File #55 supported by DBIA 2228
    4         ;External references to L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
    5         Q
    6 APSOD(PSODFN)   ;called from file #2 date of death xref 'APOSD'
    7         N D,DA,DB,DC,DE,DG,DH,DI,DIC,DIE,DIG,DIH,DIK,DIR,DIQ,DIU,DIV,DIW,DK,DL,DM,DP,DQ,DU,DV,DW,DR
    8         S PSODEATH=1 D CAN K PSODEATH
    9         Q
    10 CAN     ;discontinued rxs due to death
    11         I $G(PSODFN),$D(^PS(52.91,PSODFN,0)) D
    12         .I '$P($G(^PS(52.91,PSODFN,0)),"^",3)!($P($G(^(0)),"^",3)>DT) S $P(^PS(52.91,PSODFN,0),"^",3)=DT,$P(^PS(52.91,PSODFN,0),"^",4)=5,^PS(52.91,"AX",DT,PSODFN)="" D SET^PSOTPCAN(PSODFN)
    13         F PSORXJ=0:0 S PSORXJ=$O(^PS(55,PSODFN,"P",PSORXJ)) Q:'PSORXJ  I $D(^(PSORXJ,0)) S PSORX=^(0) S STA=$S($P($G(^PSRX(PSORX,"STA")),"^")<11:1,$P($G(^("STA")),"^")=16:1,1:0) D:STA
    14         .I $D(^PSRX(PSORX,0)),$P($G(^PSRX(PSORX,"STA")),"^")="" D SETC
    15         .D REVERSE^PSOBPSU1(PSORX,,"DC",7)
    16         .I $D(^PSRX(PSORX,0)),$P($G(^PSRX(PSORX,2)),"^",6)'<DT S PSO0=^(0),PSO2=$G(^(2)) D
    17         ..S ^PSRX(PSORX,"DDSTA")="52;"_$P(^PSRX(PSORX,"STA"),"^")
    18         ..;remove from hold
    19         ..I $G(^PSRX(PSORX,"H"))]"" D
    20         ...S ^PSRX(PSORX,"DDSTA")="52;"_$P(^PSRX(PSORX,"STA"),"^")_"^"_^PSRX(PSORX,"H")
    21         ...K:$P(^PSRX(PSORX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSORX,"H"),"^"),PSORX) S ^PSRX(PSORX,"H")=""
    22         ...I '$P($G(^PSRX(PSORX,2)),"^",2),$P($G(^(3)),"^") S $P(^PSRX(PSORX,2),"^",2)=$P(^(3),"^")
    23         ...I $G(PSODEATH),$P(^PSRX(PSORX,0),"^",2) S ^PSRX("APSOD",$P(^PSRX(PSORX,0),"^",2),PSORX)=""
    24         ..;delete from non-verified file
    25         ..I $G(^PS(52.4,PSORX,0))]"" S ^PSRX(PSORX,"DDSTA")="52.4;"_$P(^PSRX(PSORX,"STA"),"^")_"^"_^PS(52.4,PSORX,0),DIK="^PS(52.4,",DA=PSORX D ^DIK K DIK
    26         ..I $G(PSODEATH),$P(^PSRX(PSORX,0),"^",2) S ^PSRX("APSOD",$P(^PSRX(PSORX,0),"^",2),PSORX)=""
    27         ..;delete from suspense
    28         ..D:$O(^PS(52.5,"B",PSORX,0))
    29         ...S DA=$O(^PS(52.5,"B",PSORX,0)) I '$G(^PS(52.5,DA,"P")),$G(PSODEATH) S ^PSRX(PSORX,"DDSTA")="52.5;5^"_^PS(52.5,DA,0),^PSRX("APSOD",$P(^PSRX(PSORX,0),"^",2),PSORX)=""
    30         ...I $O(^PSRX(PSORX,1,0)),'$G(PSODEATH) S DA=PSORX,SUSD=$P($G(^PS(52.5,$O(^PS(52.5,"B",PSORX,0)),0)),"^",2) D:'$G(^PS(52.5,$O(^PS(52.5,"B",PSORX,0)),"P")) REF^PSOCAN2
    31         ...S DA=$O(^PS(52.5,"B",PSORX,0)),DIK="^PS(52.5," D ^DIK K DIK
    32         ..D SETC
    33         ..;activity record
    34         ..S (COM,ACOM)=$S($G(PSODEATH):"Date of Death Entered by MAS",1:"Discontinued by Pharmacy")_"."
    35         ..S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(PSORX,"A",SUB)) Q:'SUB  S ACNT=SUB
    36         ..S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(PSORX,1,RF)) Q:'RF  S RFCNT=RF
    37         ..D NOW^%DTC S ACNT=ACNT+1,^PSRX(PSORX,"A",0)="^52.3DA^"_ACNT_"^"_ACNT
    38         ..S ^PSRX(PSORX,"A",ACNT,0)=%_"^"_"C"_"^^"_RFCNT_"^"_"Auto Discontinued Due to Death. "_ACOM
    39         ..;check for label/release/pending release
    40         ..D FIL
    41         ..S STAT="OD",PHARMST="" D EN^PSOHLSN1(PSORX,STAT,PHARMST,COM,"A") K COMM,PHARMST,STAT
    42         ;dc pending orders
    43         F PDA=0:0 S PDA=$O(^PS(52.41,"P",PSODFN,PDA)) Q:'PDA  I $P(^PS(52.41,PDA,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") D
    44         .I $G(PSODEATH) D
    45         ..S ^PS(52.41,PDA,"DDSTA")=$P(^PS(52.41,PDA,0),"^",3)_";"_+$P($G(^PS(52.41,PDA,"INI")),"^"),^PS(52.41,"APSOD",PSODFN,PDA)=""
    46         ..S $P(^PS(52.41,PDA,4),"^")="Date of Death Entered by MAS."
    47         .S $P(^PS(52.41,PDA,0),"^",3)="DC"
    48         .K ^PS(52.41,"AOR",PSODFN,+$P($G(^PS(52.41,PDA,"INI")),"^"),PDA)
    49         .S COM=$S($G(PSODEATH):"Date of Death Entered by MAS.",1:""),PL=$P(^PS(52.41,PDA,0),"^"),$P(^(0),"^",3)="DC"
    50         .D EN^PSOHLSN(PL,"OC",COM,"A") K COM,PL
    51         ;dc non-va meds
    52         D APSOD^PSONVNEW
    53 KILL    K %,%H,%T,ACNT,DA,PDA,DIRUT,DTOUT,PSO,PSO0,PSO2,PSOD,PSOD0,PSODFN,PSODL,PSORX,PSORXJ,PSOSD,RF,RFCNT,SUB,TM,TSKDT,X,X1,X2,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
    54         D KVAR^VADPT S:$D(ZTQUEUED) ZTREQ="@"
    55         Q
    56 CAN1    Q:$G(DODR)
    57         S PSOMGDFN=$G(PSODFN) ; SAVE IN CASE CANCELING RX THAT WAS MERGED TO ANOTHER DFN
    58         I $G(^PSRX(DA,"H"))]"" D HLD^PSOCAN2
    59         D REVERSE^PSOBPSU1(DA,,"DC",7)
    60         S PSCANVAR=0,RXDA=DA,DA=$O(^PS(52.5,"B",DA,0)) I DA,'$G(^PS(52.5,DA,"P")) S PSCANVAR=1 D
    61         .S SUSD=$P($G(^PS(52.5,DA,0)),"^",2)
    62         .S:+$G(^PS(52.5,DA,"P"))'=1 ACOM=$S(REA="C":"Discontinued",1:"Reinstated")_" while suspended. "_$G(COM)
    63         .S DIK="^PS(52.5," D ^DIK K DIK S DA=RXDA,RXREF=0,PSODFN=+$P(^PSRX(DA,0),"^",2)
    64         .D AREC^PSOCAN1 S DA=RXDA I $O(^PSRX(DA,1,0)) D REF^PSOCAN2
    65         I $G(REA)="C" S DA=$O(^PS(52.5,"B",RXDA,0)) I DA S DIK="^PS(52.5," D ^DIK K DIK
    66         I 'PSCANVAR S:$D(SPCANC) ACOM=$S(REA="C":"Discontinued",1:"Reinstated")_" during Rx cancel.  "
    67 ADD     S DA=RXDA,RXREF=0,PSODFN=+$P(^PSRX(DA,0),"^",2) S:$G(PSOOPT)=3 REA="L"
    68         D:'$G(PSCANVAR) AREC^PSOCAN1 S:REA="L" REA="C" S:REA'="C" $P(^PSRX(DA,"STA"),"^")=0
    69         N PSOTPCNZ S PSOTPCNZ=0 I $P(^PSRX(DA,"STA"),"^")'=12 S PSOTPCNZ=1
    70         S:REA="C"&($P(^PSRX(DA,"STA"),"^")<12)!($P(^("STA"),"^")=16) $P(^PSRX(DA,"STA"),"^")=12 I $P($G(^PSRX(DA,"STA")),"^")=12,$G(PSOTPCNZ) D CAN^PSOTPCAN(DA)
    71         K PSOTPCNZ
    72         I REA="R" D
    73         .I $P(^PSRX(DA,3),"^",8) S $P(^PSRX(DA,3),"^",2)=$P(^PSRX(DA,3),"^",8),$P(^(3),"^",8)=""
    74         .S $P(^PSRX(DA,3),"^")=$S($P(^PSRX(DA,3),"^",10):$P(^(3),"^",10),$G(PSOCANHD):PSOCANHD,$P(^(3),"^",5):$P(^(3),"^",5),1:$P(^(3),"^")),$P(^(3),"^",5)="",$P(^(3),"^",10)=""
    75         I REA="C" D
    76         .S $P(^PSRX(DA,3),"^",10)=$P(^PSRX(DA,3),"^")
    77         .S:'$P(^PSRX(DA,3),"^",5) $P(^PSRX(DA,3),"^",5)=DT
    78         .I $O(^PS(52.41,"ARF",DA,0)),'$O(^PS(52.41,"APSOD",PSODFN,0)) S HLDDA=DA,DA=$O(^PS(52.41,"ARF",DA,0)),DIK="^PS(52.41," D ^DIK S DA=HLDDA K HLDDA
    79         .;check for label/release/pending release
    80         .I $G(PSOOPT)'=3 D FILX
    81         S PSONOOR=$S($D(PSONOOR):PSONOOR,1:"D"),STAT=$S(REA="C":"OD",1:"SC"),PHARMST=$S(REA="C":"",1:"CM")
    82         S COM=$S(REA="C":$S($G(PSOOPT)=3&('$G(DUP)):"Renewed",1:"Discontinued")_" by Pharmacy",1:"Reinstated by Pharmacy")
    83         D EN^PSOHLSN1(DA,STAT,PHARMST,$S(COM["Discontinued"&($D(INCOM)):INCOM,1:COM),$S($G(PSOOPT)=3&('$G(DUP)):"",1:PSONOOR)) K COM,STAT,PHARMST,PSCANVAR
    84         I REA="C" D
    85         .I $G(^PS(52.4,DA,0))]"" S PSCDA=DA,DIK="^PS(52.4," D ^DIK S DA=PSCDA K DIK,PSCDA
    86         I $G(PSOMGDFN)'="" S PSODFN=PSOMGDFN K PSOMGDFN
    87         Q:(REA="C")!('$P($G(PSOPAR),"^",2))!($P(^PSRX(DA,2),"^",10)]"")
    88         Q:$D(^XUSEC("PSORPH",DUZ))  S PSVC=$P(^PSRX(DA,0),"^",16) F JJ=0:0 S JJ=$O(^PS(55,PSODFN,"P",JJ)) Q:'JJ  I $D(^(JJ,0)),+^(0)=DA Q
    89         Q:'JJ  S PSRXIN=DA,DIC="^PS(52.4,",DLAYGO=52.4,(X,DINUM)=PSRXIN,DIC(0)="ML"
    90         S DIC("DR")="1////"_$G(PSODFN)_";2////"_DUZ_";4////"_DT
    91         K DD,DO D FILE^DICN K DD,DO,DIC,DLAYGO,DINUM
    92         K DA,DIK S DA=PSRXIN K PSRXIN S $P(^PSRX(DA,"STA"),"^")=1 D NVER^PSOCAN2
    93         W !,"Rx # "_$P(^PSRX(DA,0),"^")_" is still non-verified!"
    94         Q
    95 OERR    I '$D(^XUSEC("PSORPH",DUZ)),'$P($G(PSOPAR),"^",2) S VALMSG="Invalid Action Selection!",VALMBCK="" Q
    96         S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
    97         K PSOPLCK S PSOCANRD=+$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^",4),PSOCANRA=1
    98         I $P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^"),$P(^("STA"),"^")=1!($P(^("STA"),"^")=4) S:$G(SPEED) PSONOORS=$G(PSONOOR) D DEL^PSOCAN4 S:$G(PSONOORS)'="" PSONOOR=$G(PSONOORS) K PSONOORS D KCAN D ULP Q
    99         D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D KCAN D ULP Q
    100         I '+^PSRX($P(PSOLST(ORN),"^",2),"OR1"),$P(^("STA"),"^")=12 S VALMSG="Rx Cannot be Reinstated.  No Orderable Item." D KCAN D ULP D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q
    101         I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")=12,$P($G(^("PKI")),"^") S VALMSG="Cannot be Reinstated - Digitally Signed" D KCAN D ULP D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q
    102         I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")=12 S PSOCANRZ=1
    103         D HLDHDR^PSOLMUTL S X=$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),PS=$S($P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^")=12:"Reinstate: ",1:"Discontinue: ")
    104         S POERR=1,DFNHLD=PSODFN,DA=$P(PSOLST(ORN),"^",2)
    105         I $P(^PSRX(DA,3),"^",5) S PSOCANHD=$P(^PSRX(DA,3),"^",5)
    106         D LMNO D:$P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")=12 RMP
    107         D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
    108         K POERR,PSCAN,PSI,PSL S PSODFN=DFNHLD K DFNHLD D ULP
    109         D KCAN
    110         Q
    111         Q
    112 ULP     D UL^PSSLOCK(+$G(PSODFN))
    113         Q
    114         ;
    115 LMNO    ; Calls LMNO^PSOCAN
    116         N PSODFN,PSORX,RXN,RX0
    117         S PSPOP=0,RXNUM=X S PSODFN=+$P(^PSRX(DA,0),"^",2) D LMNO^PSOCAN
    118         Q
    119         ;
    120 KCAN    ;
    121         K PSOCANRA,PSOCANRC,PSOCANRD,PSOCANRN,PSOCANRP,PSOCANRZ,PSOMSG,PSOCANHD
    122         Q
    123         ;
    124 KCAN1   ;
    125         K PSOCANRC,PSOCANRD,PSOCANRN,PSOCANRP,PSOCANRZ
    126         Q
    127         ;
    128 RMP     D RMP^PSOCAN3N
    129         Q
    130         ;
    131 FIL     Q:'$G(PSORX)
    132         S PSOFC=PSORX G FILC
    133 FILX    Q:'$G(DA)
    134         S PSOFC=DA
    135 FILC    ;
    136         N PFC,PSOFFLAG
    137         I $P($G(^PSRX(PSOFC,2)),"^",13) G FILQ
    138         S PSOFFLAG=0 F PFC=0:0 S PFC=$O(^PSRX(PSOFC,1,PFC)) Q:'PFC!(PSOFFLAG)  I $P($G(^PSRX(PSOFC,1,PFC,0)),"^",18) S PSOFFLAG=1
    139         I PSOFFLAG G FILQ
    140         F PFC=0:0 S PFC=$O(^PSRX(PSOFC,"L",PFC)) Q:'PFC!(PSOFFLAG)  I $D(^PSRX(PSOFC,"L",PFC,0)),'$P($G(^(0)),"^",5) S PSOFFLAG=1
    141         I PSOFFLAG G FILQ
    142         S PSOFCSUS=$O(^PS(52.5,"B",PSOFC,0))
    143         I $G(PSOFCSUS),$P($G(^PS(52.5,PSOFCSUS,0)),"^",7)="L"!($P($G(^(0)),"^",7)="X") G FILQ
    144         S $P(^PSRX(PSOFC,3),"^",8)=$P($G(^PSRX(PSOFC,3)),"^",2)
    145         S $P(^PSRX(PSOFC,3),"^",2)=$P($G(^PSRX(PSOFC,2)),"^",2)
    146         I $P($G(^PSRX(PSOFC,"OR1")),"^",3) S $P(^PSRX(PSOFC,3),"^")=$P($G(^PSRX($P(^PSRX(PSOFC,"OR1"),"^",3),3)),"^")
    147 FILQ    K PSOFC,PSOFCSUS
    148         Q
    149         ;
    150 SETC    ;Called from Date of Death
    151         S $P(^PSRX(PSORX,"STA"),"^")=12,$P(^PSRX(PSORX,3),"^",5)=DT,$P(^PSRX(PSORX,3),"^",10)=$P(^PSRX(PSORX,3),"^") D CAN^PSOTPCAN(PSORX)
    152         Q
     1PSOCAN3 ;BIR/RTR/SAB - auto dc rxs due to death ; 9/18/06 2:59pm
     2 ;;7.0;OUTPATIENT PHARMACY;**15,24,27,32,36,94,88,117,131,146,139,132,223,235,148,249**;DEC 1997;Build 9
     3 ;External reference to File #55 supported by DBIA 2228
     4 ;External references to L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
     5 Q
     6APSOD(PSODFN) ;called from file #2 date of death xref 'APOSD'
     7 N D,DA,DB,DC,DE,DG,DH,DI,DIC,DIE,DIG,DIH,DIK,DIR,DIQ,DIU,DIV,DIW,DK,DL,DM,DP,DQ,DU,DV,DW,DR
     8 S PSODEATH=1 D CAN K PSODEATH
     9 Q
     10CAN ;discontinued rxs due to death
     11 I $G(PSODFN),$D(^PS(52.91,PSODFN,0)) D
     12 .I '$P($G(^PS(52.91,PSODFN,0)),"^",3)!($P($G(^(0)),"^",3)>DT) S $P(^PS(52.91,PSODFN,0),"^",3)=DT,$P(^PS(52.91,PSODFN,0),"^",4)=5,^PS(52.91,"AX",DT,PSODFN)="" D SET^PSOTPCAN(PSODFN)
     13 F PSORXJ=0:0 S PSORXJ=$O(^PS(55,PSODFN,"P",PSORXJ)) Q:'PSORXJ  I $D(^(PSORXJ,0)) S PSORX=^(0) S STA=$S($P($G(^PSRX(PSORX,"STA")),"^")<11:1,$P($G(^("STA")),"^")=16:1,1:0) D:STA
     14 .I $D(^PSRX(PSORX,0)),$P($G(^PSRX(PSORX,"STA")),"^")="" D SETC
     15 .D REVERSE^PSOBPSU1(PSORX,,"DC",7)
     16 .I $D(^PSRX(PSORX,0)),$P($G(^PSRX(PSORX,2)),"^",6)'<DT S PSO0=^(0),PSO2=$G(^(2)) D
     17 ..S ^PSRX(PSORX,"DDSTA")="52;"_$P(^PSRX(PSORX,"STA"),"^")
     18 ..;remove from hold
     19 ..I $G(^PSRX(PSORX,"H"))]"" D
     20 ...S ^PSRX(PSORX,"DDSTA")="52;"_$P(^PSRX(PSORX,"STA"),"^")_"^"_^PSRX(PSORX,"H")
     21 ...K:$P(^PSRX(PSORX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSORX,"H"),"^"),PSORX) S ^PSRX(PSORX,"H")=""
     22 ...I '$P($G(^PSRX(PSORX,2)),"^",2),$P($G(^(3)),"^") S $P(^PSRX(PSORX,2),"^",2)=$P(^(3),"^")
     23 ...I $G(PSODEATH),$P(^PSRX(PSORX,0),"^",2) S ^PSRX("APSOD",$P(^PSRX(PSORX,0),"^",2),PSORX)=""
     24 ..;delete from non-verified file
     25 ..I $G(^PS(52.4,PSORX,0))]"" S ^PSRX(PSORX,"DDSTA")="52.4;"_$P(^PSRX(PSORX,"STA"),"^")_"^"_^PS(52.4,PSORX,0),DIK="^PS(52.4,",DA=PSORX D ^DIK K DIK
     26 ..I $G(PSODEATH),$P(^PSRX(PSORX,0),"^",2) S ^PSRX("APSOD",$P(^PSRX(PSORX,0),"^",2),PSORX)=""
     27 ..;delete from suspense
     28 ..D:$O(^PS(52.5,"B",PSORX,0))
     29 ...S DA=$O(^PS(52.5,"B",PSORX,0)) I '$G(^PS(52.5,DA,"P")),$G(PSODEATH) S ^PSRX(PSORX,"DDSTA")="52.5;5^"_^PS(52.5,DA,0),^PSRX("APSOD",$P(^PSRX(PSORX,0),"^",2),PSORX)=""
     30 ...I $O(^PSRX(PSORX,1,0)),'$G(PSODEATH) S DA=PSORX,SUSD=$P($G(^PS(52.5,$O(^PS(52.5,"B",PSORX,0)),0)),"^",2) D:'$G(^PS(52.5,$O(^PS(52.5,"B",PSORX,0)),"P")) REF^PSOCAN2
     31 ...S DA=$O(^PS(52.5,"B",PSORX,0)),DIK="^PS(52.5," D ^DIK K DIK
     32 ..D SETC
     33 ..;activity record
     34 ..S (COM,ACOM)=$S($G(PSODEATH):"Date of Death Entered by MAS",1:"Discontinued by Pharmacy")_"."
     35 ..S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(PSORX,"A",SUB)) Q:'SUB  S ACNT=SUB
     36 ..S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(PSORX,1,RF)) Q:'RF  S RFCNT=RF
     37 ..D NOW^%DTC S ACNT=ACNT+1,^PSRX(PSORX,"A",0)="^52.3DA^"_ACNT_"^"_ACNT
     38 ..S ^PSRX(PSORX,"A",ACNT,0)=%_"^"_"C"_"^^"_RFCNT_"^"_"Auto Discontinued Due to Death. "_ACOM
     39 ..;check for label/release/pending release
     40 ..D FIL
     41 ..S STAT="OD",PHARMST="" D EN^PSOHLSN1(PSORX,STAT,PHARMST,COM,"A") K COMM,PHARMST,STAT
     42 ;dc pending orders
     43 F PDA=0:0 S PDA=$O(^PS(52.41,"P",PSODFN,PDA)) Q:'PDA  I $P(^PS(52.41,PDA,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") D
     44 .I $G(PSODEATH) D
     45 ..S ^PS(52.41,PDA,"DDSTA")=$P(^PS(52.41,PDA,0),"^",3)_";"_+$P($G(^PS(52.41,PDA,"INI")),"^"),^PS(52.41,"APSOD",PSODFN,PDA)=""
     46 ..S $P(^PS(52.41,PDA,4),"^")="Date of Death Entered by MAS."
     47 .S $P(^PS(52.41,PDA,0),"^",3)="DC"
     48 .K ^PS(52.41,"AOR",PSODFN,+$P($G(^PS(52.41,PDA,"INI")),"^"),PDA)
     49 .S COM=$S($G(PSODEATH):"Date of Death Entered by MAS.",1:""),PL=$P(^PS(52.41,PDA,0),"^"),$P(^(0),"^",3)="DC"
     50 .D EN^PSOHLSN(PL,"OC",COM,"A") K COM,PL
     51 ;dc non-va meds
     52 D APSOD^PSONVNEW
     53KILL K %,%H,%T,ACNT,DA,PDA,DIRUT,DTOUT,PSO,PSO0,PSO2,PSOD,PSOD0,PSODFN,PSODL,PSORX,PSORXJ,PSOSD,RF,RFCNT,SUB,TM,TSKDT,X,X1,X2,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
     54 D KVAR^VADPT S:$D(ZTQUEUED) ZTREQ="@"
     55 Q
     56CAN1 Q:$G(DODR)
     57 S PSOMGDFN=$G(PSODFN) ; SAVE IN CASE CANCELING RX THAT WAS MERGED TO ANOTHER DFN
     58 I $G(^PSRX(DA,"H"))]"" D HLD^PSOCAN2
     59 D REVERSE^PSOBPSU1(DA,,"DC",7)
     60 S PSCANVAR=0,RXDA=DA,DA=$O(^PS(52.5,"B",DA,0)) I DA,'$G(^PS(52.5,DA,"P")) S PSCANVAR=1 D
     61 .S SUSD=$P($G(^PS(52.5,DA,0)),"^",2)
     62 .S:+$G(^PS(52.5,DA,"P"))'=1 ACOM=$S(REA="C":"Discontinued",1:"Reinstated")_" while suspended. "_$G(COM)
     63 .S DIK="^PS(52.5," D ^DIK K DIK S DA=RXDA,RXREF=0,PSODFN=+$P(^PSRX(DA,0),"^",2)
     64 .D AREC^PSOCAN1 S DA=RXDA I $O(^PSRX(DA,1,0)) D REF^PSOCAN2
     65 I $G(REA)="C" S DA=$O(^PS(52.5,"B",RXDA,0)) I DA S DIK="^PS(52.5," D ^DIK K DIK
     66 I 'PSCANVAR S:$D(SPCANC) ACOM=$S(REA="C":"Discontinued",1:"Reinstated")_" during Rx cancel.  "
     67ADD S DA=RXDA,RXREF=0,PSODFN=+$P(^PSRX(DA,0),"^",2) S:$G(PSOOPT)=3 REA="L"
     68 D:'$G(PSCANVAR) AREC^PSOCAN1 S:REA="L" REA="C" S:REA'="C" $P(^PSRX(DA,"STA"),"^")=0
     69 N PSOTPCNZ S PSOTPCNZ=0 I $P(^PSRX(DA,"STA"),"^")'=12 S PSOTPCNZ=1
     70 S:REA="C"&($P(^PSRX(DA,"STA"),"^")<12)!($P(^("STA"),"^")=16) $P(^PSRX(DA,"STA"),"^")=12 I $P($G(^PSRX(DA,"STA")),"^")=12,$G(PSOTPCNZ) D CAN^PSOTPCAN(DA)
     71 K PSOTPCNZ
     72 I REA="R" D
     73 .I $P(^PSRX(DA,3),"^",8) S $P(^PSRX(DA,3),"^",2)=$P(^PSRX(DA,3),"^",8),$P(^(3),"^",8)=""
     74 .S $P(^PSRX(DA,3),"^")=$S($P(^PSRX(DA,3),"^",10):$P(^(3),"^",10),$G(PSOCANHD):PSOCANHD,$P(^(3),"^",5):$P(^(3),"^",5),1:$P(^(3),"^")),$P(^(3),"^",5)="",$P(^(3),"^",10)=""
     75 I REA="C" D
     76 .S $P(^PSRX(DA,3),"^",10)=$P(^PSRX(DA,3),"^")
     77 .S:'$P(^PSRX(DA,3),"^",5) $P(^PSRX(DA,3),"^",5)=DT
     78 .I $O(^PS(52.41,"ARF",DA,0)),'$O(^PS(52.41,"APSOD",PSODFN,0)) S HLDDA=DA,DA=$O(^PS(52.41,"ARF",DA,0)),DIK="^PS(52.41," D ^DIK S DA=HLDDA K HLDDA
     79 .;check for label/release/pending release
     80 .I $G(PSOOPT)'=3 D FILX
     81 S PSONOOR=$S($D(PSONOOR):PSONOOR,1:"D"),STAT=$S(REA="C":"OD",1:"SC"),PHARMST=$S(REA="C":"",1:"CM")
     82 S COM=$S(REA="C":$S($G(PSOOPT)=3&('$G(DUP)):"Renewed",1:"Discontinued")_" by Pharmacy",1:"Reinstated by Pharmacy")
     83 D EN^PSOHLSN1(DA,STAT,PHARMST,COM,$S($G(PSOOPT)=3&('$G(DUP)):"",1:PSONOOR)) K COM,STAT,PHARMST,PSCANVAR
     84 I REA="C" D
     85 .I $G(^PS(52.4,DA,0))]"" S PSCDA=DA,DIK="^PS(52.4," D ^DIK S DA=PSCDA K DIK,PSCDA
     86 I $G(PSOMGDFN)'="" S PSODFN=PSOMGDFN K PSOMGDFN
     87 Q:(REA="C")!('$P($G(PSOPAR),"^",2))!($P(^PSRX(DA,2),"^",10)]"")
     88 Q:$D(^XUSEC("PSORPH",DUZ))  S PSVC=$P(^PSRX(DA,0),"^",16) F JJ=0:0 S JJ=$O(^PS(55,PSODFN,"P",JJ)) Q:'JJ  I $D(^(JJ,0)),+^(0)=DA Q
     89 Q:'JJ  S PSRXIN=DA,DIC="^PS(52.4,",DLAYGO=52.4,(X,DINUM)=PSRXIN,DIC(0)="ML"
     90 S DIC("DR")="1////"_$G(PSODFN)_";2////"_DUZ_";4////"_DT
     91 K DD,DO D FILE^DICN K DD,DO,DIC,DLAYGO,DINUM
     92 K DA,DIK S DA=PSRXIN K PSRXIN S $P(^PSRX(DA,"STA"),"^")=1 D NVER^PSOCAN2
     93 W !,"Rx # "_$P(^PSRX(DA,0),"^")_" is still non-verified!"
     94 Q
     95OERR I '$D(^XUSEC("PSORPH",DUZ)),'$P($G(PSOPAR),"^",2) S VALMSG="Invalid Action Selection!",VALMBCK="" Q
     96 S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
     97 K PSOPLCK S PSOCANRD=+$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^",4),PSOCANRA=1
     98 I $P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^"),$P(^("STA"),"^")=1!($P(^("STA"),"^")=4) S:$G(SPEED) PSONOORS=$G(PSONOOR) D DEL^PSOCAN4 S:$G(PSONOORS)'="" PSONOOR=$G(PSONOORS) K PSONOORS D KCAN D ULP Q
     99 D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D KCAN D ULP Q
     100 I '+^PSRX($P(PSOLST(ORN),"^",2),"OR1"),$P(^("STA"),"^")=12 S VALMSG="Rx Cannot be Reinstated.  No Orderable Item." D KCAN D ULP D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q
     101 I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")=12,$P($G(^("PKI")),"^") S VALMSG="Cannot be Reinstated - Digitally Signed" D KCAN D ULP D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q
     102 I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")=12 S PSOCANRZ=1
     103 D HLDHDR^PSOLMUTL S X=$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),PS=$S($P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^")=12:"Reinstate: ",1:"Discontinue: ")
     104 S POERR=1,DFNHLD=PSODFN,DA=$P(PSOLST(ORN),"^",2)
     105 I $P(^PSRX(DA,3),"^",5) S PSOCANHD=$P(^PSRX(DA,3),"^",5)
     106 D LMNO D:$P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")=12 RMP
     107 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
     108 K POERR,PSCAN,PSI,PSL S PSODFN=DFNHLD K DFNHLD D ULP
     109 D KCAN
     110 Q
     111 Q
     112ULP D UL^PSSLOCK(+$G(PSODFN))
     113 Q
     114 ;
     115LMNO ; Calls LMNO^PSOCAN
     116 N PSODFN,PSORX,RXN,RX0
     117 S PSPOP=0,RXNUM=X S PSODFN=+$P(^PSRX(DA,0),"^",2) D LMNO^PSOCAN
     118 Q
     119 ;
     120KCAN ;
     121 K PSOCANRA,PSOCANRC,PSOCANRD,PSOCANRN,PSOCANRP,PSOCANRZ,PSOMSG,PSOCANHD
     122 Q
     123 ;
     124KCAN1 ;
     125 K PSOCANRC,PSOCANRD,PSOCANRN,PSOCANRP,PSOCANRZ
     126 Q
     127 ;
     128RMP ;remove Rx if found in array PSORX("PSOL") (Label Queue)
     129 Q:'$D(PSORX("PSOL"))  S:'$G(DA) DA=$P(PSOLST(ORN),"^",2)
     130 N I,J,FND,ST1,ST2,ST3 S I=0
     131 F  S I=$O(PSORX("PSOL",I)) Q:'I  D
     132 . S ST1=PSORX("PSOL",I) Q:ST1'[(DA_",")
     133 . S ST3="",FND=0
     134 . F J=1:1 S ST2=$P(ST1,",",J) Q:'ST2  D
     135 . . I ST2=DA S FND=1 Q
     136 . . S ST3=ST3_$S('ST3:"",1:",")_ST2
     137 . I FND D
     138 . . S:ST3]"" PSORX("PSOL",I)=ST3_","
     139 . . K:ST3="" PSORX("PSOL",I)
     140 . . D:$D(BBRX(I)) RMB^PSOCAN2(I)
     141 Q
     142 ;
     143FIL Q:'$G(PSORX)
     144 S PSOFC=PSORX G FILC
     145FILX Q:'$G(DA)
     146 S PSOFC=DA
     147FILC ;
     148 N PFC,PSOFFLAG
     149 I $P($G(^PSRX(PSOFC,2)),"^",13) G FILQ
     150 S PSOFFLAG=0 F PFC=0:0 S PFC=$O(^PSRX(PSOFC,1,PFC)) Q:'PFC!(PSOFFLAG)  I $P($G(^PSRX(PSOFC,1,PFC,0)),"^",18) S PSOFFLAG=1
     151 I PSOFFLAG G FILQ
     152 F PFC=0:0 S PFC=$O(^PSRX(PSOFC,"L",PFC)) Q:'PFC!(PSOFFLAG)  I $D(^PSRX(PSOFC,"L",PFC,0)),'$P($G(^(0)),"^",5) S PSOFFLAG=1
     153 I PSOFFLAG G FILQ
     154 S PSOFCSUS=$O(^PS(52.5,"B",PSOFC,0))
     155 I $G(PSOFCSUS),$P($G(^PS(52.5,PSOFCSUS,0)),"^",7)="L"!($P($G(^(0)),"^",7)="X") G FILQ
     156 S $P(^PSRX(PSOFC,3),"^",8)=$P($G(^PSRX(PSOFC,3)),"^",2)
     157 S $P(^PSRX(PSOFC,3),"^",2)=$P($G(^PSRX(PSOFC,2)),"^",2)
     158 I $P($G(^PSRX(PSOFC,"OR1")),"^",3) S $P(^PSRX(PSOFC,3),"^")=$P($G(^PSRX($P(^PSRX(PSOFC,"OR1"),"^",3),3)),"^")
     159FILQ K PSOFC,PSOFCSUS
     160 Q
     161 ;
     162SETC ;Called from Date of Death
     163 S $P(^PSRX(PSORX,"STA"),"^")=12,$P(^PSRX(PSORX,3),"^",5)=DT,$P(^PSRX(PSORX,3),"^",10)=$P(^PSRX(PSORX,3),"^") D CAN^PSOTPCAN(PSORX)
     164 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN4.m

    r613 r623  
    1 PSOCAN4 ;BIR/SAB-rx speed dc listman ;10/23/06 11:50am
    2         ;;7.0;OUTPATIENT PHARMACY;**20,24,27,63,88,117,131,259,268,225**;DEC 1997;Build 29
    3         ;External reference to File #200 supported by DBIA 224
    4         ;External reference NA^ORX1 supported by DBIA 2186
    5         ;External references to L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
    6         ;External reference to PSDRUG supported by DBIA 221
    7         ;External reference to PS(50.7 supported by DBIA 2223
    8         ;External reference to PS(50.606 supported by DBIA 2174
    9 SEL     I '$D(^XUSEC("PSORPH",DUZ)) S VALMSG="Unauthorized Action Selection.",VALMBCK="" Q
    10         N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
    11         S DFNHLD=PSODFN
    12         S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
    13         K PSOPLCK S RXCNT=0 K PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR S LST=Y I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" D ULP Q
    14         K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +LST S (SPEED,PSOOELSE)=1 D  D KCAN^PSOCAN3
    15         .S PSOCANRA=1 D RQTEST
    16         .D FULL^VALM1,COM^PSOCAN1 I '$D(INCOM)!($D(DIRUT)) K SPEED S VALMBCK="R" Q
    17         .D FULL^VALM1 F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""  S ORN=$P(LST,",",ORD) D @$S(+PSOLST(ORN)=52:"RX",1:"PEN")
    18         .S VALMBCK="R"
    19         I '$G(PSOOELSE) S VALMBCK=""
    20         D ^PSOBUILD,BLD^PSOORUT1,RV^PSOORFL K PSOMSG,RXCNT,DIR,DIRUT,DTOUT,DUOUT,LST,ORD,IEN,ORN,RPH,ST,REFL,REF,PSOACT,ORSV,PSORNW,PSORENW,PSONO,PSOCO,PSOCU,PSODIR,DSMSG,SAVORD,SAVORN,SPEED,DIRUT,PSONOOR
    21         D INVALD^PSOCAN1 K PSINV,PSOOELSE,INCOM,COM S PSODFN=DFNHLD K DFNHLD D ULP
    22         Q
    23 ULP     D UL^PSSLOCK(+$G(PSODFN)) Q
    24         ;
    25 RX      Q:'$D(^XUSEC("PSORPH",DUZ))
    26         D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) D  D PAUSE^VALM1 K PSOMSG Q
    27         .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P($G(PSOMSG),"^",2),!,"Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),! Q
    28         .W $C(7),!!,"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),!
    29         S RXSP=1 K PSCAN S (EN,X)=$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^") S Y=$P(PSOLST(ORN),"^",2)_"^"_X,Y(0,0)=X,Y(0)=$G(^PSRX($P(PSOLST(ORN),"^",2),0)) D
    30         .I $P(^PSRX(+Y,"STA"),"^")=1!($P(^("STA"),"^")=4) D  Q
    31         ..I $P($G(^PSRX(+Y,"PKI")),"^") N PKI,PKI1,PKIR,PKIE,DA S DA=+Y D CER^PSOPKIV1
    32         ..S:$G(PSONOOR)'="" PSONOORA=$G(PSONOOR) D DEL S:$G(PSONOORA)'="" PSONOOR=$G(PSONOORA) K PSONOORA Q
    33         .S YY=Y,YY(0,0)=Y(0,0),(PSODFN,DFN)=$P(Y(0),"^",2) D:$G(DFN) CHK^PSOCAN I DEAD!($P(^PSRX(+YY,"STA"),"^")>11),$P(^("STA"),"^")<16 S PSINV(EN)="" Q
    34         .S DA=+YY I $P($G(^PSRX(DA,"STA")),"^")=11!($P($G(^(2)),"^",6)<DT) D EXP^PSOCAN
    35         .S RX=YY(0,0) D:$D(^PSRX(DA,0)) SPEED1^PSOCAN1
    36         K YY I '$D(PSCAN) D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q
    37         S RX="",RXCNT=0 F  S RX=$O(PSCAN(RX)) Q:RX=""  S DA=+PSCAN(RX),REA=$P(PSCAN(RX),"^",2),RXCNT=RXCNT+1 D SHOW^PSOCAN1
    38         S RX="" F  S RX=$O(PSCAN(RX)) Q:RX=""  D ACT
    39         D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
    40         Q
    41 ACT     S DA=+PSCAN(RX),REA=$P(PSCAN(RX),"^",2),II=RX,PSODFN=$P(^PSRX(DA,0),"^",2) I REA="R" D REINS^PSOCAN2 Q
    42         D CAN1^PSOCAN3 Q
    43 PEN     ;discontinue pending orders
    44         S SAVORD=ORD,SAVORN=ORN
    45         S ORD=$P(PSOLST(ORN),"^",2) D PSOL^PSSLOCK(+ORD_"S") I '$G(PSOMSG) D  D MEDDIS K PSOMSG G OK
    46         .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P($G(PSOMSG),"^",2)_"  (Pending order)",! Q
    47         .W $C(7),!!,"Another person is editing this Pending order.",!
    48         I $P(^PS(52.41,ORD,0),"^",3)="RF" S DA=ORD,DIK="^PS(52.41," D ^DIK K DA,DIK D PSOUL^PSSLOCK(ORD_"S") Q
    49         K ^PS(52.41,"AOR",$P(^PS(52.41,ORD,0),"^",2),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD) S $P(^PS(52.41,ORD,0),"^",3)="DC"
    50         D EN^PSOHLSN(+^PS(52.41,ORD,0),"OC",INCOM,PSONOOR)
    51         D PSOUL^PSSLOCK(ORD_"S")
    52 OK      S ORD=SAVORD,ORN=SAVORN Q
    53 NOOR    ;ask nature of order
    54         D FULL^VALM1
    55         K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]"" D  Q:$D(DIRUT)  G NOORXP
    56         .S PSONOOR=$$NA^ORX1("S",0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:""))
    57         .I +PSONOOR S PSONOOR=$P(PSONOOR,"^",3) Q
    58         .S DIRUT=1 K PSONOOR
    59         S DIR("A")="Nature of Order: ",DIR("B")=$S($G(DODR):"SERVICE CORRECTED",1:"WRITTEN")
    60         S DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$S(+$G(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"")
    61         D ^DIR K DIR,DTOUT,DTOUT Q:$D(DIRUT)  S PSONOOR=Y
    62 NOORXP  I $G(PSOCANRA),'$G(PSOCANRZ) D REQ
    63 NOORX   S:$D(DIRUT)&($G(SPEED)) VALMBCK="Q"
    64         Q
    65 DEL     ;deletes non-verified Rxs
    66         D FULL^VALM1
    67         W ! K DIR,DIRUT,DUOUT S DIR(0)="Y",DIR("B")="No",DIR("A",1)="Rx # "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")_" is in a Non-Verified Status.",DIR("A")="Are sure you want to mark the Rx as deleted" D ^DIR I 'Y!($D(DIRUT)) S VALMBCK="R" G EX
    68         I '$G(SPEED) D  I $D(DIRUT) G EX
    69         .D NOOR^PSOCAN4 I $D(DIRUT) S VALMSG="No Action Taken!",VALMBCK="R" Q
    70         .K DIR S DIR("A")="Comments",DIR("B")="Per Pharmacy Request",DIR(0)="F^5:100" D ^DIR K DIR I $D(DIRUT) S VALMSG="No Action Taken!" Q
    71         K PSDEL,PSORX("INTERVENE") S PSOZVER=1,DA=$P(PSOLST(ORN),"^",2)
    72         I $G(PKI1) N INCOM S INCOM=Y D DCV^PSOPKIV1 Q
    73         D ENQ^PSORXDL
    74 EX      Q
    75 REQ     ;prompt for requesting provider
    76         I '$G(PSOCANRD),$G(PSOCANRP),$G(ORD),$D(^PS(52.41,ORD,0)) S PSOCANRD=+$P($G(^PS(52.41,ORD,0)),"^",5)
    77         I $G(PSOCANRD) D
    78         .I $D(^VA(200,PSOCANRD,"PS")),$P($G(^("PS")),"^"),$S('$P(^("PS"),"^",4):1,1:$P(^("PS"),"^",4)'<DT) Q
    79         .K PSOCANRD
    80         W ! K DIC S DIC=200,DIC(0)="AEQMZ",DIC("A")="Requesting PROVIDER: ",DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)" I $G(PSOCANRD) S DIC("B")=PSOCANRD
    81         D ^DIC K DIC S:$G(Y)<0!($D(DTOUT))!($D(DUOUT)) DIRUT=1 I $G(Y) S PSOCANRC=+$G(Y),PSOCANRN=$P($G(Y),"^",2),PSOCANRZ=1
    82         Q
    83 RQTEST  ;
    84         N PMIN,PMINZ,PMINFLAG
    85         S PMINFLAG=0 F PMIN=1:1:$L(LST,",") Q:$P(LST,",",PMIN)']""  S PMINZ=$P(LST,",",PMIN) D
    86         .I $P($G(PSOLST(PMINZ)),"^")=52 I $P($G(^PSRX(+$P($G(PSOLST(PMINZ)),"^",2),"STA")),"^")'=12,'$G(PMINFLAG) S PSOCANRD=+$P($G(^PSRX(+$P($G(PSOLST(PMINZ)),"^",2),0)),"^",4) S PMINFLAG=1
    87         .I $P($G(PSOLST(PMINZ)),"^")=52.41,'$G(PMINFLAG) S PSOCANRD=$P($G(^PS(52.41,+$P($G(PSOLST(PMINZ)),"^",2),0)),"^",5) S PMINFLAG=1
    88         I '$G(PMINFLAG) S PSOCANRZ=1
    89         Q
    90 MEDDIS  ;
    91         N PSOFMMD
    92         Q:'$G(ORD)
    93         Q:'$D(^PS(52.41,ORD,0))
    94         I $P(^PS(52.41,ORD,0),"^",9) W "Drug: "_$P($G(^PSDRUG(+$P(^PS(52.41,ORD,0),"^",9),0)),"^") D PAUSE^VALM1 Q
    95         I $P(^PS(52.41,ORD,0),"^",8) S PSOFMMD=$P(^(0),"^",8) W "Orderable Item: "_$P($G(^PS(50.7,PSOFMMD,0)),"^")_"  "_$P($G(^PS(50.606,+$P($G(^PS(50.7,PSOFMMD,0)),"^",2),0)),"^") D PAUSE^VALM1
    96         Q
    97         ;
    98 REF     ;CONT. FROM REF^PSOCAN2; PSO*7*259
    99         N PSOSIEN S PSOSIEN=0
    100         F  S PSOSIEN=$O(^PS(52.5,"B",DA,PSOSIEN)) Q:'PSOSIEN  D  Q:PSONODEL
    101         .I $P($G(^PS(52.5,PSOSIEN,0)),"^",13)'=IFN Q  ;NOT SAME REFILL
    102         .I '$P($G(^PS(52.5,PSOSIEN,"P")),"^") Q  ;SUSPENSE LABEL PRINT
    103         .S PSONODEL=1   ;REFILL NODE SHOULD NOT BE DELETED
    104         Q
     1PSOCAN4 ;BIR/SAB-rx speed dc listman ; 11/3/06 9:50pm
     2 ;;7.0;OUTPATIENT PHARMACY;**20,24,27,63,88,117,131,259,268,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 ;External reference to File #200 supported by DBIA 224
     20 ;External reference NA^ORX1 supported by DBIA 2186
     21 ;External references to L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
     22 ;External reference to PSDRUG supported by DBIA 221
     23 ;External reference to PS(50.7 supported by DBIA 2223
     24 ;External reference to PS(50.606 supported by DBIA 2174
     25SEL I '$D(^XUSEC("PSORPH",DUZ)) S VALMSG="Unauthorized Action Selection.",VALMBCK="" Q
     26 N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
     27 S DFNHLD=PSODFN
     28 S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
     29 K PSOPLCK S RXCNT=0 K PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR S LST=Y I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" D ULP Q
     30 K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +LST S (SPEED,PSOOELSE)=1 D  D KCAN^PSOCAN3
     31 .S PSOCANRA=1 D RQTEST
     32 .D FULL^VALM1,COM^PSOCAN1 I '$D(INCOM)!($D(DIRUT)) K SPEED S VALMBCK="R" Q
     33 .D FULL^VALM1 F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""  S ORN=$P(LST,",",ORD) D @$S(+PSOLST(ORN)=52:"RX",1:"PEN")
     34 .S VALMBCK="R"
     35 I '$G(PSOOELSE) S VALMBCK=""
     36 D ^PSOBUILD,BLD^PSOORUT1 K PSOMSG,RXCNT,DIR,DIRUT,DTOUT,DUOUT,LST,ORD,IEN,ORN,RPH,ST,REFL,REF,PSOACT,ORSV,PSORNW,PSORENW,PSONO,PSOCO,PSOCU,PSODIR,DSMSG,SAVORD,SAVORN,SPEED,DIRUT,PSONOOR
     37 D INVALD^PSOCAN1 K PSINV,PSOOELSE,INCOM,COM S PSODFN=DFNHLD K DFNHLD D ULP
     38 Q
     39ULP D UL^PSSLOCK(+$G(PSODFN)) Q
     40 ;
     41RX Q:'$D(^XUSEC("PSORPH",DUZ))
     42 D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) D  D PAUSE^VALM1 K PSOMSG Q
     43 .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P($G(PSOMSG),"^",2),!,"Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),! Q
     44 .W $C(7),!!,"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),!
     45 S RXSP=1 K PSCAN S (EN,X)=$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^") S Y=$P(PSOLST(ORN),"^",2)_"^"_X,Y(0,0)=X,Y(0)=$G(^PSRX($P(PSOLST(ORN),"^",2),0)) D
     46 .I $P(^PSRX(+Y,"STA"),"^")=1!($P(^("STA"),"^")=4) D  Q
     47 ..I $P($G(^PSRX(+Y,"PKI")),"^") N PKI,PKI1,PKIR,PKIE,DA S DA=+Y D CER^PSOPKIV1
     48 ..S:$G(PSONOOR)'="" PSONOORA=$G(PSONOOR) D DEL S:$G(PSONOORA)'="" PSONOOR=$G(PSONOORA) K PSONOORA Q
     49 .S YY=Y,YY(0,0)=Y(0,0),(PSODFN,DFN)=$P(Y(0),"^",2) D:$G(DFN) CHK^PSOCAN I DEAD!($P(^PSRX(+YY,"STA"),"^")>11),$P(^("STA"),"^")<16 S PSINV(EN)="" Q
     50 .S DA=+YY I $P($G(^PSRX(DA,"STA")),"^")=11!($P($G(^(2)),"^",6)<DT) D EXP^PSOCAN
     51 .S RX=YY(0,0) D:$D(^PSRX(DA,0)) SPEED1^PSOCAN1
     52 K YY I '$D(PSCAN) D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q
     53 S RX="",RXCNT=0 F  S RX=$O(PSCAN(RX)) Q:RX=""  S DA=+PSCAN(RX),REA=$P(PSCAN(RX),"^",2),RXCNT=RXCNT+1 D SHOW^PSOCAN1
     54 S RX="" F  S RX=$O(PSCAN(RX)) Q:RX=""  D ACT
     55 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
     56 Q
     57ACT S DA=+PSCAN(RX),REA=$P(PSCAN(RX),"^",2),II=RX,PSODFN=$P(^PSRX(DA,0),"^",2) I REA="R" D REINS^PSOCAN2 Q
     58 D CAN1^PSOCAN3 Q
     59PEN ;discontinue pending orders
     60 S SAVORD=ORD,SAVORN=ORN
     61 S ORD=$P(PSOLST(ORN),"^",2) D PSOL^PSSLOCK(+ORD_"S") I '$G(PSOMSG) D  D MEDDIS K PSOMSG G OK
     62 .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P($G(PSOMSG),"^",2)_"  (Pending order)",! Q
     63 .W $C(7),!!,"Another person is editing this Pending order.",!
     64 I $P(^PS(52.41,ORD,0),"^",3)="RF" S DA=ORD,DIK="^PS(52.41," D ^DIK K DA,DIK D PSOUL^PSSLOCK(ORD_"S") Q
     65 K ^PS(52.41,"AOR",$P(^PS(52.41,ORD,0),"^",2),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD) S $P(^PS(52.41,ORD,0),"^",3)="DC"
     66 D EN^PSOHLSN(+^PS(52.41,ORD,0),"OC",INCOM,PSONOOR)
     67 D PSOUL^PSSLOCK(ORD_"S")
     68OK S ORD=SAVORD,ORN=SAVORN Q
     69NOOR ;ask nature of order
     70 ;vfah set nature of order automatically for autofinish,rx
     71 I $G(PSOAFYN)'="Y" D FULL^VALM1 ;vfah
     72 I $G(PSOAFYN)'="Y" K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]"" D  Q:$D(DIRUT)  G NOORXP ;vfah
     73 .I $G(PSOAFYN)'="Y" S PSONOOR=$$NA^ORX1("S",0,"B","Nature of Order",0,"WPSDIVX"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:"")) ;vfah
     74 .I $G(PSOAFYN)'="Y" I +PSONOOR S PSONOOR=$P(PSONOOR,"^",3) Q  ;vfah
     75 .I $G(PSOAFYN)'="Y" S DIRUT=1 K PSONOOR ;vfah
     76 I $G(PSOAFYN)'="Y" S DIR("A")="Nature of Order: ",DIR("B")=$S($G(DODR):"SERVICE CORRECTED",1:"WRITTEN") ;vfah
     77 I $G(PSOAFYN)'="Y" S DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;X:REJECTED"_$S(+$G(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"")
     78 I $G(PSOAFYN)'="Y" D ^DIR K DIR,DTOUT,DTOUT Q:$D(DIRUT)  S PSONOOR=Y ;vfah
     79 I $G(PSOAFYN)="Y" S PSONOOR="S" ;vfah sets nature of order to service correction for autofinish,rx
     80 ;vfah end of set nature of order
     81NOORXP I $G(PSOCANRA),'$G(PSOCANRZ) D REQ
     82NOORX S:$D(DIRUT)&($G(SPEED)) VALMBCK="Q"
     83 Q
     84DEL ;deletes non-verified Rxs
     85 D FULL^VALM1
     86 W ! K DIR,DIRUT,DUOUT S DIR(0)="Y",DIR("B")="No",DIR("A",1)="Rx # "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")_" is in a Non-Verified Status.",DIR("A")="Are sure you want to mark the Rx as deleted" D ^DIR I 'Y!($D(DIRUT)) S VALMBCK="R" G EX
     87 I '$G(SPEED) D  I $D(DIRUT) G EX
     88 .D NOOR^PSOCAN4 I $D(DIRUT) S VALMSG="No Action Taken!",VALMBCK="R" Q
     89 .K DIR S DIR("A")="Comments",DIR("B")="Per Pharmacy Request",DIR(0)="F^5:100" D ^DIR K DIR I $D(DIRUT) S VALMSG="No Action Taken!" Q
     90 K PSDEL,PSORX("INTERVENE") S PSOZVER=1,DA=$P(PSOLST(ORN),"^",2)
     91 I $G(PKI1) N INCOM S INCOM=Y D DCV^PSOPKIV1 Q
     92 D ENQ^PSORXDL
     93EX Q
     94REQ ;prompt for requesting provider
     95 I '$G(PSOCANRD),$G(PSOCANRP),$G(ORD),$D(^PS(52.41,ORD,0)) S PSOCANRD=+$P($G(^PS(52.41,ORD,0)),"^",5)
     96 I $G(PSOCANRD) D
     97 .I $D(^VA(200,PSOCANRD,"PS")),$P($G(^("PS")),"^"),$S('$P(^("PS"),"^",4):1,1:$P(^("PS"),"^",4)'<DT) Q
     98 .K PSOCANRD
     99 W ! K DIC S DIC=200,DIC(0)="AEQMZ",DIC("A")="Requesting PROVIDER: ",DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)" I $G(PSOCANRD) S DIC("B")=PSOCANRD
     100 D ^DIC K DIC S:$G(Y)<0!($D(DTOUT))!($D(DUOUT)) DIRUT=1 I $G(Y) S PSOCANRC=+$G(Y),PSOCANRN=$P($G(Y),"^",2),PSOCANRZ=1
     101 Q
     102RQTEST ;
     103 N PMIN,PMINZ,PMINFLAG
     104 S PMINFLAG=0 F PMIN=1:1:$L(LST,",") Q:$P(LST,",",PMIN)']""  S PMINZ=$P(LST,",",PMIN) D
     105 .I $P($G(PSOLST(PMINZ)),"^")=52 I $P($G(^PSRX(+$P($G(PSOLST(PMINZ)),"^",2),"STA")),"^")'=12,'$G(PMINFLAG) S PSOCANRD=+$P($G(^PSRX(+$P($G(PSOLST(PMINZ)),"^",2),0)),"^",4) S PMINFLAG=1
     106 .I $P($G(PSOLST(PMINZ)),"^")=52.41,'$G(PMINFLAG) S PSOCANRD=$P($G(^PS(52.41,+$P($G(PSOLST(PMINZ)),"^",2),0)),"^",5) S PMINFLAG=1
     107 I '$G(PMINFLAG) S PSOCANRZ=1
     108 Q
     109MEDDIS ;
     110 N PSOFMMD
     111 Q:'$G(ORD)
     112 Q:'$D(^PS(52.41,ORD,0))
     113 I $P(^PS(52.41,ORD,0),"^",9) W "Drug: "_$P($G(^PSDRUG(+$P(^PS(52.41,ORD,0),"^",9),0)),"^") D PAUSE^VALM1 Q
     114 I $P(^PS(52.41,ORD,0),"^",8) S PSOFMMD=$P(^(0),"^",8) W "Orderable Item: "_$P($G(^PS(50.7,PSOFMMD,0)),"^")_"  "_$P($G(^PS(50.606,+$P($G(^PS(50.7,PSOFMMD,0)),"^",2),0)),"^") D PAUSE^VALM1
     115 Q
     116 ;
     117REF ;CONT. FROM REF^PSOCAN2; PSO*7*259
     118 N PSOSIEN S PSOSIEN=0
     119 F  S PSOSIEN=$O(^PS(52.5,"B",DA,PSOSIEN)) Q:'PSOSIEN  D  Q:PSONODEL
     120 .I $P($G(^PS(52.5,PSOSIEN,0)),"^",13)'=IFN Q  ;NOT SAME REFILL
     121 .I '$P($G(^PS(52.5,PSOSIEN,"P")),"^") Q  ;SUSPENSE LABEL PRINT
     122 .S PSONODEL=1   ;REFILL NODE SHOULD NOT BE DELETED
     123 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCIDC2.m

    r613 r623  
    1 PSOCIDC2        ;BIR/LE-continuation of Copay Correction of erroneous billed copays ;11/8/05 12:50pm
    2         ;;7.0;OUTPATIENT PHARMACY;**226,225**;DEC 1997;Build 29
    3         ;External reference to ^XUSEC supported by DBIA 10076
    4         ;External reference to IBARX supported by DBIA 125
    5         ;External reference to $$PROD^XUPROD(1) supported by DBIA 4440
    6         ;
    7 TOTAL   ;
    8         N COUNT,COUNTED,UCOUNT,UCOUNTED,CCOUNT,CCOUNTED
    9         I '$D(PSOVETS) S PSOVETS=0
    10         N I,J
    11         F I=1:1:3 S (PSOCNT("YR2004",I),PSOCNT("YR2005",I),PSOCNT("YR2006",I))=0
    12         S PSODFN=0 F  S PSODFN=$O(^XTMP(NAMSP,"TOT REL",PSODFN)) Q:'PSODFN  D
    13         .S COUNTED=0
    14         .F J="YR2004","YR2005","YR2006" F I=1:1:3 S COUNT=$G(^XTMP(NAMSP,"TOT REL",PSODFN,J,I)) I COUNT>0 S:'$G(COUNTED) COUNTED=1,PSOVETS=PSOVETS+1 S PSOCNT(J,I)=PSOCNT(J,I)+COUNT
    15         F I=1:1:3 S PSOCNT=PSOCNT+$G(PSOCNT("YR2004",I))+$G(PSOCNT("YR2005",I))+$G(PSOCNT("YR2006",I))
    16         ;
    17         S (I,J)=-""
    18         I '$D(PSOCVETS) S PSOCVETS=0
    19         F I=1:1:3 S (PSOCCNT("YR2004",I),PSOCCNT("YR2005",I),PSOCCNT("YR2006",I))=0
    20         S PSODFN=0 F  S PSODFN=$O(^XTMP(NAMSP,"TOT CAN",PSODFN)) Q:'PSODFN  D
    21         .S CCOUNTED=0
    22         .F J="YR2004","YR2005","YR2006" F I=1:1:3 S CCOUNT=$G(^XTMP(NAMSP,"TOT CAN",PSODFN,J,I)) I CCOUNT>0 S:'$G(CCOUNTED) CCOUNTED=1,PSOCVETS=PSOCVETS+1 S PSOCCNT(J,I)=PSOCCNT(J,I)+CCOUNT
    23         F I=1:1:3 S PSOCCNT=PSOCCNT+$G(PSOCCNT("YR2004",I))+$G(PSOCCNT("YR2005",I))+$G(PSOCCNT("YR2006",I))
    24         ;
    25         S (I,J)=""
    26         I '$D(PSOUVETS) S PSOUVETS=0
    27         F I=1:1:3 S (PSOUCNT("YR2004",I),PSOUCNT("YR2005",I),PSOUCNT("YR2006",I))=0
    28         S PSOUDFN=0 F  S PSOUDFN=$O(^XTMP(NAMSP,"TOT UNREL",PSOUDFN)) Q:'PSOUDFN  D
    29         .S UCOUNTED=0
    30         .F J="YR2004","YR2005","YR2006" F I=1:1:3 S UCOUNT=$G(^XTMP(NAMSP,"TOT UNREL",PSOUDFN,J,I)) I UCOUNT>0 S:'$G(UCOUNTED) UCOUNTED=1,PSOUVETS=PSOUVETS+1 S PSOUCNT(J,I)=PSOUCNT(J,I)+UCOUNT
    31         F I=1:1:3 S PSOUCNT=PSOUCNT+$G(PSOUCNT("YR2004",I))+$G(PSOUCNT("YR2005",I))+$G(PSOUCNT("YR2006",I))
    32         ;
    33         Q
    34         ;
    35 CHECK   ;check for ICD and IB nodes
    36         ;
    37         N PSOREF,PSOIB,PSOOICD,PSOBILLD
    38         S PSOREF=YY
    39         S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8)
    40         ; see if bill already exists
    41         I PSOREF=0 D
    42         . I +$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1
    43         . S PSOREL=$P($G(^PSRX(RXP,2)),"^",13)
    44         I PSOREF>0 D
    45         . I +$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1
    46         . S PSOREL=$P($G(^PSRX(RXP,1,YY,0)),"^",18)
    47         I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1
    48         ;    if billed/RELEASED and no IBQ node for both sc<50 and nsc
    49         I $G(PSOBILLD)&('$D(^PSRX(RXP,"IBQ"))) D
    50         . I $TR(PSOOICD,"^")[1  S ^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP
    51         . I $TR(PSOOICD,"^")[0 S ^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP
    52         ;           find unbilled ones with an ICD node and no IBQ node.
    53         I '$G(PSOBILLD)&('$D(^PSRX(RXP,"IBQ"))) D
    54         . Q:$TR(PSOOICD,"^")=""
    55         . S ^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP
    56         I YY S PSOTRF=PSOTRF+1
    57         Q
    58         ;
    59 CANCEL  ;Cancel erroneous copays/set IBQ node if not there
    60         ;released rx's
    61         N PSOCAP,PSODIV,PSODV,PSOFILL,PSOLOG,PSONAM,PSOOUT,PSOPAR,PSOPAR7,PSOSITE
    62         N PSOSITE7,PSOSQ,PSOTOT,PSOYEAR,PSOYR,SSN,SAVCPUN,SAVREF,PSOIB,PSOOIBQ,PSONIBQ,PSOOICD,PSOOIB
    63         N I,IFN,PSOANSQ,PSOTYP,COM,CC,PREA,PSONW,PSOOLD,PSOREL,PSO,PSOCPUN,PSOFLD,PSOTYPE,CANCEL
    64         S PSOTYPE="CAN"
    65         S PSODFN=0 F CC=1:1 S PSODFN=$O(^XTMP(NAMSP,"CANCEL",PSODFN)) Q:'PSODFN  D  Q:STOP
    66         .I CC#100=0,$D(^XTMP(NAMSP,0,"STOP")) D  Q
    67         .. S $P(^XTMP(NAMSP,0,"LAST"),"^",1,2)="STOP^"_$$NOW^XLFDT,STOP=1
    68         .S (PSOCAP(304),PSOCAP(305),PSOCAP(306))=0 ; INITIAL ANNUAL CAP FOR 2004 & 2005
    69         .F RXP=0:0 S RXP=$O(^XTMP(NAMSP,"CANCEL",PSODFN,RXP)) Q:'RXP  D
    70         ..S (SAVCPUN,PSOCPUN)=($P(^PSRX(RXP,0),"^",8)+29)\30
    71         ..S YY="" F  S YY=$O(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)) Q:YY=""  D
    72         ...S (SAVREF,PSOREF)=YY
    73         ...;  verify again that it was billed and not already cancelled
    74         ...S PSOBILLD=0
    75         ...I YY=0,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1 I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1
    76         ...I YY>0,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^")>0 D CHKIB^PSOCP1 I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1
    77         ...Q:'PSOBILLD
    78         ...S PSOREL=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^"),PSOFLD=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^",2),PSOSCP=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^",3)
    79         ...S PSO=3 D NOW^%DTC S PSODT=%,PSODA=RXP,PSOCOMM="-BKGD CIDC COPAY CANCEL",PSOOLD="",PSONW="",PREA=""
    80         ...D CHKACT
    81         ...S PSOIB="",PSOIB=$S(PSOREF>0:$G(^PSRX(RXP,1,YY,"IB")),'PSOREF:$G(^PSRX(PSODA,"IB")),1:"")
    82         ...S (PSOOIBQ,PSOOICD,PSOOIB)=""
    83         ...S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8),PSOOIB=$G(^PSRX(RXP,"IB")),PSOOIBQ=$G(^PSRX(RXP,"IBQ"))
    84         ...I PSOOIBQ=""&($TR(PSOOICD,"^")[0!($TR(PSOOICD,"^")[1)) D SETIBQ
    85         ...D SITE S PSOCOMM="-BKGD CIDC COPAY CANCEL" D RXED^PSOCPA S:PSOOICD[1&($D(^PSRX(RXP,"IB"))) $P(^PSRX(RXP,"IB"),"^")=""
    86         ...S PSOCPUN=SAVCPUN,PSOREF=SAVREF
    87         ...D ACCUM
    88         ;
    89         ;ICD NODES WITHOUT IBQ NODE; set IBQ node but only set 1st piece of IB node if unreleased.
    90         S PSOTYP="IBQ"
    91         S PSODFN=0 F CC=1:1 S PSODFN=$O(^XTMP(NAMSP,"NOIBQ",PSODFN)) Q:'PSODFN  D  Q:STOP
    92         .I CC#100=0,$D(^XTMP(NAMSP,0,"STOP")) D  Q
    93         .. S $P(^XTMP(NAMSP,0,"LAST"),"^",1,2)="STOP^"_$$NOW^XLFDT,STOP=1
    94         .S (PSOCAP(304),PSOCAP(305),PSOCAP(306))=0 ; INITIAL ANNUAL CAP FOR 2004 & 2005
    95         .F RXP=0:0 S RXP=$O(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP)) Q:'RXP  D
    96         ..S (SAVCPUN,PSOCPUN)=($P(^PSRX(RXP,0),"^",8)+29)\30
    97         ..S YY="" F  S YY=$O(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)) Q:YY=""  D
    98         ...S (SAVREF,PSOREF)=YY
    99         ...D SITE
    100         ...S PSOREL=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^"),PSOFLD=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^",2),PSOSCP=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^",3)
    101         ...S (PSOOIBQ,PSOOICD,PSOOIB)=""
    102         ...S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8),PSOOIB=$G(^PSRX(RXP,"IB")),PSOOIBQ=$G(^PSRX(RXP,"IBQ"))
    103         ...I PSOOIBQ=""&($TR(PSOOICD,"^")[0!($TR(PSOOICD,"^")[1)) D SETIBQ D   ;don't want to set again if already did it as part of copay cancel
    104         ....S I="",IFN=0 F I=0:0 S I=$O(^PSRX(RXP,"A",I)) Q:'I  S IFN=I
    105         ....S COM=" BKGD CIDC UPDATE"
    106         ....D NOW^%DTC S IFN=IFN+1,^PSRX(RXP,"A",0)="^52.3DA^"_IFN_"^"_IFN,^PSRX(RXP,"A",IFN,0)=%_"^I^.5^"_YY_"^"_COM
    107         ....K DA
    108         ....S:PSOOICD[1&($D(^PSRX(RXP,"IB"))) $P(^PSRX(RXP,"IB"),"^")=""
    109         ...D:'$G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)) ACCUM
    110         ...S PSOCPUN=SAVCPUN,PSOREF=SAVREF
    111         Q
    112         ;
    113 CHKACT  ;check activity log for prev entry
    114         N ZACT,ZPSI,ZACTI
    115         S ZPSI=0 F  S ZPSI=$O(^PSRX(PSODA,"COPAY",ZPSI)) Q:ZPSI=""  S ZACTI="",ZACTI=$G(^PSRX(PSODA,"COPAY",ZPSI,0)) D  Q:$G(ZACT)
    116         . I ZACTI["BKGD CIDC COPAY CANCEL"&($P(ZACTI,"^",2)="R") S PSOOLD="",PSONW="",PREA="C",ZACT=1 Q
    117         I '$G(ZACT) S PSOOLD="Copay",PSONW="No Copay",PREA="R" K PSOREF D ACTLOG^PSOCPA S PSOREF=YY,PSOOLD="",PSONW="",PREA="C"
    118         Q
    119         ;
    120 SETIBQ  ; get data from IBQ node, set IBQ node, and 1st piece of IB node
    121         K PSOANSQ
    122         N PSONIBQ
    123         F PSOTYP=1:1:8 D
    124         . I PSOTYP=1 S PSOANSQ("VEH")=$P(PSOOICD,"^",PSOTYP)
    125         . I PSOTYP=2 S PSOANSQ("RAD")=$P(PSOOICD,"^",PSOTYP)
    126         . I PSOTYP=3 S PSOANSQ("SC")=$P(PSOOICD,"^",PSOTYP)
    127         . I PSOTYP=4 S PSOANSQ("PGW")=$P(PSOOICD,"^",PSOTYP)
    128         . I PSOTYP=5 S PSOANSQ("MST")=$P(PSOOICD,"^",PSOTYP)
    129         . I PSOTYP=6 S PSOANSQ("HNC")=$P(PSOOICD,"^",PSOTYP)
    130         . I PSOTYP=7 S PSOANSQ("CV")=$P(PSOOICD,"^",PSOTYP)
    131         . I PSOTYP=8 S PSOANSQ("SHAD")=$P(PSOOICD,"^",PSOTYP)
    132         S ^PSRX(RXP,"IBQ")=PSOANSQ("SC")_"^"_PSOANSQ("MST")_"^"_PSOANSQ("VEH")_"^"_PSOANSQ("RAD")_"^"_PSOANSQ("PGW")_"^"_PSOANSQ("HNC")_"^"_PSOANSQ("CV")_"^"_PSOANSQ("SHAD")
    133         Q
    134         ;
    135 ACCUM   ; ACCUMULATE TOTALS
    136         S (PSOTOT,PSOYR,PSOYEAR,PSOLOG,PSONAM,PSOCHRG)=""
    137         ; get finished, but unreleased totals
    138         I PSOREL="" S PSOYR=$E(PSOFLD,1,3) Q:PSOYR=""  D  S PSOYEAR="" Q
    139         .S PSOYEAR=$S(PSOYR="304":"YR2004",PSOYR="305":"YR2005",PSOYR="306":"YR2006",1:"") Q:PSOYEAR=""
    140         .S PSOCHRG=7
    141         .I PSOYEAR="YR2006" S PSOCHRG=8
    142         .S PSOTOT=$G(^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR))
    143         .S ^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG)
    144         .S ^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR,PSOCPUN))+1
    145         .S PSONAM=$P($G(^DPT(PSODFN,0)),"^"),PSONAM=$P(PSONAM,",")
    146         .S PSONAM=$E(PSONAM,1,6)
    147         .S ^XTMP(NAMSP,"IBQ UPD",PSONAM,PSODFN,RXP,PSOREF)=PSOFLD
    148         ;for released ones
    149         S PSOYR=$E(PSOREL,1,3)
    150         S:PSOYR'="" PSOYEAR=$S(PSOYR="304":"YR2004",PSOYR="305":"YR2005",PSOYR="306":"YR2006",1:"")
    151         Q:PSOYEAR=""
    152         S PSOCHRG=7
    153         I PSOYEAR="YR2006" S PSOCHRG=8
    154         ;
    155         ;get Xtmp billing amt which would be IBAM tot + any previous refills
    156         S PSOTOT=$G(^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR))
    157         ;
    158         ;if none yet then init to the IBAM total for the year
    159         I 'PSOTOT D
    160         .F PSOSQ=0:0 S PSOSQ=$O(^IBAM(354.7,PSODFN,1,PSOSQ)) Q:'PSOSQ  D
    161         ..S PSOLOG=$G(^IBAM(354.7,PSODFN,1,PSOSQ,0))
    162         ..I $E(PSOLOG,1,3)=PSOYR S PSOTOT=PSOTOT+$P(PSOLOG,"^",2)
    163         ;
    164         ;update Xtmp tot nodes with current fill amounts
    165         ;  note:  cancel copays and updated IBQ node released prescription are collected under TOT REL for the RPT^PSOCIDC3
    166         ;             routine.  Cancelled copays are denoted with an asterisk.
    167         S ^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG)
    168         S ^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR,PSOCPUN))+1
    169         ;
    170         ;indicate COPAY CANCEL for this fill
    171         ;       ;by adding to Xtmp "BILLED"
    172         S PSONAM=$P($G(^DPT(PSODFN,0)),"^"),PSONAM=$P(PSONAM,",")
    173         S PSONAM=$E(PSONAM,1,6)
    174         S ^XTMP(NAMSP,"REL",PSONAM,PSODFN,RXP,PSOREF)=PSOREL
    175         ;
    176 CAN     I PSOTYPE="CAN"&($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY))) N PSOFILL S CANCEL="" S PSOFILL=YY D CHK^PSOCIDC3 I CANCEL D
    177         . S ^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG)
    178         . S ^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR,PSOCPUN))+1
    179         Q
    180         ;
    181 SITE    ; SET UP VARIABLES NEEDED BY BILLING
    182         S PSOSITE=$S(YY=0:$P(^PSRX(RXP,2),"^",9),1:$P($G(^PSRX(RXP,1,YY,0)),"^",9))
    183         Q:PSOSITE=""
    184         S PSOPAR=$G(^PS(59,PSOSITE,1))
    185         S PSOPAR7=$G(^PS(59,PSOSITE,"IB"))
    186         S PSOSITE7=$P($G(^PS(59,PSOSITE,"IB")),"^")
    187         Q
    188         ;
     1PSOCIDC2 ;BIR/LE-continuation of Copay Correction of erroneous billed copays ;11/8/05 12:50pm
     2 ;;7.0;OUTPATIENT PHARMACY;**226**;DEC 1997
     3 ;External reference to ^XUSEC supported by DBIA 10076
     4 ;External reference to IBARX supported by DBIA 125
     5 ;External reference to $$PROD^XUPROD(1) supported by DBIA 4440
     6 ;
     7TOTAL ;
     8 N COUNT,COUNTED,UCOUNT,UCOUNTED,CCOUNT,CCOUNTED
     9 I '$D(PSOVETS) S PSOVETS=0
     10 N I,J
     11 F I=1:1:3 S (PSOCNT("YR2004",I),PSOCNT("YR2005",I),PSOCNT("YR2006",I))=0
     12 S PSODFN=0 F  S PSODFN=$O(^XTMP(NAMSP,"TOT REL",PSODFN)) Q:'PSODFN  D
     13 .S COUNTED=0
     14 .F J="YR2004","YR2005","YR2006" F I=1:1:3 S COUNT=$G(^XTMP(NAMSP,"TOT REL",PSODFN,J,I)) I COUNT>0 S:'$G(COUNTED) COUNTED=1,PSOVETS=PSOVETS+1 S PSOCNT(J,I)=PSOCNT(J,I)+COUNT
     15 F I=1:1:3 S PSOCNT=PSOCNT+$G(PSOCNT("YR2004",I))+$G(PSOCNT("YR2005",I))+$G(PSOCNT("YR2006",I))
     16 ;
     17 S (I,J)=-""
     18 I '$D(PSOCVETS) S PSOCVETS=0
     19 F I=1:1:3 S (PSOCCNT("YR2004",I),PSOCCNT("YR2005",I),PSOCCNT("YR2006",I))=0
     20 S PSODFN=0 F  S PSODFN=$O(^XTMP(NAMSP,"TOT CAN",PSODFN)) Q:'PSODFN  D
     21 .S CCOUNTED=0
     22 .F J="YR2004","YR2005","YR2006" F I=1:1:3 S CCOUNT=$G(^XTMP(NAMSP,"TOT CAN",PSODFN,J,I)) I CCOUNT>0 S:'$G(CCOUNTED) CCOUNTED=1,PSOCVETS=PSOCVETS+1 S PSOCCNT(J,I)=PSOCCNT(J,I)+CCOUNT
     23 F I=1:1:3 S PSOCCNT=PSOCCNT+$G(PSOCCNT("YR2004",I))+$G(PSOCCNT("YR2005",I))+$G(PSOCCNT("YR2006",I))
     24 ;
     25 S (I,J)=""
     26 I '$D(PSOUVETS) S PSOUVETS=0
     27 F I=1:1:3 S (PSOUCNT("YR2004",I),PSOUCNT("YR2005",I),PSOUCNT("YR2006",I))=0
     28 S PSOUDFN=0 F  S PSOUDFN=$O(^XTMP(NAMSP,"TOT UNREL",PSOUDFN)) Q:'PSOUDFN  D
     29 .S UCOUNTED=0
     30 .F J="YR2004","YR2005","YR2006" F I=1:1:3 S UCOUNT=$G(^XTMP(NAMSP,"TOT UNREL",PSOUDFN,J,I)) I UCOUNT>0 S:'$G(UCOUNTED) UCOUNTED=1,PSOUVETS=PSOUVETS+1 S PSOUCNT(J,I)=PSOUCNT(J,I)+UCOUNT
     31 F I=1:1:3 S PSOUCNT=PSOUCNT+$G(PSOUCNT("YR2004",I))+$G(PSOUCNT("YR2005",I))+$G(PSOUCNT("YR2006",I))
     32 ;
     33 Q
     34 ;
     35CHECK ;check for ICD and IB nodes
     36 ;
     37 N PSOREF,PSOIB,PSOOICD,PSOBILLD
     38 S PSOREF=YY
     39 S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8)
     40 ; see if bill already exists
     41 I PSOREF=0 D
     42 . I +$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1
     43 . S PSOREL=$P($G(^PSRX(RXP,2)),"^",13)
     44 I PSOREF>0 D
     45 . I +$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1
     46 . S PSOREL=$P($G(^PSRX(RXP,1,YY,0)),"^",18)
     47 I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1
     48 ;    if billed/RELEASED and no IBQ node for both sc<50 and nsc
     49 I $G(PSOBILLD)&('$D(^PSRX(RXP,"IBQ"))) D
     50 . I $TR(PSOOICD,"^")[1  S ^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP
     51 . I $TR(PSOOICD,"^")[0 S ^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP
     52 ;           find unbilled ones with an ICD node and no IBQ node.
     53 I '$G(PSOBILLD)&('$D(^PSRX(RXP,"IBQ"))) D
     54 . Q:$TR(PSOOICD,"^")=""
     55 . S ^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP
     56 I YY S PSOTRF=PSOTRF+1
     57 Q
     58 ;
     59CANCEL ;Cancel erroneous copays/set IBQ node if not there
     60 ;released rx's
     61 N PSOCAP,PSODIV,PSODV,PSOFILL,PSOLOG,PSONAM,PSOOUT,PSOPAR,PSOPAR7,PSOSITE
     62 N PSOSITE7,PSOSQ,PSOTOT,PSOYEAR,PSOYR,SSN,SAVCPUN,SAVREF,PSOIB,PSOOIBQ,PSONIBQ,PSOOICD,PSOOIB
     63 N I,IFN,PSOANSQ,PSOTYP,COM,CC,PREA,PSONW,PSOOLD,PSOREL,PSO,PSOCPUN,PSOFLD,PSOTYPE,CANCEL
     64 S PSOTYPE="CAN"
     65 S PSODFN=0 F CC=1:1 S PSODFN=$O(^XTMP(NAMSP,"CANCEL",PSODFN)) Q:'PSODFN  D  Q:STOP
     66 .I CC#100=0,$D(^XTMP(NAMSP,0,"STOP")) D  Q
     67 .. S $P(^XTMP(NAMSP,0,"LAST"),"^",1,2)="STOP^"_$$NOW^XLFDT,STOP=1
     68 .S (PSOCAP(304),PSOCAP(305),PSOCAP(306))=0 ; INITIAL ANNUAL CAP FOR 2004 & 2005
     69 .F RXP=0:0 S RXP=$O(^XTMP(NAMSP,"CANCEL",PSODFN,RXP)) Q:'RXP  D
     70 ..S (SAVCPUN,PSOCPUN)=($P(^PSRX(RXP,0),"^",8)+29)\30
     71 ..S YY="" F  S YY=$O(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)) Q:YY=""  D
     72 ...S (SAVREF,PSOREF)=YY
     73 ...;  verify again that it was billed and not already cancelled
     74 ...S PSOBILLD=0
     75 ...I YY=0,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1 I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1
     76 ...I YY>0,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^")>0 D CHKIB^PSOCP1 I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1
     77 ...Q:'PSOBILLD
     78 ...S PSOREL=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^"),PSOFLD=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^",2),PSOSCP=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^",3)
     79 ...S PSO=3 D NOW^%DTC S PSODT=%,PSODA=RXP,PSOCOMM="-BKGD CIDC COPAY CANCEL",PSOOLD="",PSONW="",PREA=""
     80 ...D CHKACT
     81 ...S PSOIB="",PSOIB=$S(PSOREF>0:$G(^PSRX(RXP,1,YY,"IB")),'PSOREF:$G(^PSRX(PSODA,"IB")),1:"")
     82 ...S (PSOOIBQ,PSOOICD,PSOOIB)=""
     83 ...S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8),PSOOIB=$G(^PSRX(RXP,"IB")),PSOOIBQ=$G(^PSRX(RXP,"IBQ"))
     84 ...I PSOOIBQ=""&($TR(PSOOICD,"^")[0!($TR(PSOOICD,"^")[1)) D SETIBQ
     85 ...D SITE S PSOCOMM="-BKGD CIDC COPAY CANCEL" D RXED^PSOCPA S:PSOOICD[1&($D(^PSRX(RXP,"IB"))) $P(^PSRX(RXP,"IB"),"^")=""
     86 ...S PSOCPUN=SAVCPUN,PSOREF=SAVREF
     87 ...D ACCUM
     88 ;
     89 ;ICD NODES WITHOUT IBQ NODE; set IBQ node but only set 1st piece of IB node if unreleased.
     90 S PSOTYP="IBQ"
     91 S PSODFN=0 F CC=1:1 S PSODFN=$O(^XTMP(NAMSP,"NOIBQ",PSODFN)) Q:'PSODFN  D  Q:STOP
     92 .I CC#100=0,$D(^XTMP(NAMSP,0,"STOP")) D  Q
     93 .. S $P(^XTMP(NAMSP,0,"LAST"),"^",1,2)="STOP^"_$$NOW^XLFDT,STOP=1
     94 .S (PSOCAP(304),PSOCAP(305),PSOCAP(306))=0 ; INITIAL ANNUAL CAP FOR 2004 & 2005
     95 .F RXP=0:0 S RXP=$O(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP)) Q:'RXP  D
     96 ..S (SAVCPUN,PSOCPUN)=($P(^PSRX(RXP,0),"^",8)+29)\30
     97 ..S YY="" F  S YY=$O(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)) Q:YY=""  D
     98 ...S (SAVREF,PSOREF)=YY
     99 ...D SITE
     100 ...S PSOREL=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^"),PSOFLD=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^",2),PSOSCP=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^",3)
     101 ...S (PSOOIBQ,PSOOICD,PSOOIB)=""
     102 ...S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8),PSOOIB=$G(^PSRX(RXP,"IB")),PSOOIBQ=$G(^PSRX(RXP,"IBQ"))
     103 ...I PSOOIBQ=""&($TR(PSOOICD,"^")[0!($TR(PSOOICD,"^")[1)) D SETIBQ D   ;don't want to set again if already did it as part of copay cancel
     104 ....S I="",IFN=0 F I=0:0 S I=$O(^PSRX(RXP,"A",I)) Q:'I  S IFN=I
     105 ....S COM=" BKGD CIDC UPDATE"
     106 ....D NOW^%DTC S IFN=IFN+1,^PSRX(RXP,"A",0)="^52.3DA^"_IFN_"^"_IFN,^PSRX(RXP,"A",IFN,0)=%_"^I^.5^"_YY_"^"_COM
     107 ....K DA
     108 ....S:PSOOICD[1&($D(^PSRX(RXP,"IB"))) $P(^PSRX(RXP,"IB"),"^")=""
     109 ...D:'$G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)) ACCUM
     110 ...S PSOCPUN=SAVCPUN,PSOREF=SAVREF
     111 Q
     112 ;
     113CHKACT ;check activity log for prev entry
     114 N ZACT,ZPSI,ZACTI
     115 S ZPSI=0 F  S ZPSI=$O(^PSRX(PSODA,"COPAY",ZPSI)) Q:ZPSI=""  S ZACTI="",ZACTI=$G(^PSRX(PSODA,"COPAY",ZPSI,0)) D  Q:$G(ZACT)
     116 . I ZACTI["BKGD CIDC COPAY CANCEL"&($P(ZACTI,"^",2)="R") S PSOOLD="",PSONW="",PREA="C",ZACT=1 Q
     117 I '$G(ZACT) S PSOOLD="Copay",PSONW="No Copay",PREA="R" K PSOREF D ACTLOG^PSOCPA S PSOREF=YY,PSOOLD="",PSONW="",PREA="C"
     118 Q
     119 ;
     120SETIBQ ; get data from IBQ node, set IBQ node, and 1st piece of IB node
     121 K PSOANSQ
     122 N PSONIBQ
     123 F PSOTYP=1:1:7 D
     124 . I PSOTYP=1 S PSOANSQ("VEH")=$P(PSOOICD,"^",PSOTYP)
     125 . I PSOTYP=2 S PSOANSQ("RAD")=$P(PSOOICD,"^",PSOTYP)
     126 . I PSOTYP=3 S PSOANSQ("SC")=$P(PSOOICD,"^",PSOTYP)
     127 . I PSOTYP=4 S PSOANSQ("PGW")=$P(PSOOICD,"^",PSOTYP)
     128 . I PSOTYP=5 S PSOANSQ("MST")=$P(PSOOICD,"^",PSOTYP)
     129 . I PSOTYP=6 S PSOANSQ("HNC")=$P(PSOOICD,"^",PSOTYP)
     130 . I PSOTYP=7 S PSOANSQ("CV")=$P(PSOOICD,"^",PSOTYP)
     131 S ^PSRX(RXP,"IBQ")=PSOANSQ("SC")_"^"_PSOANSQ("MST")_"^"_PSOANSQ("VEH")_"^"_PSOANSQ("RAD")_"^"_PSOANSQ("PGW")_"^"_PSOANSQ("HNC")_"^"_PSOANSQ("CV")
     132 Q
     133 ;
     134ACCUM ; ACCUMULATE TOTALS
     135 S (PSOTOT,PSOYR,PSOYEAR,PSOLOG,PSONAM,PSOCHRG)=""
     136 ; get finished, but unreleased totals
     137 I PSOREL="" S PSOYR=$E(PSOFLD,1,3) Q:PSOYR=""  D  S PSOYEAR="" Q
     138 .S PSOYEAR=$S(PSOYR="304":"YR2004",PSOYR="305":"YR2005",PSOYR="306":"YR2006",1:"") Q:PSOYEAR=""
     139 .S PSOCHRG=7
     140 .I PSOYEAR="YR2006" S PSOCHRG=8
     141 .S PSOTOT=$G(^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR))
     142 .S ^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG)
     143 .S ^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR,PSOCPUN))+1
     144 .S PSONAM=$P($G(^DPT(PSODFN,0)),"^"),PSONAM=$P(PSONAM,",")
     145 .S PSONAM=$E(PSONAM,1,6)
     146 .S ^XTMP(NAMSP,"IBQ UPD",PSONAM,PSODFN,RXP,PSOREF)=PSOFLD
     147 ;for released ones
     148 S PSOYR=$E(PSOREL,1,3)
     149 S:PSOYR'="" PSOYEAR=$S(PSOYR="304":"YR2004",PSOYR="305":"YR2005",PSOYR="306":"YR2006",1:"")
     150 Q:PSOYEAR=""
     151 S PSOCHRG=7
     152 I PSOYEAR="YR2006" S PSOCHRG=8
     153 ;
     154 ;get Xtmp billing amt which would be IBAM tot + any previous refills
     155 S PSOTOT=$G(^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR))
     156 ;
     157 ;if none yet then init to the IBAM total for the year
     158 I 'PSOTOT D
     159 .F PSOSQ=0:0 S PSOSQ=$O(^IBAM(354.7,PSODFN,1,PSOSQ)) Q:'PSOSQ  D
     160 ..S PSOLOG=$G(^IBAM(354.7,PSODFN,1,PSOSQ,0))
     161 ..I $E(PSOLOG,1,3)=PSOYR S PSOTOT=PSOTOT+$P(PSOLOG,"^",2)
     162 ;
     163 ;update Xtmp tot nodes with current fill amounts
     164 ;  note:  cancel copays and updated IBQ node released prescription are collected under TOT REL for the RPT^PSOCIDC3
     165 ;             routine.  Cancelled copays are denoted with an asterisk.
     166 S ^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG)
     167 S ^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR,PSOCPUN))+1
     168 ;
     169 ;indicate COPAY CANCEL for this fill
     170 ;       ;by adding to Xtmp "BILLED"
     171 S PSONAM=$P($G(^DPT(PSODFN,0)),"^"),PSONAM=$P(PSONAM,",")
     172 S PSONAM=$E(PSONAM,1,6)
     173 S ^XTMP(NAMSP,"REL",PSONAM,PSODFN,RXP,PSOREF)=PSOREL
     174 ;
     175CAN I PSOTYPE="CAN"&($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY))) N PSOFILL S CANCEL="" S PSOFILL=YY D CHK^PSOCIDC3 I CANCEL D
     176 . S ^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG)
     177 . S ^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR,PSOCPUN))+1
     178 Q
     179 ;
     180SITE ; SET UP VARIABLES NEEDED BY BILLING
     181 S PSOSITE=$S(YY=0:$P(^PSRX(RXP,2),"^",9),1:$P($G(^PSRX(RXP,1,YY,0)),"^",9))
     182 Q:PSOSITE=""
     183 S PSOPAR=$G(^PS(59,PSOSITE,1))
     184 S PSOPAR7=$G(^PS(59,PSOSITE,"IB"))
     185 S PSOSITE7=$P($G(^PS(59,PSOSITE,"IB")),"^")
     186 Q
     187 ;

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCMOP.m

    r613 r623  
    1 PSOCMOP ;BIR/HTW-Rx Order Entry Screen for CMOP ; 6/28/07 7:35am
    2         ;;7.0;OUTPATIENT PHARMACY;**2,16,21,27,43,61,126,148,274**;DEC 1997;Build 8
    3         ;External reference to ^PS(55 supported by DBIA 2228
    4         ;External reference to ^PSDRUG supported by DBIA 221
    5         ;External reference to ^PSDRUG supported by DBIA 3165
    6         ;External reference to ^PSSHUIDG supported by DBIA 3621
    7 TOP     ;
    8         I $G(PSOFROM)="EDIT" S PPL=$G(PSORX("PSOL",1)) Q:$G(PPL)']""  G TEST
    9         I $G(PPL) G START
    10         I '$G(RXLTOP) S PPL=$G(DA) G TEST
    11         S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$G(PPL)']"" D1
    12 START   ;          Establish CMOP PPL
    13 TEST    N ACT,B,C,CK,COMM,CNT,DFLG,I,FLAG,MW,NEWDT,PI,P1,P2,REL,RFD,RX,RX0,RXN
    14         N RXP,RXS,SD,VALMSG,X,X7,Y,ZD,DFN,TRX
    15         S (P1,P2)=1,FLAG=0
    16         ;   PSOMC=Mail Code, PSOMDT=Mail Code Expiration Date
    17         S TRX=$P($G(PPL),",",1)
    18         S DFN=$P(^PSRX(TRX,0),"^",2),PSOMDT=$P($G(^PS(55,DFN,0)),"^",5),PSOMC=$P($G(^PS(55,DFN,0)),"^",3) K DFN,TRX
    19         I (PSOMC>1&(PSOMDT>DT))!(PSOMC>1&(PSOMDT<1)) K PSOMC,PSOMDT G RESET
    20 LOOP    F CNT=1:1 S RX=$P($G(PPL),",",CNT) Q:RX']""  D  S:'FLAG $P(RX("PSO"),",",P1)=RX,P1=P1+1 S FLAG=0
    21         .;          Get drug IEN and check if CMOP
    22         .S CK=$P($G(^PSRX(RX,0)),"^",6) Q:'$D(^PSDRUG("AQ",CK))
    23         .;          If not marked for O.P., unmark for CMOP...
    24         .I $P($G(^PSDRUG(CK,2)),"^",3)'["O" D UNMARK^PSOCMOP Q
    25         .;          Check Drug Warning >11
    26         .N WARNS,COMM S WARNS=$P(^PSDRUG(CK,0),U,8) I $L(WARNS)>11 D  Q
    27         .. S COMM(1)="Rx# "_$P(^PSRX(RX,0),"^")_" CMOP cannot dispense - Drug warnings >11 characters."
    28         .. S COMM(2)="Drug Name: "_$P(^PSDRUG(CK,0),U)_"  (IEN: # "_CK_")"
    29         .. D COMM(RX,.COMM)
    30         .;           Q:If partial or pull early
    31         .Q:$G(RXPR(RX))!($G(RXRS(RX)))
    32         .;           Q:If standard reprint but allow edit reprint
    33         .I $G(RXRP(RX))&($P($G(RXRP(RX)),"^",4)'=1) Q
    34         .;           Q:If tradename
    35         .Q:$G(^PSRX(RX,"TN"))]""
    36         .;           Q: If Cancelled, Expired, Deleted, Hold
    37         .Q:$P(^PSRX(RX,"STA"),"^")>9!($P(^("STA"),"^")=4)!($P(^("STA"),"^")=3)
    38         .;        Find last fill
    39         .S RFD=0 F X7=0:0 S X7=$O(^PSRX(RX,1,X7)) Q:'$G(X7)  S (RFD)=X7
    40         .Q:$G(RXFL(RX))&(RFD)&($G(RXFL(RX))'=RFD)
    41         .I '$O(^PSRX(RX,1,0)),'$P($G(^PSRX(RX,2)),"^",13),$P($G(^(0)),"^",11)="W",$S($P($G(^PSRX(RX,2)),"^",2):$P($G(^(2)),"^",2),1:+$G(PSOX("FILL DATE")))>DT D
    42         ..S PSOCPDA=$G(DA) K DIE S DA=RX,DIE="^PSRX(",DR="11////M" D ^DIE K DIE S:$G(PSOCPDA) DA=$G(PSOCPDA) K PSOCPDA
    43         .;           Q:If not "Mail"
    44         .S MW=$S($G(RFD)>0:$P(^PSRX(RX,1,RFD,0),"^",2),1:$P(^PSRX(RX,0),"^",11)) K X7 I $G(MW)="W"  K RFD Q
    45         .;
    46         .;           Q:If fill was CMOPed and other than a '3' 'not dispensed'
    47         .Q:'$$FILTRAN(RX,RFD)
    48         .;
    49         .;            Check if released, for use in Sus
    50         .S REL=$S(RFD=0:$P($G(^PSRX(RX,2)),"^",13),1:$P($G(^PSRX(RX,1,RFD,0)),"^",18)) K RFD
    51         .I $G(REL) Q
    52         .;           Save CMOP's in PSXPPL1
    53         .S $P(RX("CMOP"),",",P2)=RX,P2=P2+1,FLAG=1 Q
    54         K PPL S PPL=$G(RX("PSO")),RX1("CMOP")=$G(RX("CMOP")) K RX("PSO")
    55         G:$G(XFROM)="EDIT" D1 ; passed from PSXEDIT
    56 RESET   ;
    57         G:'$G(RX("CMOP")) D1
    58         I $G(XFROM)="REINSTATE"!($G(XFROM)="UNHOLD") Q
    59         I $G(PSOFROM)="EDIT",($G(REL)]"") S PPL=RX("CMOP") G D1
    60 S       ;           Auto-Suspend CMOPS
    61         N DA,Y
    62         F PI=1:1 S DA=$P($G(RX("CMOP")),",",PI) Q:'DA  D SUS
    63         S SUSPT="SUSPENSE"
    64         G D1
    65 SUS     ;
    66         I $G(XFROM)="REINSTATE" W !,RX_" REINSTATED -- "
    67         S ACT=1,RXN=DA,RX0=^PSRX(DA,0),SD=$S($G(ZD(DA)):$E(ZD(DA),1,7),1:$P(^(3),"^")),RXS=$O(^PS(52.5,"B",DA,0)) I RXS D  Q:$G(DFLG)
    68         .S DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN
    69         K X7 S RFD1=0 F X7=0:0 S X7=$O(^PSRX(DA,1,X7)) Q:'$G(X7)  S (RFD1)=X7
    70 LOCK    S RXP=+$G(RXPR(DA)),DIC="^PS(52.5,",DIC(0)="",X=RXN
    71         S DIC("DR")=".02////"_SD_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04////M;.05////"_RXP_";.06////"_PSOSITE_";2////0;3////Q;9////"_RFD1
    72         K DD,DO D FILE^DICN K DD,DO S DA=RXN I +Y S PSONAME=$P(^PSRX(DA,0),"^",2) K ^PS(52.5,"AC",PSONAME,SD,+Y),PSONAME
    73         S $P(^PSRX(RXN,"STA"),"^")=5,LFD=$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3) D ACT
    74         W !!,"RX# ",$P(^PSRX(RXN,0),"^")_" HAS BEEN SUSPENDED for CMOP Until "_LFD_"."
    75         S VALMSG="Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended for CMOP Until "_LFD_"."
    76         S COMM="Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended for CMOP Until "_LFD_"."
    77         D EN^PSOHLSN1(RXN,"SC","ZS",COMM) K COMM
    78         ;- Calling ECME to reverse any PAYABLE claim for the prescription/fill
    79         D REVERSE^PSOBPSU1(RXN,,"DC",3)
    80         Q
    81 ACT     S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S RXF=I S:I>5 RXF=I+1
    82         S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA  S IR=FDA
    83         S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
    84         D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^S^"_DUZ_"^"_RXF_"^"_"RX Placed on Suspense for CMOP until "_LFD
    85         K RXF,I,FDA,DIC,DIE,DR,Y,X,%,%H,%I
    86         Q
    87 D1      K CNT,COUNT,DFLG,DIRUT,DIROUT,DTOUT,DUOUT,EXDT,FLAG,FLD,L,PDUZ,PI,X7
    88         K PSOCMOP,REF,REPRINT,RFDATE,RFL1,RFLL,RXPD,SD,SUSPT,WARN,XFROM,ZY,RX1
    89         Q
    90 RXL     N FROM S FROM=$G(PSOFROM)
    91         I ((FROM="NEW")!(FROM="REFILL")!(FROM="CANCEL")!(FROM="BATCH")!($G(XFROM)="HOLD")!($G(XFROM)="BATCH")) G TOP
    92         Q
    93 SUS1    ;
    94         N PPL
    95         S PPL=DA D TEST
    96         I $G(PPL)']"" S XFLAG=1
    97         S RX("CMOP")=$G(RX1("CMOP"))
    98         Q
    99 A       S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1)) G:$G(PPL)']"" D1
    100         G TEST
    101 UNMARK  ;Entry point to unmark drug for CMOP dispense
    102         N X,Z,%
    103         S $P(^PSDRUG(CK,3),"^",1)=0 K ^PSDRUG("AQ",CK)
    104         S:'$D(^PSDRUG(CK,4,0)) ^PSDRUG(CK,4,0)="^50.0214DA^^"
    105         S (X,Z)=0 F  S Z=$O(^PSDRUG(CK,4,Z)) Q:'Z  S X=Z
    106         S X=X+1 D NOW^%DTC S ^PSDRUG(CK,4,X,0)=%_"^E^"_DUZ_"^CMOP Dispense^"_$S($G(^PSDRUG(CK,3))=1:"YES",$G(^PSDRUG(CK,3))=0:"NO",1:"")
    107         S $P(^PSDRUG(CK,4,0),"^",3)=X,$P(^(0),"^",4)=$P(^(0),"^",4)+1
    108         I $$PATCH^XPDUTL("PSS*1.0*70") D DRG^PSSHUIDG(CK)
    109         K X,Z,%
    110         Q
    111 FILTRAN(RX,RFD) ; Test fill's CMOP tran status, return 1 if OK to send
    112         N DA,CMOP
    113         S DA=RX
    114         D ^PSOCMOPA
    115         I '$D(CMOP(RFD)) Q 1
    116         I CMOP(RFD)=3 Q 1
    117         Q 0
    118 COMM(RXN,COMM)  ;EP process problem message to g.cmop managers
    119         N XMSUB,XMTEXT
    120         S XMTEXT="COMM(",XMY("I:G.CMOP MANAGERS")=""
    121         S XMSUB="CMOP RX PROBLEM ENCOUNTERED"
    122         D ^XMD
    123         Q
    124 CMPRXTYP(SUSDA) ; given suspense record SUSDA returns RX CMOP TYPE C - CS, N -Non-CS
    125         ;used in compound index ^PS(52.5,"CMP",STAT,TYP,DIV,DATE,DFN,DA)
    126         N RXDA,DRGDA,DEA,TYP
    127         S RXDA=$P(^PS(52.5,SUSDA,0),U),DRGDA=$P(^PSRX(RXDA,0),U,6)
    128         S TYP="N",DEA=$P(^PSDRUG(DRGDA,0),U,3) F I=3,4,5 I DEA[I S TYP="C"
    129         Q TYP
    130 NOW()   D NOW^%DTC Q %
    131         ;
    132 PIECE(REC,DLM,VP)       ; VP="Variable^Piece"
    133         ; Set Variable V = piece P of REC using delimiter DLM
    134         N V,P S V=$P(VP,U),P=$P(VP,U,2),@V=$P(REC,DLM,P)
    135         Q
    136 PUT(REC,DLM,VP) ; VP="Variable^Piece"
    137         ; pass by reference D PUT^PSOCMOP(.REC,DLM,VP)
    138         ; Set Variable V into piece P of REC using delimiter DLM
    139         N V,P S V=$P(VP,U),P=$P(VP,U,2)
    140         S $P(REC,DLM,P)=$G(@V)
    141         Q
    142 KCMPX(SUS,VAL)  ; Kill ^PS(52.5,"CMP",VAL index given SUS
    143         N SDT,TYP,DFN,DIV,RX,F,XX
    144         S F=$G(^PS(52.5,SUS,0)) Q:'+F  S TYP=$$CMPRXTYP(SUS)
    145         F XX="RX^1","SDT^2","DFN^3","DIV^6" D PIECE(F,U,XX)
    146         K ^PS(52.5,"CMP",VAL,TYP,DIV,SDT,DFN,SUS)
    147         Q
    148 SCMPX(SUS,VAL)  ; Set  ^PS(52.5,"CMP",VAL index given SUS
    149         N SDT,TYP,DFN,DIV,RX,F,XX
    150         S F=$G(^PS(52.5,SUS,0)) Q:'+F  S TYP=$$CMPRXTYP(SUS)
    151         F XX="RX^1","SDT^2","DFN^3","DIV^6" D PIECE(F,U,XX)
    152         S ^PS(52.5,"CMP",VAL,TYP,DIV,SDT,DFN,SUS)=""
    153         Q
     1PSOCMOP ;BIR/HTW-Rx Order Entry Screen for CMOP ;02/19/98  9:21 AM
     2 ;;7.0;OUTPATIENT PHARMACY;**2,16,21,27,43,61,126,148**;DEC 1997
     3 ;External reference to ^PS(55 supported by DBIA 2228
     4 ;External reference to ^PSDRUG supported by DBIA 221
     5 ;External reference to ^PSDRUG supported by DBIA 3165
     6 ;External reference to ^PSSHUIDG supported by DBIA 3621
     7TOP ;
     8 I $G(PSOFROM)="EDIT" S PPL=$G(PSORX("PSOL",1)) Q:$G(PPL)']""  G TEST
     9 I $G(PPL) G START
     10 I '$G(RXLTOP) S PPL=$G(DA) G TEST
     11 S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$G(PPL)']"" D1
     12START ;          Establish CMOP PPL
     13TEST N ACT,B,C,CK,COMM,CNT,DFLG,I,FLAG,MW,NEWDT,PI,P1,P2,REL,RFD,RX,RX0,RXN
     14 N RXP,RXS,SD,VALMSG,X,X7,Y,ZD,DFN,TRX
     15 S (P1,P2)=1,FLAG=0
     16 ;   PSOMC=Mail Code, PSOMDT=Mail Code Expiration Date
     17 S TRX=$P($G(PPL),",",1)
     18 S DFN=$P(^PSRX(TRX,0),"^",2),PSOMDT=$P($G(^PS(55,DFN,0)),"^",5),PSOMC=$P($G(^PS(55,DFN,0)),"^",3) K DFN,TRX
     19 I (PSOMC>1&(PSOMDT>DT))!(PSOMC>1&(PSOMDT<1)) K PSOMC,PSOMDT G RESET
     20LOOP F CNT=1:1 S RX=$P($G(PPL),",",CNT) Q:RX']""  D  S:'FLAG $P(RX("PSO"),",",P1)=RX,P1=P1+1 S FLAG=0
     21 .;          Get drug IEN and check if CMOP
     22 .S CK=$P($G(^PSRX(RX,0)),"^",6) Q:'$D(^PSDRUG("AQ",CK))
     23 .;          If not marked for O.P., unmark for CMOP...
     24 .I $P($G(^PSDRUG(CK,2)),"^",3)'["O" D UNMARK^PSOCMOP Q
     25 .;          Check Drug Warning >11
     26 .N WARNS,COMM S WARNS=$P(^PSDRUG(CK,0),U,8) I $L(WARNS)>11 D  Q
     27 .. S COMM(1)="Rx# "_$P(^PSRX(RX,0),"^")_" CMOP cannot dispense - Drug warnings >11 characters."
     28 .. S COMM(2)="Drug Name: "_$P(^PSDRUG(CK,0),U)_"  (IEN: # "_CK_")"
     29 .. D COMM(RX,.COMM)
     30 .;           Q:If partial or pull early
     31 .Q:$G(RXPR(RX))!($G(RXRS(RX)))
     32 .;           Q:If standard reprint but allow edit reprint
     33 .I $G(RXRP(RX))&($P($G(RXRP(RX)),"^",4)'=1) Q
     34 .;           Q:If tradename
     35 .Q:$G(^PSRX(RX,"TN"))]""
     36 .;           Q: If Cancelled, Expired, Deleted, Hold
     37 .Q:$P(^PSRX(RX,"STA"),"^")>9!($P(^("STA"),"^")=4)!($P(^("STA"),"^")=3)
     38 .;        Find last fill
     39 .S RFD=0 F X7=0:0 S X7=$O(^PSRX(RX,1,X7)) Q:'$G(X7)  S (RFD)=X7
     40 .Q:$G(RXFL(RX))&(RFD)&($G(RXFL(RX))'=RFD)
     41 .I '$O(^PSRX(RX,1,0)),'$P($G(^PSRX(RX,2)),"^",13),$P($G(^(0)),"^",11)="W",$S($P($G(^PSRX(RX,2)),"^",2):$P($G(^(2)),"^",2),1:+$G(PSOX("FILL DATE")))>DT D
     42 ..S PSOCPDA=$G(DA) K DIE S DA=RX,DIE="^PSRX(",DR="11////M" D ^DIE K DIE S:$G(PSOCPDA) DA=$G(PSOCPDA) K PSOCPDA
     43 .;           Q:If not "Mail"
     44 .S MW=$S($G(RFD)>0:$P(^PSRX(RX,1,RFD,0),"^",2),1:$P(^PSRX(RX,0),"^",11)) K X7 I $G(MW)="W"  K RFD Q
     45 .;
     46 .;           Q:If fill was CMOPed and other than a '3' 'not dispensed'
     47 .Q:'$$FILTRAN(RX,RFD)
     48 .;
     49 .;            Check if released, for use in Sus
     50 .S REL=$S(RFD=0:$P($G(^PSRX(RX,2)),"^",13),1:$P($G(^PSRX(RX,1,RFD,0)),"^",18)) K RFD
     51 .I $G(REL) Q
     52 .;           Save CMOP's in PSXPPL1
     53 .S $P(RX("CMOP"),",",P2)=RX,P2=P2+1,FLAG=1 Q
     54 K PPL S PPL=$G(RX("PSO")),RX1("CMOP")=$G(RX("CMOP")) K RX("PSO")
     55 G:$G(XFROM)="EDIT" D1 ; passed from PSXEDIT
     56RESET ;
     57 G:'$G(RX("CMOP")) D1
     58 I $G(XFROM)="REINSTATE"!($G(XFROM)="UNHOLD") Q
     59 I $G(PSOFROM)="EDIT",($G(REL)]"") S PPL=RX("CMOP") G D1
     60S ;           Auto-Suspend CMOPS
     61 N DA,Y
     62 F PI=1:1 S DA=$P($G(RX("CMOP")),",",PI) Q:'DA  D SUS
     63 S SUSPT="SUSPENSE"
     64 G D1
     65SUS ;
     66 I $G(XFROM)="REINSTATE" W !,RX_" REINSTATED -- "
     67 S ACT=1,RXN=DA,RX0=^PSRX(DA,0),SD=$S($G(ZD(DA)):$E(ZD(DA),1,7),1:$P(^(3),"^")),RXS=$O(^PS(52.5,"B",DA,0)) I RXS D  Q:$G(DFLG)
     68 .S DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN
     69 K X7 S RFD1=0 F X7=0:0 S X7=$O(^PSRX(DA,1,X7)) Q:'$G(X7)  S (RFD1)=X7
     70LOCK S RXP=+$G(RXPR(DA)),DIC="^PS(52.5,",DIC(0)="",X=RXN
     71 S DIC("DR")=".02////"_SD_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04////M;.05////"_RXP_";.06////"_PSOSITE_";2////0;3////Q;9////"_RFD1
     72 K DD,DO D FILE^DICN K DD,DO S DA=RXN I +Y S PSONAME=$P(^PSRX(DA,0),"^",2) K ^PS(52.5,"AC",PSONAME,SD,+Y),PSONAME
     73 S $P(^PSRX(RXN,"STA"),"^")=5,LFD=$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3) D ACT
     74 W !!,"RX# ",$P(^PSRX(RXN,0),"^")_" HAS BEEN SUSPENDED for CMOP Until "_LFD_"."
     75 S VALMSG="Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended for CMOP Until "_LFD_"."
     76 S COMM="Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended for CMOP Until "_LFD_"."
     77 D EN^PSOHLSN1(RXN,"SC","ZS",COMM) K COMM
     78 ;- Calling ECME to reverse any PAYABLE claim for the prescription/fill
     79 D REVERSE^PSOBPSU1(RXN,,"DC",3)
     80 Q
     81ACT I '$D(RXF) S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S RXF=I S:I>5 RXF=I+1
     82 S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA  S IR=FDA
     83 S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
     84 D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^S^"_DUZ_"^"_RXF_"^"_"RX Placed on Suspense for CMOP until "_LFD
     85 K RXF,I,FDA,DIC,DIE,DR,Y,X,%,%H,%I
     86 Q
     87D1 K CNT,COUNT,DFLG,DIRUT,DIROUT,DTOUT,DUOUT,EXDT,FLAG,FLD,L,PDUZ,PI,X7
     88 K PSOCMOP,REF,REPRINT,RFDATE,RFL1,RFLL,RXPD,SD,SUSPT,WARN,XFROM,ZY,RX1
     89 Q
     90RXL N FROM S FROM=$G(PSOFROM)
     91 I ((FROM="NEW")!(FROM="REFILL")!(FROM="CANCEL")!(FROM="BATCH")!($G(XFROM)="HOLD")!($G(XFROM)="BATCH")) G TOP
     92 Q
     93SUS1 ;
     94 N PPL
     95 S PPL=DA D TEST
     96 I $G(PPL)']"" S XFLAG=1
     97 S RX("CMOP")=$G(RX1("CMOP"))
     98 Q
     99A S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1)) G:$G(PPL)']"" D1
     100 G TEST
     101UNMARK ;Entry point to unmark drug for CMOP dispense
     102 N X,Z,%
     103 S $P(^PSDRUG(CK,3),"^",1)=0 K ^PSDRUG("AQ",CK)
     104 S:'$D(^PSDRUG(CK,4,0)) ^PSDRUG(CK,4,0)="^50.0214DA^^"
     105 S (X,Z)=0 F  S Z=$O(^PSDRUG(CK,4,Z)) Q:'Z  S X=Z
     106 S X=X+1 D NOW^%DTC S ^PSDRUG(CK,4,X,0)=%_"^E^"_DUZ_"^CMOP Dispense^"_$S($G(^PSDRUG(CK,3))=1:"YES",$G(^PSDRUG(CK,3))=0:"NO",1:"")
     107 S $P(^PSDRUG(CK,4,0),"^",3)=X,$P(^(0),"^",4)=$P(^(0),"^",4)+1
     108 I $$PATCH^XPDUTL("PSS*1.0*70") D DRG^PSSHUIDG(CK)
     109 K X,Z,%
     110 Q
     111FILTRAN(RX,RFD) ; Test fill's CMOP tran status, return 1 if OK to send
     112 N DA,CMOP
     113 S DA=RX
     114 D ^PSOCMOPA
     115 I '$D(CMOP(RFD)) Q 1
     116 I CMOP(RFD)=3 Q 1
     117 Q 0
     118COMM(RXN,COMM) ;EP process problem message to g.cmop managers
     119 N XMSUB,XMTEXT
     120 S XMTEXT="COMM(",XMY("I:G.CMOP MANAGERS")=""
     121 S XMSUB="CMOP RX PROBLEM ENCOUNTERED"
     122 D ^XMD
     123 Q
     124CMPRXTYP(SUSDA) ; given suspense record SUSDA returns RX CMOP TYPE C - CS, N -Non-CS
     125 ;used in compound index ^PS(52.5,"CMP",STAT,TYP,DIV,DATE,DFN,DA)
     126 N RXDA,DRGDA,DEA,TYP
     127 S RXDA=$P(^PS(52.5,SUSDA,0),U),DRGDA=$P(^PSRX(RXDA,0),U,6)
     128 S TYP="N",DEA=$P(^PSDRUG(DRGDA,0),U,3) F I=3,4,5 I DEA[I S TYP="C"
     129 Q TYP
     130NOW() D NOW^%DTC Q %
     131 ;
     132PIECE(REC,DLM,VP) ; VP="Variable^Piece"
     133 ; Set Variable V = piece P of REC using delimiter DLM
     134 N V,P S V=$P(VP,U),P=$P(VP,U,2),@V=$P(REC,DLM,P)
     135 Q
     136PUT(REC,DLM,VP) ; VP="Variable^Piece"
     137 ; pass by reference D PUT^PSOCMOP(.REC,DLM,VP)
     138 ; Set Variable V into piece P of REC using delimiter DLM
     139 N V,P S V=$P(VP,U),P=$P(VP,U,2)
     140 S $P(REC,DLM,P)=$G(@V)
     141 Q
     142KCMPX(SUS,VAL) ; Kill ^PS(52.5,"CMP",VAL index given SUS
     143 N SDT,TYP,DFN,DIV,RX,F,XX
     144 S F=$G(^PS(52.5,SUS,0)) Q:'+F  S TYP=$$CMPRXTYP(SUS)
     145 F XX="RX^1","SDT^2","DFN^3","DIV^6" D PIECE(F,U,XX)
     146 K ^PS(52.5,"CMP",VAL,TYP,DIV,SDT,DFN,SUS)
     147 Q
     148SCMPX(SUS,VAL) ; Set  ^PS(52.5,"CMP",VAL index given SUS
     149 N SDT,TYP,DFN,DIV,RX,F,XX
     150 S F=$G(^PS(52.5,SUS,0)) Q:'+F  S TYP=$$CMPRXTYP(SUS)
     151 F XX="RX^1","SDT^2","DFN^3","DIV^6" D PIECE(F,U,XX)
     152 S ^PS(52.5,"CMP",VAL,TYP,DIV,SDT,DFN,SUS)=""
     153 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCP.m

    r613 r623  
    1 PSOCP   ;BIR/BAB - Pharmacy CO-PAY Application Utilities for IB ;02/06/92
    2         ;;7.0;OUTPATIENT PHARMACY;**20,46,71,85,137,157,143,219,239,201,225**;DEC 1997;Build 29
    3         ;
    4         ;REF/IA - IBARX/125, SDCO22/1579, PS(55/2228, PSDRUG(/221, DGMSTAPI/2716, $$GETSHAD^DGUTL3/4462
    5 CP      ;Check if COPAY-Requires RXP,PSOSITE7
    6         I '$D(PSOPAR) D ^PSOLSET G CP
    7         K PSOCP
    8         S PSOCPN=$P(^PSRX(RXP,0),"^",2) ; Set COPAY dfn PTR TO PATIENT
    9         S PSOCP=$P($G(^PSRX(RXP,"IB")),"^") ; IB action type
    10         S PSOSAVE=$S(PSOCP:1,1:"") ; save current copay status
    11         ; Set x=service^dfn^actiontype^user duz
    12         I +$G(PSOSITE7)'>0 S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^")
    13         S X=PSOSITE7_"^"_PSOCPN_"^"_PSOCP_"^"_$P(^PSRX(RXP,0),"^",16)
    14         ;
    15 RX      ;Determine Orig or Refill for RX
    16         N PSOIB,PSOPFS S (PSOIB,PSOREF)=0
    17         I $G(^PSRX(RXP,1,+$G(YY),0))]"" S PSOREF=YY
    18         D PFSA^PSOPFSU1(RXP,PSOREF,2) G PFS:+PSOPFS
    19         ; Check if bill exists
    20         I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1 I PSOIB G QUIT
    21         I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",4)>0 G QUIT ; 'POTENTIAL BILL' - ALREADY ATTEMPTED TO BILL, BUT EXCEEDED ANNUAL COPAY CAP
    22         I PSOREF,+$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1 I PSOIB G QUIT
    23         I PSOREF,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^",2) G QUIT ; POTENTIAL BILL
    24 PFS     ;
    25         S PSOCHG=1 ; set tem var to copay and check exception
    26         N MAILMSG
    27         D COPAYREL
    28         I 'PSOCHG D  D:PSOPFS CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS) G QUIT
    29         . I PSOSAVE S PSODA=RXP,PREA="R" D ACTLOG^PSOCPA S $P(^PSRX(RXP,"IB"),"^",1)=""
    30         I PSOCHG=2 D  I 'PSOCP D:PSOPFS CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS) G QUIT ; IF 'SC' QUESTION APPLIES, BUT HAS NOT BEEN ANSWERED, SEND MAIL MSG AND KEEP COPAY STATUS AS IT WAS
    31         . D MAIL2^PSOCPE ; SEND MAIL TO PHARMACIST, PROVIDER, AND HOLDERS OF THE PSO COPAY KEY
    32         I PSOCHG=1,PSOSAVE="" D  I PSOREF S PSOCOMM="",PSOOLD="No Copay",PSONW="Copay" S PSODA=RXP,PREA="R" D ACTLOG^PSOCPA
    33         . I '$D(^PSRX(RXP,"IB")),'PSOREF S $P(^PSRX(RXP,"IB"),"^",1)=1 Q
    34         . S $P(^PSRX(RXP,"IB"),"^",1)=1
    35         . S PSOCP=1,$P(X,"^",3)=PSOCP
    36         I PSOCHG'=2 I $G(MAILMSG) D MAIL2^PSOCPE ; SEND MAIL TO PHARM, PROV, AND HOLDERS OF PSO COPAY KEY HOLDERS
    37         ; Units for COPAY
    38         S PSOCPUN=$P(($P(^PSRX(RXP,0),"^",8)+29)/30,".",1)
    39         ; Build softlink for x(n)=softlink^units
    40         S X(1)="52:"_RXP S:PSOREF>0 X(1)=X(1)_";1:"_PSOREF S X(1)=X(1)_"^"_PSOCPUN
    41         ; Set correct user duz if refill
    42         I PSOREF S:+$P(^PSRX(RXP,1,PSOREF,0),"^",7)>0 $P(X,"^",4)=$P(^PSRX(RXP,1,PSOREF,0),"^",7)
    43         ;
    44 IBNEW   ;  Load ^TMP global for IB call
    45         Q:$G(RXP)'>0
    46         I PSOPFS D CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS)
    47         G QUIT:PSOPFS
    48         N D0
    49         G QUIT:'$D(X)
    50         S XTMP=X,XTMP(1)=X(1)
    51         ;
    52         ; Requires x=service^dfn^action type^user duz
    53         ;   x(n)=softlink^units
    54         I $P(X,"^",3)="" S $P(X,"^",3)=$P(^PSRX(RXP,"IB"),"^",1)
    55         D NEW^IBARX
    56         ; Returns y=1^total charges for this group or Y=-1^error code
    57         ;         y(n)=IB number^charge for this Rx^AR bill #^Cap met^Partial or Full charge^Copay Exempt^Number from file 354.71
    58         ;         Cap met ('1' - If patient has met cap amount or reached cap with this charge or '0' if not)
    59         ;         Partial or Full ('P' for partial billing, 'F' for full billing, null for no billing)
    60         ;         Copay Exempt - ('1' for exempt, '0' for non-exempt, '-1' for copay off (manila)),
    61         ;            ('1' - If patient has met cap amount or reach cap with this charge
    62         ; Entry from file 354.71 will only be saved for fills that met the annual cap and could not be fully billed
    63         ;
    64         G QUIT:+Y=-1
    65         S XTMP=XTMP_"^"_Y,XTMP(1)=XTMP(1)_"^"_Y(1)
    66         ;
    67         ; see if exempt or copay cap was met
    68         I $P(Y(1),"^",6) D  G QUIT
    69         . S PREA="R",PSOOLD="Copay",PSONW="No Copay"
    70         . S PSOCOMM="RX COPAY INCOME EXEMPTION" S PSODA=RXP D ACTLOG^PSOCPA
    71         . S $P(^PSRX(RXP,"IB"),"^",1)=""
    72         I $P(Y(1),"^",4) D
    73         . S PSOCOMM=$S($P(Y(1),"^",5)="F":" FULL BILLING FOR THIS FILL",$P(Y(1),"^",5)="P":" PARTIAL BILLING FOR THIS FILL ",1:" NO BILLING FOR THIS FILL")
    74         . S PREA="A"
    75         . S PSODA=RXP D ACTLOG^PSOCPA
    76         . I $P(Y(1),"^",5)'="F" D
    77         . . I PSOREF S $P(^PSRX(RXP,1,PSOREF,"IB"),"^",2)=$P(Y(1),"^",7) Q
    78         . . S $P(^PSRX(RXP,"IB"),"^",4)=$P(Y(1),"^",7)
    79         I $P(Y(1),"^",1)="" G QUIT
    80         ;
    81 FILE    ;File IB number in ^PSRX
    82         S PSOCP2=0
    83         S PSOCP2=+$P(XTMP(1),":",3)
    84         S:PSOCP2>0 ^PSRX(RXP,1,PSOCP2,"IB")=$P(XTMP(1),U,3) ;  Filing in refill node
    85         I PSOCP2>0,'$D(^PSRX(RXP,"IB")) S ^PSRX(RXP,"IB")="1^^" ;  If refill "IB" exists, need "IB" entry on original fill node
    86         S:PSOCP2=0 $P(^PSRX(RXP,"IB"),"^",2)=$P(XTMP(1),U,3) ;Filing in original fill (zero node)
    87 QUIT    ;
    88         K Y,PSOCP1,PSOCP2,QQ,PSOCPN,X,X2,XTMP,PSOCPUN,PSOREF,PSOCHG,PSOSAVE,PSOCOMM,PSOOLD,PSONW,PREA,PSORSN
    89         Q
    90 EN      D ^PSOLSET
    91 EN1     S DIR(0)="NO",DIR("A")="Enter PRESCRIPTION number" D ^DIR K DIR G:$D(DIRUT) EXIT S RXP=X I +$G(^PSRX(RXP,0))'>0!+$P($G(^PSRX(RXP,"IB")),"^",0)>0 W !,?10,"RE-CHECK PRESCRIPTION NUMBER AND RE-ENTER " G EN1
    92         S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^")
    93         S PSODFN=$P(^PSRX(RXP,0),"^",2)
    94         D CP G EN1
    95 EXIT    K RXP D FINAL^PSOLSET Q
    96         ;
    97 SC(PSODFN,PSODD)        ;sup ref for CPRS, Pre-Copay enhancement
    98         N PSOSC
    99         I $$DT^PSOMLLDT S PSOSC="" G SCQ
    100         I $G(PSODD),($P($G(^PSDRUG(PSODD,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") S PSOSC=1 G SCQ
    101         I $P($G(^PS(55,+$G(PSODFN),"PS")),"^"),$P($G(^PS(53,+$P(^("PS"),"^"),0)),"^",7) S PSOSC=1 G SCQ
    102         N I,J,X S (X,PSOSC)=""
    103         S J=0 F  S J=$O(^PS(59,J)) Q:'J  I +$G(^(J,"IB")) S X=+^("IB") Q
    104         G:'X SCQ
    105         S X=X_"^"_PSODFN D XTYPE^IBARX
    106         S J="" F  S J=$O(Y(J)) Q:'J  S I="" F  S I=$O(Y(J,I)) Q:I=""  S:I>0 PSOSC=I
    107 SCQ     Q $S($G(PSOSC)=2:0,1:1)
    108         ;
    109 COPAYREL        ; Recheck copay status at release
    110         ; check Rx patient status
    111         I $P(^PSRX(RXP,0),"^",3)'="",$P($G(^PS(53,$P(^PSRX(RXP,0),"^",3),0)),"^",7)=1 S PSOCHG=0,PSOCOMM="Rx Patient Status Change",PSOOLD="Copay",PSONW="No Copay" Q
    112         ; see if drug is investigational or supply
    113         N DRG,DRGTYP,X
    114         S DRG=+$P(^PSRX(RXP,0),"^",6),DRGTYP=$P($G(^PSDRUG(DRG,0)),"^",3)
    115         I DRGTYP["I" S PSOCOMM="Investigational Drug",PSOCHG=0,PSOOLD="Copay",PSONW="No Copay",PSOCHG=0
    116         I DRGTYP["S" S PSOCOMM="Supply Item",PSOCHG=0,PSOOLD="Copay",PSONW="No Copay",PSOCHG=0
    117         K PSOTG,CHKXTYPE
    118         I +$G(^PSRX(RXP,"IBQ")) D XTYPE1^PSOCP1
    119         I $G(^PSRX(RXP,"IBQ"))["1" D  S PSOCHG=0,PSOOLD="Copay",PSONW="No Copay" Q  ; COPAY EXEMPT
    120         . N EXMT,II,PSOCIBQ
    121         . S PSOCIBQ=$G(^PSRX(RXP,"IBQ"))
    122         . F II=1,7,3,4,5,6,2,8 I $P(PSOCIBQ,"^",II)=1 S EXMT=$S(II=1:"SC",II=7:"CV",II=3:"AO",II=4:"IR",II=5:"EC",II=8:"SHAD",II=2:"MST",II=6:"HNC",1:"") D:EXMT'="" SETCOMM Q
    123         D SCNEW(.PSOTG,PSOCPN,DRG,RXP)
    124         N EXMT
    125         I '$D(CHKXTYPE) D XTYPE
    126         F EXMT="SC","CV","AO","IR","EC","SHAD","MST","HNC" I $D(PSOTG(EXMT)) D  I 'PSOCHG Q
    127         . I PSOTG(EXMT)=1 S PSOCHG=0 D SETCOMM
    128         I 'PSOCHG S PSOOLD="Copay",PSONW="No Copay" Q
    129         ;
    130         ; If any of the applicable exemption quest have never been answered, send a mail msg with all of the quest
    131         S EXMT="",MAILMSG=0 F  S EXMT=$O(PSOTG(EXMT)) Q:EXMT=""  I PSOTG(EXMT)="" S MAILMSG=1 Q
    132         I MAILMSG,$D(PSOTG("SC")) I $G(PSOTG("SC"))="" S PSOCHG=2 ; 'SC' quest not answered, don't reset copay status to 'copay'
    133         Q
    134         ;
    135 SCNEW(PSOTG,PSOPT,PSODR,PSORN)  ;CPRS supported ref
    136         I '$$DT^PSOMLLDT Q
    137         I '$G(PSOPT) Q
    138         ;I $G(PSODR),($P($G(^PSDRUG(PSODR,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") Q ;CIDC ALWAYS ASK
    139         N PSOCIBQ,PSOQMSH,PSOQVEH,PSOQRQD,PSOQHNC,PSOQPGW,DFN,PSOSCA,ZXX
    140         K PSOANSQ("SC>50")
    141         S DFN=PSOPT
    142         D SCP^PSORN52D S:PSOSCP>49&(PSOSCA) PSOANSQ("SC>50")=1
    143         I $G(PSORN) D
    144         . S PSOCIBQ=$G(^PSRX(PSORN,"IBQ"))
    145         . I $TR(PSOCIBQ,"^")="" S ZXX=$G(^PSRX(PSORN,"ICD",1,0)) D ICD:ZXX'=""
    146         I '$G(PSORN) S PSOCIBQ=""
    147         ;Rx Patient Status check is not being done here
    148         N PSOSCMX,Y,I,J,X S (X,PSOSCMX)=""
    149         S J=0 F  S J=$O(^PS(59,J)) Q:'J  I +$G(^(J,"IB")) S X=+^("IB") Q
    150         G:'X SKIP
    151         S X=X_"^"_PSOPT D XTYPE^IBARX
    152         S J="" F  S J=$O(Y(J)) Q:'J  S I="" F  S I=$O(Y(J,I)) Q:I=""  S:I>0 PSOSCMX=I
    153 SKIP    ;
    154         I $G(PSOSCA)!($G(PSOSCMX)=2) S PSOTG("SC")=$S($P(PSOCIBQ,"^")=1:1,$P(PSOCIBQ,"^")=0:0,$G(PSORN)&($P($G(^PSRX(+$G(PSORN),"IB")),"^")):0,1:"")
    155         S:$$AO^SDCO22(PSOPT) PSOTG("AO")=$S($P(PSOCIBQ,"^",3)=1:1,$P(PSOCIBQ,"^",3)=0:0,1:"")
    156         S:$$IR^SDCO22(PSOPT) PSOTG("IR")=$S($P(PSOCIBQ,"^",4)=1:1,$P(PSOCIBQ,"^",4)=0:0,1:"")
    157         S:$$EC^SDCO22(PSOPT) PSOTG("EC")=$S($P(PSOCIBQ,"^",5)=1:1,$P(PSOCIBQ,"^",5)=0:0,1:"")
    158         S:$P($$GETSTAT^DGMSTAPI(PSOPT),"^",2)="Y" PSOTG("MST")=$S($P(PSOCIBQ,"^",2)=1:1,$P(PSOCIBQ,"^",2)=0:0,1:"")
    159         I $T(GETCUR^DGNTAPI)]"" N PSONC,PSONCX S PSONCX=$$GETCUR^DGNTAPI(PSOPT,"PSONC") I $P($G(PSONC("IND")),"^")="Y" S PSOTG("HNC")=$S($P(PSOCIBQ,"^",6)=1:1,$P(PSOCIBQ,"^",6)=0:0,1:"")
    160         S:$P($$CVEDT^DGCV(PSOPT),"^",3) PSOTG("CV")=$S($P(PSOCIBQ,"^",7)=1:1,$P(PSOCIBQ,"^",7)=0:0,1:"")
    161         I $L($T(GETSHAD^DGUTL3)) S:$$GETSHAD^DGUTL3(PSOPT)=1 PSOTG("SHAD")=$S($P(PSOCIBQ,"^",8)=1:1,$P(PSOCIBQ,"^",8)=0:0,1:"")
    162         Q
    163         ;
    164 ICD     ;
    165         D ICD^PSOCP1
    166         Q
    167 XTYPE   ;
    168         N PSOCIBQ,PSOSCMX,Y,I,J,X,SAVY,ZXX
    169         S (X,PSOSCMX,SAVY)=""
    170         S PSOCIBQ=$G(^PSRX(RXP,"IBQ")) I $TR(PSOCIBQ,"^")="" S ZXX=$G(^PSRX(RXP,"ICD",1,0)) D ICD:ZXX'=""
    171         I $P(PSOCIBQ,"^",1)'="" S PSOTG("SC")=$P(PSOCIBQ,"^",1)
    172         I $D(PSOTG("SC")),$P(PSOCIBQ,"^",1)="" S PSOTG("SC")="" ; USE "CURRENT" SETTING AS ANS TO SC QUEST IF IT APPLIES
    173         S J=0 F  S J=$O(^PS(59,J)) Q:'J  I +$G(^(J,"IB")) S X=+^("IB") Q
    174         I 'X Q
    175         S X=X_"^"_PSOCPN D XTYPE^IBARX
    176         I $G(Y)'=1 Q
    177         S J="" F  S J=$O(Y(J)) Q:'J  S I="" F  S SAVY=I,I=$O(Y(J,I)) Q:I=""  S:I>0 PSOSCMX=I
    178         I PSOSCMX="",SAVY=0 S PSOCHG=0 S PSOCOMM="Exempt from copayment" Q  ; INCOME EXEMPT OR SC
    179         I PSOSCMX=2,'$D(PSOTG("SC")) S PSOTG("SC")=$S(($G(RXP)&($P($G(^PSRX(+$G(RXP),"IB")),"^")))!($P(PSOCIBQ,"^")=0):0,$P(PSOCIBQ,"^")=1:1,1:"") Q
    180         Q
    181         ;
    182 SETCOMM ;
    183         D SETCOMM^PSOCP1
    184         Q
    185         ;
     1PSOCP ;BIR/BAB - Pharmacy CO-PAY Application Utilities for IB ;02/06/92
     2 ;;7.0;OUTPATIENT PHARMACY;**20,46,71,85,137,157,143,219,239,201**;DEC 1997
     3 ;
     4 ;REF/IA - IBARX/125, SDCO22/1579, PS(55/2228, PSDRUG(/221, DGMSTAPI/2716
     5CP ;Check if COPAY-Requires RXP,PSOSITE7
     6 I '$D(PSOPAR) D ^PSOLSET G CP
     7 K PSOCP
     8 S PSOCPN=$P(^PSRX(RXP,0),"^",2) ; Set COPAY dfn PTR TO PATIENT
     9 S PSOCP=$P($G(^PSRX(RXP,"IB")),"^") ; IB action type
     10 S PSOSAVE=$S(PSOCP:1,1:"") ; save current copay status
     11 ; Set x=service^dfn^actiontype^user duz
     12 I +$G(PSOSITE7)'>0 S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^")
     13 S X=PSOSITE7_"^"_PSOCPN_"^"_PSOCP_"^"_$P(^PSRX(RXP,0),"^",16)
     14 ;
     15RX ;Determine Orig or Refill for RX
     16 N PSOIB,PSOPFS S (PSOIB,PSOREF)=0
     17 I $G(^PSRX(RXP,1,+$G(YY),0))]"" S PSOREF=YY
     18 D PFSA^PSOPFSU1(RXP,PSOREF,2) G PFS:+PSOPFS
     19 ; Check if bill exists
     20 I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1 I PSOIB G QUIT
     21 I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",4)>0 G QUIT ; 'POTENTIAL BILL' - ALREADY ATTEMPTED TO BILL, BUT EXCEEDED ANNUAL COPAY CAP
     22 I PSOREF,+$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1 I PSOIB G QUIT
     23 I PSOREF,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^",2) G QUIT ; POTENTIAL BILL
     24PFS ;
     25 S PSOCHG=1 ; set tem var to copay and check exception
     26 N MAILMSG
     27 D COPAYREL
     28 I 'PSOCHG D  D:PSOPFS CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS) G QUIT
     29 . I PSOSAVE S PSODA=RXP,PREA="R" D ACTLOG^PSOCPA S $P(^PSRX(RXP,"IB"),"^",1)=""
     30 I PSOCHG=2 D  I 'PSOCP D:PSOPFS CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS) G QUIT ; IF 'SC' QUESTION APPLIES, BUT HAS NOT BEEN ANSWERED, SEND MAIL MSG AND KEEP COPAY STATUS AS IT WAS
     31 . D MAIL2^PSOCPE ; SEND MAIL TO PHARMACIST, PROVIDER, AND HOLDERS OF THE PSO COPAY KEY
     32 I PSOCHG=1,PSOSAVE="" D  I PSOREF S PSOCOMM="",PSOOLD="No Copay",PSONW="Copay" S PSODA=RXP,PREA="R" D ACTLOG^PSOCPA
     33 . I '$D(^PSRX(RXP,"IB")),'PSOREF S $P(^PSRX(RXP,"IB"),"^",1)=1 Q
     34 . S $P(^PSRX(RXP,"IB"),"^",1)=1
     35 . S PSOCP=1,$P(X,"^",3)=PSOCP
     36 I PSOCHG'=2 I $G(MAILMSG) D MAIL2^PSOCPE ; SEND MAIL TO PHARM, PROV, AND HOLDERS OF PSO COPAY KEY HOLDERS
     37 ; Units for COPAY
     38 S PSOCPUN=$P(($P(^PSRX(RXP,0),"^",8)+29)/30,".",1)
     39 ; Build softlink for x(n)=softlink^units
     40 S X(1)="52:"_RXP S:PSOREF>0 X(1)=X(1)_";1:"_PSOREF S X(1)=X(1)_"^"_PSOCPUN
     41 ; Set correct user duz if refill
     42 I PSOREF S:+$P(^PSRX(RXP,1,PSOREF,0),"^",7)>0 $P(X,"^",4)=$P(^PSRX(RXP,1,PSOREF,0),"^",7)
     43 ;
     44IBNEW ;  Load ^TMP global for IB call
     45 Q:$G(RXP)'>0
     46 I PSOPFS D CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS)
     47 G QUIT:PSOPFS
     48 N D0
     49 G QUIT:'$D(X)
     50 S XTMP=X,XTMP(1)=X(1)
     51 ;
     52 ; Requires x=service^dfn^action type^user duz
     53 ;   x(n)=softlink^units
     54 I $P(X,"^",3)="" S $P(X,"^",3)=$P(^PSRX(RXP,"IB"),"^",1)
     55 D NEW^IBARX
     56 ; Returns y=1^total charges for this group or Y=-1^error code
     57 ;         y(n)=IB number^charge for this Rx^AR bill #^Cap met^Partial or Full charge^Copay Exempt^Number from file 354.71
     58 ;         Cap met ('1' - If patient has met cap amount or reached cap with this charge or '0' if not)
     59 ;         Partial or Full ('P' for partial billing, 'F' for full billing, null for no billing)
     60 ;         Copay Exempt - ('1' for exempt, '0' for non-exempt, '-1' for copay off (manila)),
     61 ;            ('1' - If patient has met cap amount or reach cap with this charge
     62 ; Entry from file 354.71 will only be saved for fills that met the annual cap and could not be fully billed
     63 ;
     64 G QUIT:+Y=-1
     65 S XTMP=XTMP_"^"_Y,XTMP(1)=XTMP(1)_"^"_Y(1)
     66 ;
     67 ; see if exempt or copay cap was met
     68 I $P(Y(1),"^",6) D  G QUIT
     69 . S PREA="R",PSOOLD="Copay",PSONW="No Copay"
     70 . S PSOCOMM="RX COPAY INCOME EXEMPTION" S PSODA=RXP D ACTLOG^PSOCPA
     71 . S $P(^PSRX(RXP,"IB"),"^",1)=""
     72 I $P(Y(1),"^",4) D
     73 . S PSOCOMM=$S($P(Y(1),"^",5)="F":" FULL BILLING FOR THIS FILL",$P(Y(1),"^",5)="P":" PARTIAL BILLING FOR THIS FILL ",1:" NO BILLING FOR THIS FILL")
     74 . S PREA="A"
     75 . S PSODA=RXP D ACTLOG^PSOCPA
     76 . I $P(Y(1),"^",5)'="F" D
     77 . . I PSOREF S $P(^PSRX(RXP,1,PSOREF,"IB"),"^",2)=$P(Y(1),"^",7) Q
     78 . . S $P(^PSRX(RXP,"IB"),"^",4)=$P(Y(1),"^",7)
     79 I $P(Y(1),"^",1)="" G QUIT
     80 ;
     81FILE ;File IB number in ^PSRX
     82 S PSOCP2=0
     83 S PSOCP2=+$P(XTMP(1),":",3)
     84 S:PSOCP2>0 ^PSRX(RXP,1,PSOCP2,"IB")=$P(XTMP(1),U,3) ;  Filing in refill node
     85 I PSOCP2>0,'$D(^PSRX(RXP,"IB")) S ^PSRX(RXP,"IB")="1^^" ;  If refill "IB" exists, need "IB" entry on original fill node
     86 S:PSOCP2=0 $P(^PSRX(RXP,"IB"),"^",2)=$P(XTMP(1),U,3) ;Filing in original fill (zero node)
     87QUIT ;
     88 K Y,PSOCP1,PSOCP2,QQ,PSOCPN,X,X2,XTMP,PSOCPUN,PSOREF,PSOCHG,PSOSAVE,PSOCOMM,PSOOLD,PSONW,PREA,PSORSN
     89 Q
     90EN D ^PSOLSET
     91EN1 S DIR(0)="NO",DIR("A")="Enter PRESCRIPTION number" D ^DIR K DIR G:$D(DIRUT) EXIT S RXP=X I +$G(^PSRX(RXP,0))'>0!+$P($G(^PSRX(RXP,"IB")),"^",0)>0 W !,?10,"RE-CHECK PRESCRIPTION NUMBER AND RE-ENTER " G EN1
     92 S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^")
     93 S PSODFN=$P(^PSRX(RXP,0),"^",2)
     94 D CP G EN1
     95EXIT K RXP D FINAL^PSOLSET Q
     96 ;
     97SC(PSODFN,PSODD) ;sup ref for CPRS, Pre-Copay enhancement
     98 N PSOSC
     99 I $$DT^PSOMLLDT S PSOSC="" G SCQ
     100 I $G(PSODD),($P($G(^PSDRUG(PSODD,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") S PSOSC=1 G SCQ
     101 I $P($G(^PS(55,+$G(PSODFN),"PS")),"^"),$P($G(^PS(53,+$P(^("PS"),"^"),0)),"^",7) S PSOSC=1 G SCQ
     102 N I,J,X S (X,PSOSC)=""
     103 S J=0 F  S J=$O(^PS(59,J)) Q:'J  I +$G(^(J,"IB")) S X=+^("IB") Q
     104 G:'X SCQ
     105 S X=X_"^"_PSODFN D XTYPE^IBARX
     106 S J="" F  S J=$O(Y(J)) Q:'J  S I="" F  S I=$O(Y(J,I)) Q:I=""  S:I>0 PSOSC=I
     107SCQ Q $S($G(PSOSC)=2:0,1:1)
     108 ;
     109COPAYREL ; Recheck copay status at release
     110 ; check Rx patient status
     111 I $P(^PSRX(RXP,0),"^",3)'="",$P($G(^PS(53,$P(^PSRX(RXP,0),"^",3),0)),"^",7)=1 S PSOCHG=0,PSOCOMM="Rx Patient Status Change",PSOOLD="Copay",PSONW="No Copay" Q
     112 ; see if drug is investigational or supply
     113 N DRG,DRGTYP,X
     114 S DRG=+$P(^PSRX(RXP,0),"^",6),DRGTYP=$P($G(^PSDRUG(DRG,0)),"^",3)
     115 I DRGTYP["I" S PSOCOMM="Investigational Drug",PSOCHG=0,PSOOLD="Copay",PSONW="No Copay",PSOCHG=0
     116 I DRGTYP["S" S PSOCOMM="Supply Item",PSOCHG=0,PSOOLD="Copay",PSONW="No Copay",PSOCHG=0
     117 K PSOTG,CHKXTYPE
     118 I +$G(^PSRX(RXP,"IBQ")) D XTYPE1^PSOCP1
     119 I $G(^PSRX(RXP,"IBQ"))["1" D  S PSOCHG=0,PSOOLD="Copay",PSONW="No Copay" Q  ; COPAY EXEMPT
     120 . N EXMT,II,PSOCIBQ
     121 . S PSOCIBQ=$G(^PSRX(RXP,"IBQ"))
     122 . F II=1,7,3,4,5,6,2 I $P(PSOCIBQ,"^",II)=1 S EXMT=$S(II=1:"SC",II=7:"CV",II=3:"AO",II=4:"IR",II=5:"EC",II=2:"MST",II=6:"HNC",1:"") D:EXMT'="" SETCOMM Q
     123 D SCNEW(.PSOTG,PSOCPN,DRG,RXP)
     124 N EXMT
     125 I '$D(CHKXTYPE) D XTYPE
     126 F EXMT="SC","CV","AO","IR","EC","MST","HNC" I $D(PSOTG(EXMT)) D  I 'PSOCHG Q
     127 . I PSOTG(EXMT)=1 S PSOCHG=0 D SETCOMM
     128 I 'PSOCHG S PSOOLD="Copay",PSONW="No Copay" Q
     129 ;
     130 ; If any of the applicable exemption quest have never been answered, send a mail msg with all of the quest
     131 S EXMT="",MAILMSG=0 F  S EXMT=$O(PSOTG(EXMT)) Q:EXMT=""  I PSOTG(EXMT)="" S MAILMSG=1 Q
     132 I MAILMSG,$D(PSOTG("SC")) I $G(PSOTG("SC"))="" S PSOCHG=2 ; 'SC' quest not answered, don't reset copay status to 'copay'
     133 Q
     134 ;
     135SCNEW(PSOTG,PSOPT,PSODR,PSORN) ;CPRS supported ref
     136 I '$$DT^PSOMLLDT Q
     137 I '$G(PSOPT) Q
     138 ;I $G(PSODR),($P($G(^PSDRUG(PSODR,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") Q ;CIDC ALWAYS ASK
     139 N PSOCIBQ,PSOQMSH,PSOQVEH,PSOQRQD,PSOQHNC,PSOQPGW,DFN,PSOSCA,ZXX
     140 K PSOANSQ("SC>50")
     141 S DFN=PSOPT
     142 D SCP^PSORN52D S:PSOSCP>49&(PSOSCA) PSOANSQ("SC>50")=1
     143 I $G(PSORN) D
     144 . S PSOCIBQ=$G(^PSRX(PSORN,"IBQ"))
     145 . I $TR(PSOCIBQ,"^")="" S ZXX=$G(^PSRX(PSORN,"ICD",1,0)) D ICD:ZXX'=""
     146 I '$G(PSORN) S PSOCIBQ=""
     147 ;Rx Patient Status check is not being done here
     148 N PSOSCMX,Y,I,J,X S (X,PSOSCMX)=""
     149 S J=0 F  S J=$O(^PS(59,J)) Q:'J  I +$G(^(J,"IB")) S X=+^("IB") Q
     150 G:'X SKIP
     151 S X=X_"^"_PSOPT D XTYPE^IBARX
     152 S J="" F  S J=$O(Y(J)) Q:'J  S I="" F  S I=$O(Y(J,I)) Q:I=""  S:I>0 PSOSCMX=I
     153SKIP ;
     154 I $G(PSOSCA)!($G(PSOSCMX)=2) S PSOTG("SC")=$S($P(PSOCIBQ,"^")=1:1,$P(PSOCIBQ,"^")=0:0,$G(PSORN)&($P($G(^PSRX(+$G(PSORN),"IB")),"^")):0,1:"")
     155 S:$$AO^SDCO22(PSOPT) PSOTG("AO")=$S($P(PSOCIBQ,"^",3)=1:1,$P(PSOCIBQ,"^",3)=0:0,1:"")
     156 S:$$IR^SDCO22(PSOPT) PSOTG("IR")=$S($P(PSOCIBQ,"^",4)=1:1,$P(PSOCIBQ,"^",4)=0:0,1:"")
     157 S:$$EC^SDCO22(PSOPT) PSOTG("EC")=$S($P(PSOCIBQ,"^",5)=1:1,$P(PSOCIBQ,"^",5)=0:0,1:"")
     158 S:$P($$GETSTAT^DGMSTAPI(PSOPT),"^",2)="Y" PSOTG("MST")=$S($P(PSOCIBQ,"^",2)=1:1,$P(PSOCIBQ,"^",2)=0:0,1:"")
     159 I $T(GETCUR^DGNTAPI)]"" N PSONC,PSONCX S PSONCX=$$GETCUR^DGNTAPI(PSOPT,"PSONC") I $P($G(PSONC("IND")),"^")="Y" S PSOTG("HNC")=$S($P(PSOCIBQ,"^",6)=1:1,$P(PSOCIBQ,"^",6)=0:0,1:"")
     160 S:$P($$CVEDT^DGCV(PSOPT),"^",3) PSOTG("CV")=$S($P(PSOCIBQ,"^",7)=1:1,$P(PSOCIBQ,"^",7)=0:0,1:"")
     161 Q
     162 ;
     163ICD ;
     164 D ICD^PSOCP1
     165 Q
     166XTYPE ;
     167 N PSOCIBQ,PSOSCMX,Y,I,J,X,SAVY,ZXX
     168 S (X,PSOSCMX,SAVY)=""
     169 S PSOCIBQ=$G(^PSRX(RXP,"IBQ")) I $TR(PSOCIBQ,"^")="" S ZXX=$G(^PSRX(RXP,"ICD",1,0)) D ICD:ZXX'=""
     170 I $P(PSOCIBQ,"^",1)'="" S PSOTG("SC")=$P(PSOCIBQ,"^",1)
     171 I $D(PSOTG("SC")),$P(PSOCIBQ,"^",1)="" S PSOTG("SC")="" ; USE "CURRENT" SETTING AS ANS TO SC QUEST IF IT APPLIES
     172 S J=0 F  S J=$O(^PS(59,J)) Q:'J  I +$G(^(J,"IB")) S X=+^("IB") Q
     173 I 'X Q
     174 S X=X_"^"_PSOCPN D XTYPE^IBARX
     175 I $G(Y)'=1 Q
     176 S J="" F  S J=$O(Y(J)) Q:'J  S I="" F  S SAVY=I,I=$O(Y(J,I)) Q:I=""  S:I>0 PSOSCMX=I
     177 I PSOSCMX="",SAVY=0 S PSOCHG=0 S PSOCOMM="Exempt from copayment" Q  ; INCOME EXEMPT OR SC
     178 I PSOSCMX=2,'$D(PSOTG("SC")) S PSOTG("SC")=$S(($G(RXP)&($P($G(^PSRX(+$G(RXP),"IB")),"^")))!($P(PSOCIBQ,"^")=0):0,$P(PSOCIBQ,"^")=1:1,1:"") Q
     179 Q
     180 ;
     181SETCOMM ;
     182 D SETCOMM^PSOCP1
     183 Q
     184 ;

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCP1.m

    r613 r623  
    1 PSOCP1  ;BHAM ISC/EJW-PHARMACY CO-PAY APPLICATION UTILITIES FOR IB (CONT'D) ;12/12/02
    2         ;;7.0;OUTPATIENT PHARMACY;**137,239,225**;DEC 1997;Build 29
    3         ;
    4         ;REF/IA
    5         ;IBARX/125
    6 CHKIB   ; SEE IF BILL # IS A CHARGE OR CANCELLATION #
    7         N IBN,XX
    8         I PSOREF=0 S XX=$G(^PSRX(RXP,"IB")) I $P(XX,"^",4)'="" S PSOIB=1 Q  ;ALREADY BILLED
    9         I PSOREF=0 S IBN=$P(XX,"^",2)
    10         I PSOREF'=0 S XX=$G(^PSRX(RXP,1,PSOREF,"IB")) I $P(XX,"^",2)'="" S PSOIB=1 Q  ;ALREADY BILLED
    11         I PSOREF'=0 S IBN=$P(XX,"^",1)
    12         I IBN'="" D STATUS
    13         Q
    14         ;
    15 STATUS  ;
    16         N XX
    17         S XX=$$STATUS^IBARX(IBN)
    18         I XX'=1,XX'=3 Q
    19         S PSOIB=1 ; ALREADY BILLED
    20         Q
    21         ;
    22 XTYPE1  ;
    23         N PSOCIBQ,PSOSCMX,Y,I,J,X,SAVY
    24         S (X,PSOSCMX,SAVY)=""
    25         S PSOCIBQ=$G(^PSRX(RXP,"IBQ"))
    26         I $P(PSOCIBQ,"^",1)'=1 Q
    27         S J=0 F  S J=$O(^PS(59,J)) Q:'J  I +$G(^(J,"IB")) S X=+^("IB") Q
    28         I 'X Q
    29         S X=X_"^"_PSOCPN D XTYPE^IBARX
    30         I $G(Y)'=1 Q
    31         S J="" F  S J=$O(Y(J)) Q:'J  S I="" F  S SAVY=I,I=$O(Y(J,I)) Q:I=""  S:I>0 PSOSCMX=I
    32         I PSOSCMX="",SAVY=0 Q  ; INCOME EXEMPT OR SERVICE-CONNECTED
    33         I PSOSCMX=2 Q  ; NEED TO ASK SC QUESTION
    34         ; If get to here, service-connected question does not apply for this patient anymore.  Update "IBQ" and CPRS
    35         S $P(^PSRX(RXP,"IBQ"),"^",1)="",CHKXTYPE=1
    36         D EN^PSOHLSN1(RXP,"XX","","Order edited")
    37         Q
    38         ;
    39 SETCOMM ;
    40         I EXMT="SC" S PSOCOMM="Service Connected" Q
    41         I EXMT="CV" S PSOCOMM="COMBAT VETERAN" Q
    42         I EXMT="AO" S PSOCOMM="AGENT ORANGE RELATED" Q
    43         I EXMT="IR" S PSOCOMM="IONIZING RAD RELATED" Q
    44         I EXMT="EC" S PSOCOMM="SW ASIA COND. RELATED" Q
    45         I EXMT="SHAD" S PSOCOMM="PROJ 112/SHAD" Q
    46         I EXMT="MST" S PSOCOMM="MILITARY SEXUAL TRAUMA" Q
    47         I EXMT="HNC" S PSOCOMM="Head and/or Neck Cancer" Q
    48         Q
    49         ;
    50 ICD     ;
    51         S PSOCIBQ=$P(ZXX,U,4)_"^"_$P(ZXX,U,6)_"^"_$P(ZXX,U,2)_"^"_$P(ZXX,U,3)_"^"_$P(ZXX,U,5)_"^"_$P(ZXX,U,7)_"^"_$P(ZXX,U,8)_"^"_$P(ZXX,U,9)
    52         Q
    53         ;
     1PSOCP1 ;BHAM ISC/EJW-PHARMACY CO-PAY APPLICATION UTILITIES FOR IB (CONT'D) ;12/12/02
     2 ;;7.0;OUTPATIENT PHARMACY;**137,239**;DEC 1997
     3 ;
     4 ;REF/IA
     5 ;IBARX/125
     6CHKIB ; SEE IF BILL # IS A CHARGE OR CANCELLATION #
     7 N IBN,XX
     8 I PSOREF=0 S XX=$G(^PSRX(RXP,"IB")) I $P(XX,"^",4)'="" S PSOIB=1 Q  ;ALREADY BILLED
     9 I PSOREF=0 S IBN=$P(XX,"^",2)
     10 I PSOREF'=0 S XX=$G(^PSRX(RXP,1,PSOREF,"IB")) I $P(XX,"^",2)'="" S PSOIB=1 Q  ;ALREADY BILLED
     11 I PSOREF'=0 S IBN=$P(XX,"^",1)
     12 I IBN'="" D STATUS
     13 Q
     14 ;
     15STATUS ;
     16 N XX
     17 S XX=$$STATUS^IBARX(IBN)
     18 I XX'=1,XX'=3 Q
     19 S PSOIB=1 ; ALREADY BILLED
     20 Q
     21 ;
     22XTYPE1 ;
     23 N PSOCIBQ,PSOSCMX,Y,I,J,X,SAVY
     24 S (X,PSOSCMX,SAVY)=""
     25 S PSOCIBQ=$G(^PSRX(RXP,"IBQ"))
     26 I $P(PSOCIBQ,"^",1)'=1 Q
     27 S J=0 F  S J=$O(^PS(59,J)) Q:'J  I +$G(^(J,"IB")) S X=+^("IB") Q
     28 I 'X Q
     29 S X=X_"^"_PSOCPN D XTYPE^IBARX
     30 I $G(Y)'=1 Q
     31 S J="" F  S J=$O(Y(J)) Q:'J  S I="" F  S SAVY=I,I=$O(Y(J,I)) Q:I=""  S:I>0 PSOSCMX=I
     32 I PSOSCMX="",SAVY=0 Q  ; INCOME EXEMPT OR SERVICE-CONNECTED
     33 I PSOSCMX=2 Q  ; NEED TO ASK SC QUESTION
     34 ; If get to here, service-connected question does not apply for this patient anymore.  Update "IBQ" and CPRS
     35 S $P(^PSRX(RXP,"IBQ"),"^",1)="",CHKXTYPE=1
     36 D EN^PSOHLSN1(RXP,"XX","","Order edited")
     37 Q
     38 ;
     39SETCOMM ;
     40 I EXMT="SC" S PSOCOMM="Service Connected" Q
     41 I EXMT="CV" S PSOCOMM="COMBAT VETERAN" Q
     42 I EXMT="AO" S PSOCOMM="AGENT ORANGE RELATED" Q
     43 I EXMT="IR" S PSOCOMM="IONIZING RAD RELATED" Q
     44 I EXMT="EC" S PSOCOMM="ENV CONTAMINANTS RELATED" Q
     45 I EXMT="MST" S PSOCOMM="MILITARY SEXUAL TRAUMA" Q
     46 I EXMT="HNC" S PSOCOMM="Head and/or Neck Cancer" Q
     47 Q
     48 ;
     49ICD ;
     50 S PSOCIBQ=$P(ZXX,U,4)_"^"_$P(ZXX,U,6)_"^"_$P(ZXX,U,2)_"^"_$P(ZXX,U,3)_"^"_$P(ZXX,U,5)_"^"_$P(ZXX,U,7)_"^"_$P(ZXX,U,8)
     51 Q
     52 ;

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPC.m

    r613 r623  
    1 PSOCPC  ;BHAM ISC/BAB - PHARMACY CO-PAY APPLICATION ;06/09/92
    2         ;;7.0;OUTPATIENT PHARMACY;**10,9,71,85,114,157,143,239,201,275,225**;DEC 1997;Build 29
    3         ;
    4         ;REF/IA
    5         ;piece 9 of zero node of File 350 and APDT cross reference of File 350/2215
    6         ;$$STATUS^IBARX/125
    7         ;File 350.1/592 (DBIA125-B)
    8 WARN    ; Message when attempt is made to delete a refill date on COPAY
    9         N PSOIB,PSOIBST
    10         S PSOFLG=0
    11         G:'$D(^PSRX(DA(1),1,DA,"IB")) ENDW
    12         S PSOIB=^PSRX(DA(1),1,DA,"IB")
    13         I +PSOIB'>0 G ENDW
    14         S PSOIBST=$$STATUS^IBARX(+PSOIB) I PSOIBST=2!(PSOIBST=0) G ENDW
    15         I +PSOIB>0 D CANCEL G ENDW:PSOFLG=0
    16         I '$G(PSOXXDEL) D EN^DDIOL("This REFILL has COPAY charges, which MUST be removed","","$C(7),!!"),EN^DDIOL("BEFORE the refill date is deleted.","","!")
    17         I '$G(PSOXXDEL) D EN^DDIOL("Use option RESET COPAY STATUS/CANCEL CHARGES, return to EDIT A PRESCRIPTION,","","!!"),EN^DDIOL("and delete the refill date.","","!"),EN^DDIOL(" ","","!!")
    18         S PSOFLG=1
    19 ENDW    ;
    20         I PSOFLG
    21         K PSOFLG
    22         Q
    23 CANCEL  ;Check if charge is cancelled for this Refill date
    24         S PSOFLG=1 ;indicates a charge not cancelled
    25         S PSOX=+^PSRX(DA(1),1,DA,"IB")
    26         D LAST I PSOLAST'=PSOPARNT,$D(^IB(PSOLAST,0)),$P(^IBE(350.1,$P(^IB(PSOLAST,0),"^",3),0),"^",5)=2 S PSOFLG=0
    27         K PSOLAST,PSOPARNT,PSOX,PSOL,PSOLDT
    28         Q
    29 LAST    ;find last entry
    30         S PSOLAST=""
    31         S PSOPARNT=$P(^IB(+PSOX,0),"^",9) I 'PSOPARNT S PSOPARNT=+PSOX
    32         S PSOLDT=$O(^IB("APDT",PSOPARNT,"")) I +PSOLDT F PSOL=0:0 S PSOL=$O(^IB("APDT",PSOPARNT,PSOLDT,PSOL)) Q:'PSOL  S PSOLAST=PSOL
    33         I PSOLAST="" S PSOLAST=PSOPARNT
    34         Q
    35         ;
    36 EXEMCHK ; Allow reset of exemption answers
    37         N PSOTG,PSOCPN,PSOEXMT,PSOANS,OLDIBQ,PSOSCP,PSOSCA
    38         S PSOANS=0 D SCP^PSORN52D
    39         S OLDIBQ=$G(^PSRX(PSODA,"IBQ"))
    40         I OLDIBQ[0!(OLDIBQ)[1 D
    41         . S PSOANS=1
    42         . I $P(OLDIBQ,"^",1)'="" S PSOTG("SC")=$P(OLDIBQ,"^",1)
    43         . I $P(OLDIBQ,"^",2)'="" S PSOTG("MST")=$P(OLDIBQ,"^",2)
    44         . I $P(OLDIBQ,"^",3)'="" S PSOTG("AO")=$P(OLDIBQ,"^",3)
    45         . I $P(OLDIBQ,"^",4)'="" S PSOTG("IR")=$P(OLDIBQ,"^",4)
    46         . I $P(OLDIBQ,"^",5)'="" S PSOTG("EC")=$P(OLDIBQ,"^",5)
    47         . I $P(OLDIBQ,"^",6)'="" S PSOTG("HNC")=$P(OLDIBQ,"^",6)
    48         . I $P(OLDIBQ,"^",7)'="" S PSOTG("CV")=$P(OLDIBQ,"^",7)
    49         . I $P(OLDIBQ,"^",8)'="" S PSOTG("SHAD")=$P(OLDIBQ,"^",8)
    50         S PSOCPN=$P(^PSRX(PSODA,0),"^",2)
    51         S RXP=PSODA
    52         D SCNEW^PSOCP(.PSOTG,PSOCPN,"",PSODA)
    53         N EXMT
    54         D XTYPE^PSOCP ; KEEP THIS CALL IN HERE TO SEE IF SC QUESTION APPLIES
    55         ;I $D(PSOTG("SC")) S PSOTG("SC")=$P(OLDIBQ,"^",1) ; CHANGED TO JUST USE IBQ SETTING IF SC QUESTION APPLIES - DON'T RE-CALCULATE SERVICE-CONNECTED
    56         S EXMT="" F  S EXMT=$O(PSOTG(EXMT)) Q:EXMT=""  I PSOTG(EXMT)'="" S PSOANS=1 Q
    57         I $O(PSOTG(""))="" Q
    58         I PSOANS W !!,"The following exemption flags have been set:"
    59         F EXMT="SC","CV","AO","IR","EC","SHAD","MST","HNC" I $G(PSOTG(EXMT))'="" W !,$S(EXMT="EC":"SWAC",1:EXMT),": ",?6,$S(PSOTG(EXMT)=1:"Yes",PSOTG(EXMT)=0:"No",1:"")
    60         W !
    61         W ! K DIR S DIR(0)="Y",DIR("B")="N" D  S DIR("A")="Do you want to enter/edit any copay exemption flags"
    62         . S EXMT="" F  S EXMT=$O(PSOTG(EXMT)) Q:EXMT=""  I PSOTG(EXMT)="" S DIR("B")="Y" Q
    63         S DIR("?")="Enter 'Y' for Yes if you want to edit any applicable medication exemption flags."
    64         S DIR("??")="^D HELPEXEM^PSOCPC"
    65         D ^DIR K DIR S PSOEXMT=Y I Y'=1 Q
    66         ; PRESENT ALL APPLICABLE EXEMPTIONS AND SAVE NEW ANSWERS
    67         N PSOIBQ,PSOSUBS,PSOQUES,PSOLTAG,OLDIBQ,II,PSOCHG,PSOPATST
    68         S PSOPATST=$$GET1^DIQ(52,PSODA_",",3,"I")
    69         S PSOIBQ=""
    70         S OLDIBQ=$G(^PSRX(PSODA,"IBQ"))
    71         I '$D(^PSRX(PSODA,"IBQ")),+($G(^PSRX(PSODA,"IB")))=2 S $P(OLDIBQ,"^",1)=0 ; SC QUESTION WAS PREVIOUSLY ANSWERED AS N
    72         S PSOCOMM="",PSOOLD="",PSONW=""
    73         S II=0
    74         F EXMT="SC","CV","AO","IR","EC","SHAD","MST","HNC" I $D(PSOTG(EXMT)) D
    75         . S PSOLTAG="REL"_EXMT_"^PSOCPE"
    76         . S HELPTAG="HELP"_EXMT
    77         . S PSOQUES=$P($T(@PSOLTAG),";",2) I PSOQUES="" Q
    78         . S PSOQUES=$P(PSOQUES,"?")
    79         . S PSOSUBS=$P($T(@PSOLTAG),";",3) I PSOSUBS="" Q
    80         . D ASKEXEM
    81         I $D(PSOCHG) D
    82         . ;PSO*7*275 IBQ node should not be present in some cases.
    83         . K ^PSRX(PSODA,"IBQ")
    84         . S:PSOSCP<50&($TR(PSOIBQ,"^")'="")&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)'=1) ^PSRX(PSODA,"IBQ")=PSOIBQ
    85         . D RESET^PSORN52D  ;set SC/EI on ICD node
    86         . S PSOPFSA=1 ;PFSS-denotes to calling routine that outpatient classifications changed.
    87         . D EN^PSOHLSN1(PSODA,"XX","","Order edited")
    88         . I PCOPAY,PSOIBQ["1" D  ; RESET TO NO COPAY
    89         . . W !,"Editing of exemption flag(s) has resulted in a copay status change.",!,"The status for this Rx will be reset to NO COPAY."
    90         . . S $P(^PSRX(PSODA,"IB"),"^",1)=""
    91         . . S PSOREF="",PSOOLD="Copay",PSONW="No Copay",PREA="R" D ACTLOG^PSOCPA
    92         . . S PSOCOMM="Copay status reset due to exemption flag(s)"
    93         . . S PSI=0 D SETSUMM
    94         . I $G(II)>0 D
    95         . . S PSOCOMM="The following exemption flags have been changed: ",PSI=0 D SETSUMM
    96         . . S II="" F  S II=$O(PSOCHG(II)) Q:II=""  S PSOCOMM=PSOCHG(II),PSI=0 D SETSUMM
    97         Q
    98         ;
    99 ASKEXEM ; ASK THE EXEMPTION QUESTIONS
    100         K DIR S DIR("A")=PSOQUES,DIR(0)="YO" S:PSOTG(EXMT)=1 DIR("B")="Y" S:PSOTG(EXMT)=0 DIR("B")="N" D @HELPTAG
    101 ASKEXEM1        D ^DIR I X="@" R !,"  Are you sure you want to delete this answer? ",X:DTIME I $E(X)'="Y",$E(X)'="y" G ASKEXEM1
    102         I X="^" S X=$G(DIR("B")) S Y=$S(X="Y":1,X="N":0,1:"")
    103         S $P(PSOIBQ,"^",PSOSUBS)=$S(Y=1:1,Y=0:0,1:"")
    104         I $P(PSOIBQ,"^",PSOSUBS)'=$P(OLDIBQ,"^",PSOSUBS) S II=II+1,PSOCHG(II)=$S(EXMT="EC":"SWAC",1:EXMT)_": "_$S($P(PSOIBQ,"^",PSOSUBS)=1:"Yes",$P(PSOIBQ,"^",PSOSUBS)=0:"No",1:"")
    105         I Y=1 D
    106         . I PSOCOMM'="" Q
    107         . D SETCOMM^PSOCP
    108         Q
    109         ;
    110 HELPEXEM        ; help text for exemption edit question
    111         W !,"Enter 'Y' for Yes if you want to edit any applicable exemption flags such as"
    112         W !,"Service Connected (SC), Combat Veteran(CV), Agent Orange (AO), Ionizing"
    113         W !,"Radiation (IR), Southwest Asia Conditions (SWAC), PROJ 112/SHAD,"
    114         W !,"Military Sexual Trauma (MST), or Head and/or Neck Cancer (HNC)."
    115         Q
    116         ;
    117 HELPSC  ;
    118         S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is for a Service Connected condition."
    119         S DIR("?",2)="This response will be used to determine whether or not a copay should be"
    120         S DIR("?",3)="applied to the prescription."
    121         Q
    122         ;
    123 HELPAO  ;
    124         S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to",DIR("?",2)="Vietnam-Era Herbicide (Agent Orange) exposure. This response will be used to"
    125         S DIR("?",3)="determine whether or not a copay should be applied to the prescription."
    126         Q
    127         ;
    128 HELPIR  ;
    129         S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to",DIR("?",2)="ionizing radiation exposure during military service. This response will be used"
    130         S DIR("?",3)="to determine whether or not a copay should be applied to the prescription."
    131         Q
    132         ;
    133 HELPEC  ;
    134         S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related to",DIR("?",2)="service in Southwest Asia. This response will be used to determine whether"
    135         S DIR("?",3)="or not a copay should be applied to the prescription."
    136         Q
    137         ;
    138 HELPMST ;
    139         S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related",DIR("?",2)="to Military Sexual Trauma. This response will be used to determine whether or"
    140         S DIR("?",3)="not a copay should be applied to the prescription."
    141         Q
    142         ;
    143 HELPHNC ;
    144         S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat Head and/or Neck Cancer",DIR("?",2)="due to nose or throat radium treatments while in the military. This response"
    145         S DIR("?",3)="will be used to determine whether or not a copay should be applied to the",DIR("?",4)="prescription."
    146         Q
    147         ;
    148 HELPCV  ;
    149         S DIR("?")=" "
    150         S DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related"
    151         S DIR("?",2)="to Combat Services. This response will be used to determine whether or"
    152         S DIR("?",3)="not a copay should be applied to the prescription."
    153         Q
    154         ;
    155 HELPSHAD        ;
    156         S DIR("?")=" "
    157         S DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related"
    158         S DIR("?",2)="to PROJ 112/SHAD. This response will be used to determine whether or"
    159         S DIR("?",3)="not a copay should be applied to the prescription."
    160         Q
    161 SETSUMM ; SET MESSAGE INTO SUMMARY
    162         S PSI=$O(PSOSUMM(PSI)) G:$O(PSOSUMM(PSI)) SETSUMM
    163         S PSI=PSI+1,PSOSUMM(PSI)=PSOCOMM
    164         K PSOCOMM
    165         Q
    166         ;
     1PSOCPC ;BHAM ISC/BAB - PHARMACY CO-PAY APPLICATION ;06/09/92
     2 ;;7.0;OUTPATIENT PHARMACY;**10,9,71,85,114,157,143,239,201**;DEC 1997
     3 ;
     4 ;REF/IA
     5 ;piece 9 of zero node of File 350 and APDT cross reference of File 350/2215
     6 ;$$STATUS^IBARX/125
     7 ;File 350.1/592 (DBIA125-B)
     8WARN ; Message when attempt is made to delete a refill date on COPAY
     9 N PSOIB,PSOIBST
     10 S PSOFLG=0
     11 G:'$D(^PSRX(DA(1),1,DA,"IB")) ENDW
     12 S PSOIB=^PSRX(DA(1),1,DA,"IB")
     13 I +PSOIB'>0 G ENDW
     14 S PSOIBST=$$STATUS^IBARX(+PSOIB) I PSOIBST=2!(PSOIBST=0) G ENDW
     15 I +PSOIB>0 D CANCEL G ENDW:PSOFLG=0
     16 I '$G(PSOXXDEL) D EN^DDIOL("This REFILL has COPAY charges, which MUST be removed","","$C(7),!!"),EN^DDIOL("BEFORE the refill date is deleted.","","!")
     17 I '$G(PSOXXDEL) D EN^DDIOL("Use option RESET COPAY STATUS/CANCEL CHARGES, return to EDIT A PRESCRIPTION,","","!!"),EN^DDIOL("and delete the refill date.","","!"),EN^DDIOL(" ","","!!")
     18 S PSOFLG=1
     19ENDW ;
     20 I PSOFLG
     21 K PSOFLG
     22 Q
     23CANCEL ;Check if charge is cancelled for this Refill date
     24 S PSOFLG=1 ;indicates a charge not cancelled
     25 S PSOX=+^PSRX(DA(1),1,DA,"IB")
     26 D LAST I PSOLAST'=PSOPARNT,$D(^IB(PSOLAST,0)),$P(^IBE(350.1,$P(^IB(PSOLAST,0),"^",3),0),"^",5)=2 S PSOFLG=0
     27 K PSOLAST,PSOPARNT,PSOX,PSOL,PSOLDT
     28 Q
     29LAST ;find last entry
     30 S PSOLAST=""
     31 S PSOPARNT=$P(^IB(+PSOX,0),"^",9) I 'PSOPARNT S PSOPARNT=+PSOX
     32 S PSOLDT=$O(^IB("APDT",PSOPARNT,"")) I +PSOLDT F PSOL=0:0 S PSOL=$O(^IB("APDT",PSOPARNT,PSOLDT,PSOL)) Q:'PSOL  S PSOLAST=PSOL
     33 I PSOLAST="" S PSOLAST=PSOPARNT
     34 Q
     35 ;
     36EXEMCHK ; Allow reset of exemption answers
     37 N PSOTG,PSOCPN,PSOEXMT,PSOANS,OLDIBQ,PSOSCP,PSOSCA
     38 S PSOANS=0 D SCP^PSORN52D
     39 S OLDIBQ=$G(^PSRX(PSODA,"IBQ"))
     40 I OLDIBQ[0!(OLDIBQ)[1 D
     41 . S PSOANS=1
     42 . I $P(OLDIBQ,"^",1)'="" S PSOTG("SC")=$P(OLDIBQ,"^",1)
     43 . I $P(OLDIBQ,"^",2)'="" S PSOTG("MST")=$P(OLDIBQ,"^",2)
     44 . I $P(OLDIBQ,"^",3)'="" S PSOTG("AO")=$P(OLDIBQ,"^",3)
     45 . I $P(OLDIBQ,"^",4)'="" S PSOTG("IR")=$P(OLDIBQ,"^",4)
     46 . I $P(OLDIBQ,"^",5)'="" S PSOTG("EC")=$P(OLDIBQ,"^",5)
     47 . I $P(OLDIBQ,"^",6)'="" S PSOTG("HNC")=$P(OLDIBQ,"^",6)
     48 . I $P(OLDIBQ,"^",7)'="" S PSOTG("CV")=$P(OLDIBQ,"^",7)
     49 S PSOCPN=$P(^PSRX(PSODA,0),"^",2)
     50 S RXP=PSODA
     51 D SCNEW^PSOCP(.PSOTG,PSOCPN,"",PSODA)
     52 N EXMT
     53 D XTYPE^PSOCP ; KEEP THIS CALL IN HERE TO SEE IF SC QUESTION APPLIES
     54 ;I $D(PSOTG("SC")) S PSOTG("SC")=$P(OLDIBQ,"^",1) ; CHANGED TO JUST USE IBQ SETTING IF SC QUESTION APPLIES - DON'T RE-CALCULATE SERVICE-CONNECTED
     55 S EXMT="" F  S EXMT=$O(PSOTG(EXMT)) Q:EXMT=""  I PSOTG(EXMT)'="" S PSOANS=1 Q
     56 I $O(PSOTG(""))="" Q
     57 I PSOANS W !!,"The following exemption flags have been set:"
     58 F EXMT="SC","CV","AO","IR","EC","MST","HNC" I $G(PSOTG(EXMT))'="" W !,EXMT,": ",?6,$S(PSOTG(EXMT)=1:"Yes",PSOTG(EXMT)=0:"No",1:"")
     59 W !
     60 W ! K DIR S DIR(0)="Y",DIR("B")="N" D  S DIR("A")="Do you want to enter/edit any copay exemption flags"
     61 . S EXMT="" F  S EXMT=$O(PSOTG(EXMT)) Q:EXMT=""  I PSOTG(EXMT)="" S DIR("B")="Y" Q
     62 S DIR("?")="Enter 'Y' for Yes if you want to edit any applicable medication exemption flags."
     63 S DIR("??")="^D HELPEXEM^PSOCPC"
     64 D ^DIR K DIR S PSOEXMT=Y I Y'=1 Q
     65 ; PRESENT ALL APPLICABLE EXEMPTIONS AND SAVE NEW ANSWERS
     66 N PSOIBQ,PSOSUBS,PSOQUES,PSOLTAG,OLDIBQ,II,PSOCHG,PSOPATST
     67 S PSOPATST=$$GET1^DIQ(52,PSODA_",",3,"I")
     68 S PSOIBQ=""
     69 S OLDIBQ=$G(^PSRX(PSODA,"IBQ"))
     70 I '$D(^PSRX(PSODA,"IBQ")),+($G(^PSRX(PSODA,"IB")))=2 S $P(OLDIBQ,"^",1)=0 ; SC QUESTION WAS PREVIOUSLY ANSWERED AS N
     71 S PSOCOMM="",PSOOLD="",PSONW=""
     72 S II=0
     73 F EXMT="SC","CV","AO","IR","EC","MST","HNC" I $D(PSOTG(EXMT)) D
     74 . S PSOLTAG="REL"_EXMT_"^PSOCPE"
     75 . S HELPTAG="HELP"_EXMT
     76 . S PSOQUES=$P($T(@PSOLTAG),";",2) I PSOQUES="" Q
     77 . S PSOQUES=$P(PSOQUES,"?")
     78 . S PSOSUBS=$P($T(@PSOLTAG),";",3) I PSOSUBS="" Q
     79 . D ASKEXEM
     80 I $D(PSOCHG) D
     81 . S:PSOSCP<50&($TR(PSOIBQ,"^")'="")&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)'=1) ^PSRX(PSODA,"IBQ")=PSOIBQ
     82 . D RESET^PSORN52D  ;set SC/EI on ICD node
     83 . S PSOPFSA=1 ;PFSS-denotes to calling routine that outpatient classifications changed.
     84 . D EN^PSOHLSN1(PSODA,"XX","","Order edited")
     85 . I PCOPAY,PSOIBQ["1" D  ; RESET TO NO COPAY
     86 . . W !,"Editing of exemption flag(s) has resulted in a copay status change.",!,"The status for this Rx will be reset to NO COPAY."
     87 . . S $P(^PSRX(PSODA,"IB"),"^",1)=""
     88 . . S PSOREF="",PSOOLD="Copay",PSONW="No Copay",PREA="R" D ACTLOG^PSOCPA
     89 . . S PSOCOMM="Copay status reset due to exemption flag(s)"
     90 . . S PSI=0 D SETSUMM
     91 . I $G(II)>0 D
     92 . . S PSOCOMM="The following exemption flags have been changed: ",PSI=0 D SETSUMM
     93 . . S II="" F  S II=$O(PSOCHG(II)) Q:II=""  S PSOCOMM=PSOCHG(II),PSI=0 D SETSUMM
     94 Q
     95 ;
     96ASKEXEM ; ASK THE EXEMPTION QUESTIONS
     97 K DIR S DIR("A")=PSOQUES,DIR(0)="YO" S:PSOTG(EXMT)=1 DIR("B")="Y" S:PSOTG(EXMT)=0 DIR("B")="N" D @HELPTAG
     98ASKEXEM1 D ^DIR I X="@" R !,"  Are you sure you want to delete this answer? ",X:DTIME I $E(X)'="Y",$E(X)'="y" G ASKEXEM1
     99 I X="^" S X=$G(DIR("B")) S Y=$S(X="Y":1,X="N":0,1:"")
     100 S $P(PSOIBQ,"^",PSOSUBS)=$S(Y=1:1,Y=0:0,1:"")
     101 I $P(PSOIBQ,"^",PSOSUBS)'=$P(OLDIBQ,"^",PSOSUBS) S II=II+1,PSOCHG(II)=EXMT_": "_$S($P(PSOIBQ,"^",PSOSUBS)=1:"Yes",$P(PSOIBQ,"^",PSOSUBS)=0:"No",1:"")
     102 I Y=1 D
     103 . I PSOCOMM'="" Q
     104 . D SETCOMM^PSOCP
     105 Q
     106 ;
     107HELPEXEM ; help text for exemption edit question
     108 W !,"Enter 'Y' for Yes if you want to edit any applicable exemption flags such as"
     109 W !,"Service Connected (SC), Combat Veteran(CV), Agent Orange (AO), Ionizing Radiation (IR),"
     110 W !,"Environmental Contaminants (EC), Military Sexual Trauma (MST), or"
     111 W !,"Head and/or Neck Cancer (HNC)."
     112 Q
     113 ;
     114HELPSC ;
     115 S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is for a Service Connected condition."
     116 S DIR("?",2)="This response will be used to determine whether or not a copay should be"
     117 S DIR("?",3)="applied to the prescription."
     118 Q
     119 ;
     120HELPAO ;
     121 S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to",DIR("?",2)="Vietnam-Era Herbicide (Agent Orange) exposure. This response will be used to"
     122 S DIR("?",3)="determine whether or not a copay should be applied to the prescription."
     123 Q
     124 ;
     125HELPIR ;
     126 S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to",DIR("?",2)="ionizing radiation exposure during military service. This response will be used"
     127 S DIR("?",3)="to determine whether or not a copay should be applied to the prescription."
     128 Q
     129 ;
     130HELPEC ;
     131 S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to",DIR("?",2)="environmental contaminant exposure during the Persian Gulf War. This response"
     132 S DIR("?",3)="will be used to determine whether or not a copay should be applied to the",DIR("?",4)="prescription."
     133 Q
     134 ;
     135HELPMST ;
     136 S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related",DIR("?",2)="to Military Sexual Trauma. This response will be used to determine whether or"
     137 S DIR("?",3)="not a copay should be applied to the prescription."
     138 Q
     139 ;
     140HELPHNC ;
     141 S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat Head and/or Neck Cancer",DIR("?",2)="due to nose or throat radium treatments while in the military. This response"
     142 S DIR("?",3)="will be used to determine whether or not a copay should be applied to the",DIR("?",4)="prescription."
     143 Q
     144 ;
     145HELPCV ;
     146 S DIR("?")=" "
     147 S DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related"
     148 S DIR("?",2)="to Combat Services. This response will be used to determine whether or"
     149 S DIR("?",3)="not a copay should be applied to the prescription."
     150 Q
     151 ;
     152SETSUMM ; SET MESSAGE INTO SUMMARY
     153 S PSI=$O(PSOSUMM(PSI)) G:$O(PSOSUMM(PSI)) SETSUMM
     154 S PSI=PSI+1,PSOSUMM(PSI)=PSOCOMM
     155 K PSOCOMM
     156 Q
     157 ;

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPE.m

    r613 r623  
    1 PSOCPE  ;BIR/BAB - PHARMACY COPAY APPLICATION UTILITIES FOR IB ;10/26/92
    2         ;;7.0;OUTPATPSOCT PHARMACY;**26,71,85,114,157,219,268,225**;DEC 1997;Build 29
    3         ;
    4         ;REF/IA
    5         ;^XUSEC/10076
    6         ;^PSDRUG(/221
    7         ;Routine initially released as part of the copayment enhancement.
    8         ;called from PSOLBL
    9 INV     ;         Entry point from PSOCP - Prints one copay invoice
    10         I '$D(PSOCPN)!($G(RXP)) Q
    11         S PSOCPBAR=0
    12         I $D(PSOBARS),PSOBARS S PSOCPBAR=1
    13         D DEM^VADPT S Y=DT X ^DD("DD") S EDT=Y
    14         W ?54,"PRESCRIPTION COPAYMENT INFORMATION"
    15         W !!,?54,VADM(1)," ",VA("PID")," ",EDT
    16         S PSZ1=0,PSZ2="",PSOCPBN=$P(VADM(2),"^"),PSOCPBN=$S(PSOCPBN]"":PSOCPBN,1:"Unavailable")
    17         ;I '$G(PSOCPN) S PSOCPN=$P(^PSRX(RX,0),U,2)
    18         I PSOCPBAR,(PSOCPBN]"") S X="S",X2=PSOCPBN W !,?54,@PSOBAR1,PSOCPBN,@PSOBAR0
    19         E  W !
    20         W !,?54,"The following prescriptions are"
    21         W !,?54,"eligible for prescription copayment.",!!
    22 DRUG    S PSZ2="" F  S PSZ2=$O(^TMP($J,"PSOCP",PSOCPN,PSZ2)) Q:PSZ2']""  S PSZ=^(PSZ2) D PRT
    23 NAR     ; Print narrative from site parameter file
    24         K ^UTILITY($J,"W") S DIWL=55,DIWR=99,DIWF="" W !
    25         G:'$D(^PS(59,PSOSITE,4,0)) END
    26         G:$P(^PS(59,PSOSITE,4,0),"^",3)'>0 END
    27         F PSO9=0:0 S PSO9=$O(^PS(59,PSOSITE,4,PSO9)) G:'PSO9 P1 I $D(^PS(59,PSOSITE,4,PSO9,0)) S X=^(0) D ^DIWP
    28 P1      D ^DIWW
    29         K DIWF,DIWL,DIWR,PSO9
    30 END     ;
    31         W @IOF
    32         K ^TMP($J,"PSOCP",PSOCPN),PSOCPBAR,PSOCPBN,PSZ1,PSZ2,PSOCPN,DIWF,DIWL,DIWR,PSO9
    33         Q
    34 PRT     ;
    35         W ?54,PSZ2
    36         W ?72," ",$P(^TMP($J,"PSOCP",PSOCPN,PSZ2),"^",3)," ","Days Supply",!
    37         W ?56,$E($P(^TMP($J,"PSOCP",PSOCPN,PSZ2),U,2),1,45),!
    38         Q
    39 XMPT    ;   Entry point for menu option to select copay exemption
    40         N PSORXPNM,PSORXPRE,PSOCPEDA
    41         I '$D(PSOPAR) D ^PSOLSET G XMPT
    42         W ! S (DIC,DIE)="^PS(53,",DIC(0)="AEQMZ" D ^DIC K DIC G:Y<0 QUIT
    43         G:$D(DTOUT) QUIT
    44         S PSORXPRE=$P($G(^PS(53,+$G(Y),0)),"^",7)
    45         S PSORXPNM=$P($G(^PS(53,+$G(Y),0)),"^")
    46         S DA=+Y,DR="15" L +^PS(53,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !!,PSORXPNM_" is locked by another user. Try Later!" W ! D PAGE G QUIT
    47         W ! D ^DIE
    48         I PSORXPRE,$P($G(^PS(53,DA,0)),"^",7) W !!,"All Rx's entered with this Rx Patient Status will be EXEMPT from Copayment.",! D PAGE L -^PS(53,DA) G QUIT
    49         I 'PSORXPRE,'$P($G(^PS(53,DA,0)),"^",7) W !!,"All Rx's entered with this Rx Patient Status will NOT be exempt from Copayment.",! D PAGE L -^PS(53,DA) G QUIT
    50         D WARN L -^PS(53,DA)
    51 QUIT    K PSORXPRE,DIE,DIC,DA,DR,X,C,Y
    52         Q
    53 PAGE    ;
    54         I '$G(DUZ("AUTO")) K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
    55         Q
    56 WARN    ;
    57         S PSOCPEDA=$G(DA)
    58         W !!?28,"**** WARNING ****",!
    59         I 'PSORXPRE W !,"By setting the Exempt from Copayment for the Rx Patient Status of",!,PSORXPNM," to 'YES', every prescription entered",!,"with this Rx Patient Status will NOT be charged a Copayment.",!
    60         I PSORXPRE W !,"By setting the EXEMPT FROM COPAYMENT for the Rx Patient Status of ",!,PSORXPNM," to 'NO', prescriptions entered with this Rx",!,"Patient Status from this point on will NOT be exempt from Copayment.",!
    61         W !,"A mail message will be sent to PSORPH and PSO COPAY Key holders informing",!,"them of your change."
    62         W ! K DIR S DIR(0)="Y",DIR("A")="Are you sure you want to do this",DIR("B")="Y" D ^DIR K DIR
    63         I $G(Y) D  D MAIL G WARNX
    64         .I 'PSORXPRE W !!,"Setting ",PSORXPNM," Rx Patient Status to Exempt from Copayment." Q
    65         .W !!,"Setting Exempt from Copayment to 'NO' for the ",PSORXPNM,!,"Rx Patient Status."
    66         I 'PSORXPRE W !!,"No action taken." S $P(^PS(53,PSOCPEDA,0),"^",7)=0 H 1
    67         I PSORXPRE W !!,"No action taken." S $P(^PS(53,PSOCPEDA,0),"^",7)=1 H 1
    68 WARNX   W ! D PAGE
    69         S DA=$G(PSOCPEDA) K PSOCPEDA
    70         Q
    71 MAIL    ;
    72         K PSOTXT,PSOCFN,PSODCPA
    73         I $G(DUZ) S DIC=200,DR=".01",DA=DUZ,DIQ(0)="E",DIQ="PSODCPA(" D EN^DIQ1 S PSOCFN=$G(PSODCPA(200,DA,.01,"E")) K PSODCPA,DIC,DIQ,DR
    74         I 'PSORXPRE S PSOTXT(1,0)="The "_PSORXPNM_" Rx Patient Status has been marked as",PSOTXT(2,0)="Exempt from Copayment by "_$G(PSOCFN)_".",PSOTXT(3,0)="Every prescription with this Rx Patient Status will not be charged a Copayment."
    75         I PSORXPRE S PSOTXT(1,0)="The Exempt from Copayment status has been removed from the",PSOTXT(2,0)=PSORXPNM_" Rx Patient Status by "_$G(PSOCFN)_".",PSOTXT(3,0)="Prescriptions entered with this Rx Patient Status will not be exempt from"
    76         I PSORXPRE S PSOTXT(4,0)="Copayment."
    77         F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSORPH",PSOCXPDA)) Q:'PSOCXPDA  S XMY(PSOCXPDA)=""
    78         F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSO COPAY",PSOCXPDA)) Q:'PSOCXPDA  S XMY(PSOCXPDA)=""
    79         I $G(DUZ) S XMY(DUZ)=""
    80         S XMSUB="Exempt from Copayment",XMTEXT="PSOTXT(",XMDUZ="Outpatient Pharmacy" D ^XMD
    81         K PSOTXT,PSOCXPDA,XMDUZ,PSOCFN,XMTEXT,XMSUB,XMY
    82         Q
    83         ;
    84 MAIL2   ; SEND MAIL TO PHARMACIST, PROVIDER, AND HOLDERS OF PSO COPAY KEY
    85         N PSOC,PSOTXT,X
    86         K XMY
    87         S XMSUB="PRESCRIPTION QUESTIONS REVIEW NEEDED"
    88         S XMDUZ="Outpatient Pharmacy Package"
    89         S PSOTXT(1)=" "
    90         S DFN=+$P($G(^PSRX(RXP,0)),"^",2) D PID^VADPT
    91         S PSODIV=$P($G(^PSRX(RXP,2)),"^",9) S:PSODIV'="" XMSUB=XMSUB_" ("_$P($G(^PS(59,PSODIV,0)),"^",6)_")",PSODIV=$P($G(^PS(59,PSODIV,0)),"^",1) ; ADDED DIVISION NUMBER TO SUBJECT LINE - PATCH 85
    92         S PSOTXT(2)=$P($G(^DPT($P(^PSRX(RXP,0),"^",2),0)),"^",1)_"  ("_$G(VA("BID"))_")"_"    "_PSODIV
    93         D ELIG
    94         S PSOTXT(PSOC)="Rx# "_$P(^PSRX(RXP,0),"^",1)_" ("_PSOREF_")    "_$S('$G(^PSRX(RXP,"IB")):"NO COPAY",1:"COPAY")
    95         S PSOC=PSOC+1
    96         S DRG=+$P(^PSRX(RXP,0),"^",6)
    97         S PSOC=PSOC+1
    98         S PSOTXT(PSOC)=$P($G(^PSDRUG(DRG,0)),"^",1)
    99         S PSOC=PSOC+1
    100         S PSOTXT(PSOC)=" "
    101         S PSOC=PSOC+1
    102         S PSOTXT(PSOC)="Due to a change in criteria, additional information listed below is needed"
    103         S PSOC=PSOC+1
    104         S PSOTXT(PSOC)="to determine the final VA copay and/or insurance billable status for this Rx"
    105         S PSOC=PSOC+1
    106         S PSOTXT(PSOC)="so that appropriate action can be taken by pharmacy personnel."
    107         S PSOC=PSOC+1
    108         S PSOTXT(PSOC)=" "
    109         S PSOC=PSOC+1
    110         F EXMT="SC","CV","AO","IR","EC","SHAD","MST","HNC" I $D(PSOTG(EXMT)) D
    111         . I PSOTG(EXMT)'="" Q
    112         . S PSOLTAG="REL"_EXMT
    113         . S PSOQUES=$P($T(@PSOLTAG),";",2) I PSOQUES="" Q
    114         . S PSOC=PSOC+1,PSOTXT(PSOC)=PSOQUES
    115         . S PSOQUES=$P($T(@PSOLTAG),";",2) I PSOQUES="" Q
    116         S PSOC=PSOC+1,PSOTXT(PSOC)=" "
    117         S PSOC=PSOC+1,PSOTXT(PSOC)="This message has been sent to the provider of record, the pharmacist who"
    118         S PSOC=PSOC+1,PSOTXT(PSOC)="finished the prescription order, and all holders of the PSO COPAY key."
    119         S PSOC=PSOC+1,PSOTXT(PSOC)=" "
    120         S PSOC=PSOC+1,PSOTXT(PSOC)="Providers:"
    121         S PSOC=PSOC+1,PSOTXT(PSOC)="Please respond with your answer to the question(s) as a reply to this"
    122         S PSOC=PSOC+1,PSOTXT(PSOC)="message. The prescription will be updated by the appropriate staff."
    123         S PSOC=PSOC+1,PSOTXT(PSOC)=" "
    124         S PSOC=PSOC+1,PSOTXT(PSOC)="Staff assigned to update the Prescription responses:"
    125         S PSOC=PSOC+1,PSOTXT(PSOC)="Please use the RESET COPAY STATUS/CANCEL CHARGES option to enter the responses"
    126         S PSOC=PSOC+1,PSOTXT(PSOC)="to the questions above, which may result in a Rx copay status change and/or"
    127         S PSOC=PSOC+1,PSOTXT(PSOC)="the need to remove VA copay charges or may result in a charge to the patient's"
    128         S PSOC=PSOC+1,PSOTXT(PSOC)="insurance carrier."
    129         S PSOC=PSOC+1,PSOTXT(PSOC)=" "
    130         S PSOC=PSOC+1,PSOTXT(PSOC)="Note: The SC question is now asked for Veterans who are SC>49% in order to"
    131         S PSOC=PSOC+1,PSOTXT(PSOC)="determine if the Rx can be billed to a third party insurance. These Veterans"
    132         S PSOC=PSOC+1,PSOTXT(PSOC)="will NOT be charged a VA copay."
    133         S PSOC=PSOC+1,PSOTXT(PSOC)=" "
    134         S PSOC=PSOC+1,PSOTXT(PSOC)="Supply and investigational drugs are not charged a VA copay but could be"
    135         S PSOC=PSOC+1,PSOTXT(PSOC)="reimbursable by third party insurance."
    136         ; S XMY() TO ALL THE RECIPIENTS
    137         I '$G(PSOREF) S XMY(+$P(^PSRX(RXP,0),"^",4))="" ; ORIGINAL
    138         I $G(PSOREF) S XMY(+$P(^PSRX(RXP,1,PSOREF,0),"^",17))="" ; REFILL
    139         I $G(^PSRX(RXP,"OR1")) I $P(^PSRX(RXP,"OR1"),"^",5)'="" S XMY($P(^PSRX(RXP,"OR1"),"^",5))=""
    140         F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSO COPAY",PSOCXPDA)) Q:'PSOCXPDA  S XMY(PSOCXPDA)=""
    141         S XMTEXT="PSOTXT("
    142         D ^XMD K XMSUB,XMY,XMDUZ,XMTEXT,PSODIV,PSOCXPDA,PSOLTAG,PSOC,PSOQUES,PSOTG
    143         Q
    144         ;
    145 ELIG    D ELIG^VADPT S PSOC=3,PSOTXT(PSOC)="Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):"     SC%: "_$P(VAEL(3),"^",2),1:""),PSOC=PSOC+1
    146         N N,I,I1,PSDIS,PSCNT
    147         S N=0 F  S N=$O(VAEL(1,N)) Q:'N  S $P(PSOTXT(PSOC)," ",14)=$P(VAEL(1,N),"^",2),PSOC=PSOC+1
    148         S PSOTXT(PSOC)=" ",PSOC=PSOC+1,PSOTXT(PSOC)="Disabilities: "
    149         F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I  S I1=$S($D(^DPT(DFN,.372,I,0)):^(0),1:"") D:+I1
    150         .S PSDIS=$S($P($G(^DIC(31,+I1,0)),"^")]""&($P($G(^(0)),"^",4)']""):$P(^(0),"^"),$P($G(^DIC(31,+I1,0)),"^",4)]"":$P(^(0),"^",4),1:""),PSCNT=$P(I1,"^",2)
    151         .S:$L(PSOTXT(PSOC)_PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), ")>80 PSOC=PSOC+1,$P(PSOTXT(PSOC)," ",14)=" "
    152         .S PSOTXT(PSOC)=$G(PSOTXT(PSOC))_PSDIS_"-"_PSCNT_"%("_$S($P(I1,"^",3):"SC",1:"NSC")_"), "
    153         S PSOC=PSOC+1 S PSOTXT(PSOC)=" ",PSOC=PSOC+1
    154         Q
    155         ;
    156         ;EXEMPTION QUESTIONS - MAIL MESSAGE POSITION;SUBSCRIPT IN "IBQ" NODE
    157 RELSC   ;Is this Rx for a Service Connected Condition?;1
    158 RELMST  ;Is this Rx related to the treatment of Military Sexual Trauma?;2
    159 RELAO   ;Is this Rx for treatment of Vietnam-Era Herbicide (Agent Orange) exposure?;3
    160 RELIR   ;Is this Rx for treatment of Ionizing Radiation exposure?;4
    161 RELEC   ;Is this Rx for treatment related to service in SW Asia?;5
    162 RELHNC  ;Is this Rx related to treatment of Head and/or Neck Cancer?;6
    163 RELCV   ;Is this Rx potentially for treatment related to Combat?;7
    164 RELSHAD ;Is this Rx related to treatment of PROJ 112/SHAD?;8
    165         ;
     1PSOCPE ;BIR/BAB - PHARMACY COPAY APPLICATION UTILITIES FOR IB ;10/26/92
     2 ;;7.0;OUTPATPSOCT PHARMACY;**26,71,85,114,157,219,268**;DEC 1997;Build 9
     3 ;
     4 ;REF/IA
     5 ;^XUSEC/10076
     6 ;^PSDRUG(/221
     7 ;Routine initially released as part of the copayment enhancement.
     8 ;called from PSOLBL
     9INV ;         Entry point from PSOCP - Prints one copay invoice
     10 I '$D(PSOCPN)!($G(RXP)) Q
     11 S PSOCPBAR=0
     12 I $D(PSOBARS),PSOBARS S PSOCPBAR=1
     13 D DEM^VADPT S Y=DT X ^DD("DD") S EDT=Y
     14 W ?54,"PRESCRIPTION COPAYMENT INFORMATION"
     15 W !!,?54,VADM(1)," ",VA("PID")," ",EDT
     16 S PSZ1=0,PSZ2="",PSOCPBN=$P(VADM(2),"^"),PSOCPBN=$S(PSOCPBN]"":PSOCPBN,1:"Unavailable")
     17 ;I '$G(PSOCPN) S PSOCPN=$P(^PSRX(RX,0),U,2)
     18 I PSOCPBAR,(PSOCPBN]"") S X="S",X2=PSOCPBN W !,?54,@PSOBAR1,PSOCPBN,@PSOBAR0
     19 E  W !
     20 W !,?54,"The following prescriptions are"
     21 W !,?54,"eligible for prescription copayment.",!!
     22DRUG S PSZ2="" F  S PSZ2=$O(^TMP($J,"PSOCP",PSOCPN,PSZ2)) Q:PSZ2']""  S PSZ=^(PSZ2) D PRT
     23NAR ; Print narrative from site parameter file
     24 K ^UTILITY($J,"W") S DIWL=55,DIWR=99,DIWF="" W !
     25 G:'$D(^PS(59,PSOSITE,4,0)) END
     26 G:$P(^PS(59,PSOSITE,4,0),"^",3)'>0 END
     27 F PSO9=0:0 S PSO9=$O(^PS(59,PSOSITE,4,PSO9)) G:'PSO9 P1 I $D(^PS(59,PSOSITE,4,PSO9,0)) S X=^(0) D ^DIWP
     28P1 D ^DIWW
     29 K DIWF,DIWL,DIWR,PSO9
     30END ;
     31 W @IOF
     32 K ^TMP($J,"PSOCP",PSOCPN),PSOCPBAR,PSOCPBN,PSZ1,PSZ2,PSOCPN,DIWF,DIWL,DIWR,PSO9
     33 Q
     34PRT ;
     35 W ?54,PSZ2
     36 W ?72," ",$P(^TMP($J,"PSOCP",PSOCPN,PSZ2),"^",3)," ","Days Supply",!
     37 W ?56,$E($P(^TMP($J,"PSOCP",PSOCPN,PSZ2),U,2),1,45),!
     38 Q
     39XMPT ;   Entry point for menu option to select copay exemption
     40 N PSORXPNM,PSORXPRE,PSOCPEDA
     41 I '$D(PSOPAR) D ^PSOLSET G XMPT
     42 W ! S (DIC,DIE)="^PS(53,",DIC(0)="AEQMZ" D ^DIC K DIC G:Y<0 QUIT
     43 G:$D(DTOUT) QUIT
     44 S PSORXPRE=$P($G(^PS(53,+$G(Y),0)),"^",7)
     45 S PSORXPNM=$P($G(^PS(53,+$G(Y),0)),"^")
     46 S DA=+Y,DR="15" L +^PS(53,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !!,PSORXPNM_" is locked by another user. Try Later!" W ! D PAGE G QUIT
     47 W ! D ^DIE
     48 I PSORXPRE,$P($G(^PS(53,DA,0)),"^",7) W !!,"All Rx's entered with this Rx Patient Status will be EXEMPT from Copayment.",! D PAGE L -^PS(53,DA) G QUIT
     49 I 'PSORXPRE,'$P($G(^PS(53,DA,0)),"^",7) W !!,"All Rx's entered with this Rx Patient Status will NOT be exempt from Copayment.",! D PAGE L -^PS(53,DA) G QUIT
     50 D WARN L -^PS(53,DA)
     51QUIT K PSORXPRE,DIE,DIC,DA,DR,X,C,Y
     52 Q
     53PAGE ;
     54 I '$G(DUZ("AUTO")) K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
     55 Q
     56WARN ;
     57 S PSOCPEDA=$G(DA)
     58 W !!?28,"**** WARNING ****",!
     59 I 'PSORXPRE W !,"By setting the Exempt from Copayment for the Rx Patient Status of",!,PSORXPNM," to 'YES', every prescription entered",!,"with this Rx Patient Status will NOT be charged a Copayment.",!
     60 I PSORXPRE W !,"By setting the EXEMPT FROM COPAYMENT for the Rx Patient Status of ",!,PSORXPNM," to 'NO', prescriptions entered with this Rx",!,"Patient Status from this point on will NOT be exempt from Copayment.",!
     61 W !,"A mail message will be sent to PSORPH and PSO COPAY Key holders informing",!,"them of your change."
     62 W ! K DIR S DIR(0)="Y",DIR("A")="Are you sure you want to do this",DIR("B")="Y" D ^DIR K DIR
     63 I $G(Y) D  D MAIL G WARNX
     64 .I 'PSORXPRE W !!,"Setting ",PSORXPNM," Rx Patient Status to Exempt from Copayment." Q
     65 .W !!,"Setting Exempt from Copayment to 'NO' for the ",PSORXPNM,!,"Rx Patient Status."
     66 I 'PSORXPRE W !!,"No action taken." S $P(^PS(53,PSOCPEDA,0),"^",7)=0 H 1
     67 I PSORXPRE W !!,"No action taken." S $P(^PS(53,PSOCPEDA,0),"^",7)=1 H 1
     68WARNX W ! D PAGE
     69 S DA=$G(PSOCPEDA) K PSOCPEDA
     70 Q
     71MAIL ;
     72 K PSOTXT,PSOCFN,PSODCPA
     73 I $G(DUZ) S DIC=200,DR=".01",DA=DUZ,DIQ(0)="E",DIQ="PSODCPA(" D EN^DIQ1 S PSOCFN=$G(PSODCPA(200,DA,.01,"E")) K PSODCPA,DIC,DIQ,DR
     74 I 'PSORXPRE S PSOTXT(1,0)="The "_PSORXPNM_" Rx Patient Status has been marked as",PSOTXT(2,0)="Exempt from Copayment by "_$G(PSOCFN)_".",PSOTXT(3,0)="Every prescription with this Rx Patient Status will not be charged a Copayment."
     75 I PSORXPRE S PSOTXT(1,0)="The Exempt from Copayment status has been removed from the",PSOTXT(2,0)=PSORXPNM_" Rx Patient Status by "_$G(PSOCFN)_".",PSOTXT(3,0)="Prescriptions entered with this Rx Patient Status will not be exempt from"
     76 I PSORXPRE S PSOTXT(4,0)="Copayment."
     77 F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSORPH",PSOCXPDA)) Q:'PSOCXPDA  S XMY(PSOCXPDA)=""
     78 F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSO COPAY",PSOCXPDA)) Q:'PSOCXPDA  S XMY(PSOCXPDA)=""
     79 I $G(DUZ) S XMY(DUZ)=""
     80 S XMSUB="Exempt from Copayment",XMTEXT="PSOTXT(",XMDUZ="Outpatient Pharmacy" D ^XMD
     81 K PSOTXT,PSOCXPDA,XMDUZ,PSOCFN,XMTEXT,XMSUB,XMY
     82 Q
     83 ;
     84MAIL2 ; SEND MAIL TO PHARMACIST, PROVIDER, AND HOLDERS OF PSO COPAY KEY
     85 N PSOC,PSOTXT,X
     86 K XMY
     87 S XMSUB="PRESCRIPTION QUESTIONS REVIEW NEEDED"
     88 S XMDUZ="Outpatient Pharmacy Package"
     89 S PSOTXT(1)=" "
     90 S DFN=+$P($G(^PSRX(RXP,0)),"^",2) D PID^VADPT
     91 S PSODIV=$P($G(^PSRX(RXP,2)),"^",9) S:PSODIV'="" XMSUB=XMSUB_" ("_$P($G(^PS(59,PSODIV,0)),"^",6)_")",PSODIV=$P($G(^PS(59,PSODIV,0)),"^",1) ; ADDED DIVISION NUMBER TO SUBJECT LINE - PATCH 85
     92 S PSOTXT(2)=$P($G(^DPT($P(^PSRX(RXP,0),"^",2),0)),"^",1)_"  ("_$G(VA("BID"))_")"_"    "_PSODIV
     93 D ELIG
     94 S PSOTXT(PSOC)="Rx# "_$P(^PSRX(RXP,0),"^",1)_" ("_PSOREF_")    "_$S('$G(^PSRX(RXP,"IB")):"NO COPAY",1:"COPAY")
     95 S PSOC=PSOC+1
     96 S DRG=+$P(^PSRX(RXP,0),"^",6)
     97 S PSOC=PSOC+1
     98 S PSOTXT(PSOC)=$P($G(^PSDRUG(DRG,0)),"^",1)
     99 S PSOC=PSOC+1
     100 S PSOTXT(PSOC)=" "
     101 S PSOC=PSOC+1
     102 S PSOTXT(PSOC)="Due to a change in criteria, additional information listed below is needed"
     103 S PSOC=PSOC+1
     104 S PSOTXT(PSOC)="to determine the final VA copay and/or insurance billable status for this Rx"
     105 S PSOC=PSOC+1
     106 S PSOTXT(PSOC)="so that appropriate action can be taken by pharmacy personnel."
     107 S PSOC=PSOC+1
     108 S PSOTXT(PSOC)=" "
     109 S PSOC=PSOC+1
     110 F EXMT="SC","CV","AO","IR","EC","MST","HNC" I $D(PSOTG(EXMT)) D
     111 . I PSOTG(EXMT)'="" Q
     112 . S PSOLTAG="REL"_EXMT
     113 . S PSOQUES=$P($T(@PSOLTAG),";",2) I PSOQUES="" Q
     114 . S PSOC=PSOC+1,PSOTXT(PSOC)=PSOQUES
     115 . S PSOQUES=$P($T(@PSOLTAG),";",2) I PSOQUES="" Q
     116 S PSOC=PSOC+1,PSOTXT(PSOC)=" "
     117 S PSOC=PSOC+1,PSOTXT(PSOC)="This message has been sent to the provider of record, the pharmacist who"
     118 S PSOC=PSOC+1,PSOTXT(PSOC)="finished the prescription order, and all holders of the PSO COPAY key."
     119 S PSOC=PSOC+1,PSOTXT(PSOC)=" "
     120 S PSOC=PSOC+1,PSOTXT(PSOC)="Providers:"
     121 S PSOC=PSOC+1,PSOTXT(PSOC)="Please respond with your answer to the question(s) as a reply to this"
     122 S PSOC=PSOC+1,PSOTXT(PSOC)="message. The prescription will be updated by the appropriate staff."
     123 S PSOC=PSOC+1,PSOTXT(PSOC)=" "
     124 S PSOC=PSOC+1,PSOTXT(PSOC)="Staff assigned to update the Prescription responses:"
     125 S PSOC=PSOC+1,PSOTXT(PSOC)="Please use the RESET COPAY STATUS/CANCEL CHARGES option to enter the responses"
     126 S PSOC=PSOC+1,PSOTXT(PSOC)="to the questions above, which may result in a Rx copay status change and/or"
     127 S PSOC=PSOC+1,PSOTXT(PSOC)="the need to remove VA copay charges or may result in a charge to the patient's"
     128 S PSOC=PSOC+1,PSOTXT(PSOC)="insurance carrier."
     129 S PSOC=PSOC+1,PSOTXT(PSOC)=" "
     130 S PSOC=PSOC+1,PSOTXT(PSOC)="Note: The SC question is now asked for Veterans who are SC>49% in order to"
     131 S PSOC=PSOC+1,PSOTXT(PSOC)="determine if the Rx can be billed to a third party insurance. These Veterans"
     132 S PSOC=PSOC+1,PSOTXT(PSOC)="will NOT be charged a VA copay."
     133 S PSOC=PSOC+1,PSOTXT(PSOC)=" "
     134 S PSOC=PSOC+1,PSOTXT(PSOC)="Supply and investigational drugs are not charged a VA copay but could be"
     135 S PSOC=PSOC+1,PSOTXT(PSOC)="reimbursable by third party insurance."
     136 ; S XMY() TO ALL THE RECIPIENTS
     137 I '$G(PSOREF) S XMY(+$P(^PSRX(RXP,0),"^",4))="" ; ORIGINAL
     138 I $G(PSOREF) S XMY(+$P(^PSRX(RXP,1,PSOREF,0),"^",17))="" ; REFILL
     139 I $G(^PSRX(RXP,"OR1")) I $P(^PSRX(RXP,"OR1"),"^",5)'="" S XMY($P(^PSRX(RXP,"OR1"),"^",5))=""
     140 F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSO COPAY",PSOCXPDA)) Q:'PSOCXPDA  S XMY(PSOCXPDA)=""
     141 S XMTEXT="PSOTXT("
     142 D ^XMD K XMSUB,XMY,XMDUZ,XMTEXT,PSODIV,PSOCXPDA,PSOLTAG,PSOC,PSOQUES,PSOTG
     143 Q
     144 ;
     145ELIG D ELIG^VADPT S PSOC=3,PSOTXT(PSOC)="Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):"     SC%: "_$P(VAEL(3),"^",2),1:""),PSOC=PSOC+1
     146 N N,I,I1,PSDIS,PSCNT
     147 S N=0 F  S N=$O(VAEL(1,N)) Q:'N  S $P(PSOTXT(PSOC)," ",14)=$P(VAEL(1,N),"^",2),PSOC=PSOC+1
     148 S PSOTXT(PSOC)=" ",PSOC=PSOC+1,PSOTXT(PSOC)="Disabilities: "
     149 F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I  S I1=$S($D(^DPT(DFN,.372,I,0)):^(0),1:"") D:+I1
     150 .S PSDIS=$S($P($G(^DIC(31,+I1,0)),"^")]""&($P($G(^(0)),"^",4)']""):$P(^(0),"^"),$P($G(^DIC(31,+I1,0)),"^",4)]"":$P(^(0),"^",4),1:""),PSCNT=$P(I1,"^",2)
     151 .S:$L(PSOTXT(PSOC)_PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), ")>80 PSOC=PSOC+1,$P(PSOTXT(PSOC)," ",14)=" "
     152 .S PSOTXT(PSOC)=$G(PSOTXT(PSOC))_PSDIS_"-"_PSCNT_"%("_$S($P(I1,"^",3):"SC",1:"NSC")_"), "
     153 S PSOC=PSOC+1 S PSOTXT(PSOC)=" ",PSOC=PSOC+1
     154 Q
     155 ;
     156 ;EXEMPTION QUESTIONS - MAIL MESSAGE POSITION;SUBSCRIPT IN "IBQ" NODE
     157RELSC ;Is this Rx for a Service Connected Condition?;1
     158RELMST ;Is this Rx related to the treatment of Military Sexual Trauma?;2
     159RELAO ;Is this Rx for treatment of Vietnam-Era Herbicide (Agent Orange) exposure?;3
     160RELIR ;Is this Rx for treatment of Ionizing Radiation exposure?;4
     161RELEC ;Is this Rx for treatment of Environmental Contaminants exposure?;5
     162RELHNC ;Is this Rx related to treatment of Head and/or Neck Cancer?;6
     163RELCV ;Is this Rx potentially for treatment related to Combat?;7
     164 ;

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCSTM.m

    r613 r623  
    1 PSOCSTM ;BHAM ISC/SAB - monthly rx cost compilation ;7/10/06 4:36pm
    2         ;;7.0;OUTPATIENT PHARMACY;**4,17,19,28,89,212,246**;DEC 1997;Build 12
    3         ;External Ref. to ^PS(55 DBIA# 2228
    4         ;External Ref. to ^DPT DBIA# 10035
    5         ;External Ref. to ^PSDRUG DBIA# 221
    6         ;
    7         ;*212 don't allow this request, if monthly compile is running
    8         ;*246 alter SRCH1 For loop to not init to numeric values
    9         ;
    10         Q:$$MTHLCK(1)            ;get lock, quit if already locked    PSO*212
    11         K BDT,EDT W !!,"**** Date Range Selection ****" S LATE=$E(DT,1,5)_"00"
    12 BEG     W ! S %DT="APE",%DT("A")="   Beginning MONTH/YEAR : " D ^%DT G:Y<0 Q W:Y'<LATE !!,$C(7),"Run 'DAILY' compilation routine for selected month!",! G:Y'<LATE BEG I (+$E(Y,6,7)'=0)!(+$E(Y,4,5)=0) D QUES G BEG
    13         S BDT=Y
    14 END     S %DT(0)=BDT W ! S %DT="APE",%DT("A")="   Ending    MONTH/YEAR : " D ^%DT K %DT G:Y<0 Q W:Y'<LATE !!,$C(7),"Run 'DAILY' compilation routine for selected month!",! G:Y'<LATE END I (+$E(Y,6,7)'=0)!(+$E(Y,4,5)=0) D QUES G END
    15         W ! S EDT=Y
    16         S ZTIO="",ZTRTN="START^PSOCSTM",ZTDESC="Rx Monthly Cost Compile" F G="EDT","BDT" S:$D(@G) ZTSAVE(G)=""
    17         D ^%ZTLOAD W:$D(ZTSK) !,"Task #"_ZTSK_" Queued!" K G,BDT,EDT,ZTSAVE,ZTIO,ZTRTN,ZTDESC Q
    18         L -^PSOCSTM                                    ;unlock month end flag
    19         ;
    20 START   Q:$$MTHLCK^PSOCSTM(1)      ;get lock, quit if already locked  PSO*212
    21         K ^TMP($J) S PSG=0 F I=1:1 S X=$T(G+I) Q:$P(X,";",3)=""  S A(I)=$P(X,";",3),B(I)=$P(X,";",4),PSG=PSG+1,A1(I)=$P(X,";",5),B1(I)=$P(X,";",6)
    22         S PSD=0 F I=1:1 S X=$T(D+I) Q:X=""  S C(I)=$P(X,";",3),D(I)=$P(X,";",4),PSD=PSD+1,C1(I)=$P(X,";",5),D1(I)=$P(X,";",6)
    23         F PSDT=BDT:100:EDT K ^PSCST(PSDT),^PSCST("B",PSDT)
    24         S STOP=$E(EDT,1,5)_"31.2359",PSDT=BDT F  S PSDT=$O(^PSCST(PSDT)) Q:'PSDT!(PSDT>STOP)  K ^PSCST(PSDT),^PSCST("B",PSDT)
    25         K STOP
    26         ;
    27 SRCH    F PSDT=BDT:100:EDT S PSDTX=PSDT+100 D:$E(PSDT,4,5)<13 SRCH1,SET1 S:$E(PSDT,4,5)>12 PSDT=$E(PSDT,1,2)_($E(PSDT,3)+1)_"0000"
    28         S PSOCNT=0 F PSDT=0:0 S PSDT=$O(^PSCST("B",PSDT)) Q:'PSDT  S PSD=PSDT,PSOCNT=PSOCNT+1
    29         S ^PSCST(0)="DRUG COST^50.9D^"_PSD_"^"_PSOCNT D ZNODE
    30 Q       K ^TMP($J),%DT,A,B,BDT,COST,DATA,DATA1,DATA2,DRG,DFN,EDT,I,II,LATE,ML,OR,PAST,PHYS,PSOCNT,PSD,PSDT,PSDT1,PSDTX,RXF,PSG,QTY,RF,RX0
    31         K RX2,DIV,D,C,CLINIC,A1,B1,C1,D1,RX1,RXN,VAL,VAR,PGM,VALUE,CDT,NDT,VISITS,DV,VIS,WD,X,X1,X2,Y S:$D(ZTQUEUED) ZTREQ="@"
    32         L -^PSOCSTM                                    ;unlock month end flag
    33         Q
    34         ;
    35 SRCH1   D INI
    36         ;refill
    37         S PSDT1=PSDT                                ;*246
    38         F  S PSDT1=$O(^PSRX("AL",PSDT1)) Q:($E(PSDT1,1,7)<PSDT)!($E(PSDT1,1,7)>PSDTX)  D
    39         .S CDT=$P(PSDT1,".") F RXN=0:0 S RXN=$O(^PSRX("AL",PSDT1,RXN)) Q:'RXN  S RXF="" F  S RXF=$O(^PSRX("AL",PSDT1,RXN,RXF)) Q:RXF=""  D CHK
    40         .S NDT=$O(^PSRX("AL",PSDT1)) D:$P(NDT,".")'=CDT VST
    41         ;partial fill
    42         S PSDT1=PSDT                                ;*246
    43         F  S PSDT1=$O(^PSRX("AM",PSDT1)) Q:($E(PSDT1,1,7)<PSDT)!($E(PSDT1,1,7)>PSDTX)  D
    44         .S CDT=$P(PSDT1,"."),RXN=0 F  S RXN=$O(^PSRX("AM",PSDT1,RXN)) Q:'RXN  S RXF=0 F  S RXF=$O(^PSRX("AM",PSDT1,RXN,RXF)) Q:RXF=""  S PAR=1 D CHK
    45         .S NDT=$O(^PSRX("AM",PSDT1)) D:$P(NDT,".")'=CDT VST K PAR
    46         Q
    47 INI     K VIS S (VISITS,DV)=0 F  S DV=$O(^PS(59,DV)) Q:'+DV  S VIS(DV)=0
    48         Q
    49 VST     S DV=0 F  S DV=$O(^TMP($J,"PAT",DV)) Q:'DV  D
    50         .S DFN=0 F  S DFN=$O(^TMP($J,"PAT",DV,DFN)) Q:'DFN  S VIS(DV)=VIS(DV)+1,VISITS=VISITS+1
    51         K ^TMP($J,"PAT") Q
    52 CHK     I '$D(^PSRX(RXN,0)) K ^PSRX("AL",PSDT,RXN,RXF) Q
    53         Q:'$D(^PSRX(RXN,2))  S RX0=^PSRX(RXN,0),RX2=^PSRX(RXN,2)
    54         S DFN=+$P(RX0,"^",2) Q:'$D(^DPT(DFN,0))  D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN)
    55         S DRG=+$P(RX0,"^",6) Q:'$D(^PSDRUG(DRG,0))
    56         ;S CLASS=+$P(^(0),"^",2) Q:'$D(^PS(50.605,CLASS,0))
    57         S DIV=+$P(RX2,"^",9) Q:'$D(^PS(59,DIV,0))
    58         S PHYS=+$P(RX0,"^",4) Q:'$D(^VA(200,PHYS,0))
    59         S PAST=+$P(RX0,"^",3) Q:'$D(^PS(53,PAST,0))
    60         S CLINIC=+$P(RX0,"^",5) K:'$D(^SC(CLINIC,0)) CLINIC
    61         S COST=$S(+$P(RX0,"^",17):+$P(RX0,"^",17),$D(^PSDRUG(DRG,660)):+$P(^(660),"^",6),1:0)
    62         I $G(PAR) D  S PR=0 Q
    63         .I '$D(^PSRX(RXN,"P",RXF,0)) K ^PSRX("AM",PSDT,RXN,RXF) Q
    64         .I $P(^PSRX(RXN,"P",RXF,0),"^",19) D
    65         ..S RX1=^PSRX(RXN,"P",RXF,0),DIV=$S($P(RX1,"^",9):$P(RX1,"^",9),1:$P(RX2,"^",9))
    66         ..S PHYS=$S($P(RX1,"^",17):$P(RX1,"^",17),1:$P(RX0,"^",4))
    67         ..S OR=0,RF=1,QTY=+$P(RX1,"^",4),ML=$S($P(RX1,"^",2)="M":1,1:0),WD=$S($P(RX1,"^",2)="W":1,1:0) S COST=QTY*COST D SET,SF
    68         I $P(RX2,"^",13),'RXF D  Q
    69         .S OR=1,RF=0,QTY=+$P(RX0,"^",7),ML=$S($P(RX0,"^",11)="M":1,1:0),WD=$S($P(RX0,"^",11)="W":1,1:0),COST=QTY*COST D SET,SF
    70         D:RXF
    71         .I '$D(^PSRX(RXN,1,RXF,0)) K ^PSRX("AL",PSDT,RXN,RXF) Q
    72         .Q:'$P(^PSRX(RXN,1,RXF,0),"^",18)  S RX1=^PSRX(RXN,1,RXF,0)
    73         .S OR=0,RF=1,QTY=+$P(RX1,"^",4),ML=$S($P(RX1,"^",2)="M":1,1:0),WD=$S($P(RX1,"^",2)="W":1,1:0) S COST=QTY*COST
    74         .S PHYS=$S($P(RX1,"^",17):$P(RX1,"^",17),1:$P(RX0,"^",4)),DIV=$S($P(RX1,"^",9):$P(RX1,"^",9),1:$P(RX2,"^",9))
    75         .D SET,SF
    76         Q
    77 SF      S DATA="^"_OR_"^"_RF_"^"_COST_"^"_QTY_"^"_ML_"^"_WD,^TMP($J,"PAT",DIV,DFN)=""
    78         F I=1:1:PSG Q:('$D(CLINIC))&(I=PSG)  S DATA1=$S($D(@A(I))#2:^(0),1:@(B(I))_"^0^0^0^0") S DATA2=+$P(DATA1,"^") D
    79         .F II=2:1:7 S VALUE=$P(DATA,"^",II)+$P(DATA1,"^",II),DATA2=DATA2_"^"_VALUE S:II=7 @A(I)=DATA2
    80         .S:'$D(@A1(I)) @A1(I)=B1(I) S $P(@A1(I),"^",4)=+$P(@A1(I),"^",4)+1,$P(@A1(I),"^",3)=@B(I)
    81         F I=1:1:PSD S DATA1=$S(($D(@(C(I)))#2):$G(^(0)),1:@(D(I))_"^0^0^0^0") S DATA2=+$P(DATA1,"^") D
    82         .F II=2:1:7 S VALUE=$P(DATA,"^",II)+$P(DATA1,"^",II),DATA2=DATA2_"^"_VALUE S:II=7 @C(I)=DATA2 D
    83         .S:'$D(@C1(I)) @C1(I)=D1(I) S $P(@C1(I),"^",4)=+$P(@C1(I),"^",4)+1,$P(@C1(I),"^",3)=@D(I)
    84         Q
    85         ;
    86 SET     S:'$D(^PSCST(PSDT,0)) ^PSCST(PSDT,0)=PSDT,^PSCST("B",PSDT,PSDT)="" Q
    87 SET1    S ^PSCST(PSDT,1)=DT_"^"_VISITS
    88         S DV=0 F  S DV=$O(VIS(DV)) Q:'DV  S $P(^PSCST(PSDT,"V",DV,0),"^",8)=+VIS(DV)
    89         Q
    90 QUES    W !,$C(7),"??",!,"For example, September 1993 could be entered as 9/93 or SEP 93.",!,"For Year 2000 Compliance enter date as 9/2000 or SEP 2000." Q
    91 ZNODE   ;update zero nodes
    92         F PSDT=BDT:$S('$D(BEGDATE):100,1:1):EDT S NDZ=0 F ND="D","P","PS","S","V" S NODE(ND)=0 D:$O(^PSCST(PSDT,"D",0))
    93         .F  S NDZ=$O(^PSCST(PSDT,ND,NDZ)) Q:'NDZ  S NODE(ND)=NODE(ND)+1,NDZ2=NDZ D:ND="V"
    94         ..S NDZ1=0,NODE(ND,"P")=0 F  S NDZ1=$O(^PSCST(PSDT,ND,NDZ2,"P",NDZ1)) Q:'NDZ1  S NODE(ND,"P")=NODE(ND,"P")+1
    95         ..S $P(^PSCST(PSDT,ND,NDZ2,"P",0),"^",4)=NODE(ND,"P"),NDZ1=0
    96         .S:$G(^PSCST(PSDT,ND,0))]"" $P(^PSCST(PSDT,ND,0),"^",4)=NODE(ND),NDZ=0
    97         K NDZ,ND,NODE,NDZ2,NDZ1 Q
    98         ;
    99 MTHLCK(GET)     ;lock for month end run or query if month end is running
    100         ; INPUT:  GET = 1  try to get lock and keep locked
    101         ;               0  query if locked only, leave as unlocked
    102         ; RETURNS: 1 - already locked
    103         ;          0 - was not already locked
    104         ;
    105         I '$D(ZTQUEUED) W !,"checking for duplicate job..."
    106         N GOTLOCK
    107         L +^PSOCSTM:10 S GOTLOCK=$T   ;delay 10 secs to handle slower systems
    108         I GOTLOCK,'GET L -^PSOCSTM Q 0
    109         I GOTLOCK,GET Q 0
    110         N AST S AST="",$P(AST,"*",79)=""
    111         D:'($D(ZTQUEUED))
    112         .W !!,*7,AST,!
    113         .W "Monthly Rx Cost Compilation is currently running, "
    114         .W "Try your request later",!
    115         .W AST,!!
    116         Q 1
    117         ;
    118         ;
    119 G       ;;
    120         ;;^PSCST(PSDT,0);PSDT;^TMP($J,"A1");1
    121         ;;^PSCST(PSDT,"P",PHYS,0);PHYS;^PSCST(PSDT,"P",0);^50.9001PA^^
    122         ;;^PSCST(PSDT,"P",PHYS,"D",DRG,0);DRG;^PSCST(PSDT,"P",PHYS,"D",0);^50.9002PA^^
    123         ;;^PSCST(PSDT,"D",DRG,0);DRG;^PSCST(PSDT,"D",0);^50.9003PA^^
    124         ;;^PSCST(PSDT,"D",DRG,"P",PHYS,0);PHYS;^PSCST(PSDT,"D",DRG,"P",0);^50.9004PA^^
    125         ;;^PSCST(PSDT,"PS",PAST,0);PAST;^PSCST(PSDT,"PS",0);^50.9005PA^^
    126         ;;^PSCST(PSDT,"S",CLINIC,0);CLINIC;^PSCST(PSDT,"S",0);^50.9008PA^^
    127         ;;
    128 D       ;;
    129         ;;^PSCST(PSDT,"V",DIV,0);DIV;^PSCST(PSDT,"V",0);^50.9006PA^^
    130         ;;^PSCST(PSDT,"V",DIV,"D",DRG,0);DRG;^PSCST(PSDT,"V",DIV,"D",0);^50.9007PA^^
    131         ;;^PSCST(PSDT,"V",DIV,"P",PHYS,0);PHYS;^PSCST(PSDT,"V",DIV,"P",0);^50.901PA^^
     1PSOCSTM ;BHAM ISC/SAB - monthly rx cost compilation ;9/14/05 1:13pm
     2 ;;7.0;OUTPATIENT PHARMACY;**4,17,19,28,89,212**;DEC 1997
     3 ;External Ref. to ^PS(55 DBIA# 2228
     4 ;External Ref. to ^DPT DBIA# 10035
     5 ;External Ref. to ^PSDRUG DBIA# 221
     6 ;
     7 ;PSO*212 don't allow this request, if monthly compile is running
     8 ;
     9 Q:$$MTHLCK(1)            ;get lock, quit if already locked    PSO*212
     10 K BDT,EDT W !!,"**** Date Range Selection ****" S LATE=$E(DT,1,5)_"00"
     11BEG W ! S %DT="APE",%DT("A")="   Beginning MONTH/YEAR : " D ^%DT G:Y<0 Q W:Y'<LATE !!,$C(7),"Run 'DAILY' compilation routine for selected month!",! G:Y'<LATE BEG I (+$E(Y,6,7)'=0)!(+$E(Y,4,5)=0) D QUES G BEG
     12 S BDT=Y
     13END S %DT(0)=BDT W ! S %DT="APE",%DT("A")="   Ending    MONTH/YEAR : " D ^%DT K %DT G:Y<0 Q W:Y'<LATE !!,$C(7),"Run 'DAILY' compilation routine for selected month!",! G:Y'<LATE END I (+$E(Y,6,7)'=0)!(+$E(Y,4,5)=0) D QUES G END
     14 W ! S EDT=Y
     15 S ZTIO="",ZTRTN="START^PSOCSTM",ZTDESC="Rx Monthly Cost Compile" F G="EDT","BDT" S:$D(@G) ZTSAVE(G)=""
     16 D ^%ZTLOAD W:$D(ZTSK) !,"Task #"_ZTSK_" Queued!" K G,BDT,EDT,ZTSAVE,ZTIO,ZTRTN,ZTDESC Q
     17 L -^PSOCSTM                                    ;unlock month end flag
     18 ;
     19START Q:$$MTHLCK^PSOCSTM(1)      ;get lock, quit if already locked  PSO*212
     20 K ^TMP($J) S PSG=0 F I=1:1 S X=$T(G+I) Q:$P(X,";",3)=""  S A(I)=$P(X,";",3),B(I)=$P(X,";",4),PSG=PSG+1,A1(I)=$P(X,";",5),B1(I)=$P(X,";",6)
     21 S PSD=0 F I=1:1 S X=$T(D+I) Q:X=""  S C(I)=$P(X,";",3),D(I)=$P(X,";",4),PSD=PSD+1,C1(I)=$P(X,";",5),D1(I)=$P(X,";",6)
     22 F PSDT=BDT:100:EDT K ^PSCST(PSDT),^PSCST("B",PSDT)
     23 S STOP=$E(EDT,1,5)_"31.2359",PSDT=BDT F  S PSDT=$O(^PSCST(PSDT)) Q:'PSDT!(PSDT>STOP)  K ^PSCST(PSDT),^PSCST("B",PSDT)
     24 K STOP
     25 ;
     26SRCH F PSDT=BDT:100:EDT S PSDTX=PSDT+100 D:$E(PSDT,4,5)<13 SRCH1,SET1 S:$E(PSDT,4,5)>12 PSDT=$E(PSDT,1,2)_($E(PSDT,3)+1)_"0000"
     27 S PSOCNT=0 F PSDT=0:0 S PSDT=$O(^PSCST("B",PSDT)) Q:'PSDT  S PSD=PSDT,PSOCNT=PSOCNT+1
     28 S ^PSCST(0)="DRUG COST^50.9D^"_PSD_"^"_PSOCNT D ZNODE
     29Q K ^TMP($J),%DT,A,B,BDT,COST,DATA,DATA1,DATA2,DRG,DFN,EDT,I,II,LATE,ML,OR,PAST,PHYS,PSOCNT,PSD,PSDT,PSDT1,PSDTX,RXF,PSG,QTY,RF,RX0
     30 K RX2,DIV,D,C,CLINIC,A1,B1,C1,D1,RX1,RXN,VAL,VAR,PGM,VALUE,CDT,NDT,VISITS,DV,VIS,WD,X,X1,X2,Y S:$D(ZTQUEUED) ZTREQ="@"
     31 L -^PSOCSTM                                    ;unlock month end flag
     32 Q
     33 ;
     34SRCH1 D INI F PSDT1=PSDT:0:PSDTX S PSDT1=$O(^PSRX("AL",PSDT1)) Q:'PSDT1!($E(PSDT1,1,7)>PSDTX)  D
     35 .S CDT=$P(PSDT1,".") F RXN=0:0 S RXN=$O(^PSRX("AL",PSDT1,RXN)) Q:'RXN  S RXF="" F  S RXF=$O(^PSRX("AL",PSDT1,RXN,RXF)) Q:RXF=""  D CHK
     36 .S NDT=$O(^PSRX("AL",PSDT1)) D:$P(NDT,".")'=CDT VST
     37 F PSDT1=PSDT:0:PSDTX S PSDT1=$O(^PSRX("AM",PSDT1)) Q:'PSDT1!($E(PSDT1,1,7)>PSDTX)  D
     38 .S CDT=$P(PSDT1,"."),RXN=0 F  S RXN=$O(^PSRX("AM",PSDT1,RXN)) Q:'RXN  S RXF=0 F  S RXF=$O(^PSRX("AM",PSDT1,RXN,RXF)) Q:RXF=""  S PAR=1 D CHK
     39 .S NDT=$O(^PSRX("AM",PSDT1)) D:$P(NDT,".")'=CDT VST K PAR
     40 Q
     41INI K VIS S (VISITS,DV)=0 F  S DV=$O(^PS(59,DV)) Q:'+DV  S VIS(DV)=0
     42 Q
     43VST S DV=0 F  S DV=$O(^TMP($J,"PAT",DV)) Q:'DV  D
     44 .S DFN=0 F  S DFN=$O(^TMP($J,"PAT",DV,DFN)) Q:'DFN  S VIS(DV)=VIS(DV)+1,VISITS=VISITS+1
     45 K ^TMP($J,"PAT") Q
     46CHK I '$D(^PSRX(RXN,0)) K ^PSRX("AL",PSDT,RXN,RXF) Q
     47 Q:'$D(^PSRX(RXN,2))  S RX0=^PSRX(RXN,0),RX2=^PSRX(RXN,2)
     48 S DFN=+$P(RX0,"^",2) Q:'$D(^DPT(DFN,0))  D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN)
     49 S DRG=+$P(RX0,"^",6) Q:'$D(^PSDRUG(DRG,0))
     50 ;S CLASS=+$P(^(0),"^",2) Q:'$D(^PS(50.605,CLASS,0))
     51 S DIV=+$P(RX2,"^",9) Q:'$D(^PS(59,DIV,0))
     52 S PHYS=+$P(RX0,"^",4) Q:'$D(^VA(200,PHYS,0))
     53 S PAST=+$P(RX0,"^",3) Q:'$D(^PS(53,PAST,0))
     54 S CLINIC=+$P(RX0,"^",5) K:'$D(^SC(CLINIC,0)) CLINIC
     55 S COST=$S(+$P(RX0,"^",17):+$P(RX0,"^",17),$D(^PSDRUG(DRG,660)):+$P(^(660),"^",6),1:0)
     56 I $G(PAR) D  S PR=0 Q
     57 .I '$D(^PSRX(RXN,"P",RXF,0)) K ^PSRX("AM",PSDT,RXN,RXF) Q
     58 .I $P(^PSRX(RXN,"P",RXF,0),"^",19) D
     59 ..S RX1=^PSRX(RXN,"P",RXF,0),DIV=$S($P(RX1,"^",9):$P(RX1,"^",9),1:$P(RX2,"^",9))
     60 ..S PHYS=$S($P(RX1,"^",17):$P(RX1,"^",17),1:$P(RX0,"^",4))
     61 ..S OR=0,RF=1,QTY=+$P(RX1,"^",4),ML=$S($P(RX1,"^",2)="M":1,1:0),WD=$S($P(RX1,"^",2)="W":1,1:0) S COST=QTY*COST D SET,SF
     62 I $P(RX2,"^",13),'RXF D  Q
     63 .S OR=1,RF=0,QTY=+$P(RX0,"^",7),ML=$S($P(RX0,"^",11)="M":1,1:0),WD=$S($P(RX0,"^",11)="W":1,1:0),COST=QTY*COST D SET,SF
     64 D:RXF
     65 .I '$D(^PSRX(RXN,1,RXF,0)) K ^PSRX("AL",PSDT,RXN,RXF) Q
     66 .Q:'$P(^PSRX(RXN,1,RXF,0),"^",18)  S RX1=^PSRX(RXN,1,RXF,0)
     67 .S OR=0,RF=1,QTY=+$P(RX1,"^",4),ML=$S($P(RX1,"^",2)="M":1,1:0),WD=$S($P(RX1,"^",2)="W":1,1:0) S COST=QTY*COST
     68 .S PHYS=$S($P(RX1,"^",17):$P(RX1,"^",17),1:$P(RX0,"^",4)),DIV=$S($P(RX1,"^",9):$P(RX1,"^",9),1:$P(RX2,"^",9))
     69 .D SET,SF
     70 Q
     71SF S DATA="^"_OR_"^"_RF_"^"_COST_"^"_QTY_"^"_ML_"^"_WD,^TMP($J,"PAT",DIV,DFN)=""
     72 F I=1:1:PSG Q:('$D(CLINIC))&(I=PSG)  S DATA1=$S($D(@A(I))#2:^(0),1:@(B(I))_"^0^0^0^0") S DATA2=+$P(DATA1,"^") D
     73 .F II=2:1:7 S VALUE=$P(DATA,"^",II)+$P(DATA1,"^",II),DATA2=DATA2_"^"_VALUE S:II=7 @A(I)=DATA2
     74 .S:'$D(@A1(I)) @A1(I)=B1(I) S $P(@A1(I),"^",4)=+$P(@A1(I),"^",4)+1,$P(@A1(I),"^",3)=@B(I)
     75 F I=1:1:PSD S DATA1=$S(($D(@(C(I)))#2):$G(^(0)),1:@(D(I))_"^0^0^0^0") S DATA2=+$P(DATA1,"^") D
     76 .F II=2:1:7 S VALUE=$P(DATA,"^",II)+$P(DATA1,"^",II),DATA2=DATA2_"^"_VALUE S:II=7 @C(I)=DATA2 D
     77 .S:'$D(@C1(I)) @C1(I)=D1(I) S $P(@C1(I),"^",4)=+$P(@C1(I),"^",4)+1,$P(@C1(I),"^",3)=@D(I)
     78 Q
     79 ;
     80SET S:'$D(^PSCST(PSDT,0)) ^PSCST(PSDT,0)=PSDT,^PSCST("B",PSDT,PSDT)="" Q
     81SET1 S ^PSCST(PSDT,1)=DT_"^"_VISITS
     82 S DV=0 F  S DV=$O(VIS(DV)) Q:'DV  S $P(^PSCST(PSDT,"V",DV,0),"^",8)=+VIS(DV)
     83 Q
     84QUES W !,$C(7),"??",!,"For example, September 1993 could be entered as 9/93 or SEP 93.",!,"For Year 2000 Compliance enter date as 9/2000 or SEP 2000." Q
     85ZNODE ;update zero nodes
     86 F PSDT=BDT:$S('$D(BEGDATE):100,1:1):EDT S NDZ=0 F ND="D","P","PS","S","V" S NODE(ND)=0 D:$O(^PSCST(PSDT,"D",0))
     87 .F  S NDZ=$O(^PSCST(PSDT,ND,NDZ)) Q:'NDZ  S NODE(ND)=NODE(ND)+1,NDZ2=NDZ D:ND="V"
     88 ..S NDZ1=0,NODE(ND,"P")=0 F  S NDZ1=$O(^PSCST(PSDT,ND,NDZ2,"P",NDZ1)) Q:'NDZ1  S NODE(ND,"P")=NODE(ND,"P")+1
     89 ..S $P(^PSCST(PSDT,ND,NDZ2,"P",0),"^",4)=NODE(ND,"P"),NDZ1=0
     90 .S:$G(^PSCST(PSDT,ND,0))]"" $P(^PSCST(PSDT,ND,0),"^",4)=NODE(ND),NDZ=0
     91 K NDZ,ND,NODE,NDZ2,NDZ1 Q
     92 ;
     93MTHLCK(GET) ;lock for month end run or query if month end is running
     94 ; INPUT:  GET = 1  try to get lock and keep locked
     95 ;               0  query if locked only, leave as unlocked
     96 ; RETURNS: 1 - already locked
     97 ;          0 - was not already locked
     98 ;
     99 I '$D(ZTQUEUED) W !,"checking for duplicate job..."
     100 N GOTLOCK
     101 L +^PSOCSTM:10 S GOTLOCK=$T   ;delay 10 secs to handle slower systems
     102 I GOTLOCK,'GET L -^PSOCSTM Q 0
     103 I GOTLOCK,GET Q 0
     104 N AST S AST="",$P(AST,"*",79)=""
     105 D:'($D(ZTQUEUED))
     106 .W !!,*7,AST,!
     107 .W "Monthly Rx Cost Compilation is currently running, "
     108 .W "Try your request later",!
     109 .W AST,!!
     110 Q 1
     111 ;
     112 ;
     113G ;;
     114 ;;^PSCST(PSDT,0);PSDT;^TMP($J,"A1");1
     115 ;;^PSCST(PSDT,"P",PHYS,0);PHYS;^PSCST(PSDT,"P",0);^50.9001PA^^
     116 ;;^PSCST(PSDT,"P",PHYS,"D",DRG,0);DRG;^PSCST(PSDT,"P",PHYS,"D",0);^50.9002PA^^
     117 ;;^PSCST(PSDT,"D",DRG,0);DRG;^PSCST(PSDT,"D",0);^50.9003PA^^
     118 ;;^PSCST(PSDT,"D",DRG,"P",PHYS,0);PHYS;^PSCST(PSDT,"D",DRG,"P",0);^50.9004PA^^
     119 ;;^PSCST(PSDT,"PS",PAST,0);PAST;^PSCST(PSDT,"PS",0);^50.9005PA^^
     120 ;;^PSCST(PSDT,"S",CLINIC,0);CLINIC;^PSCST(PSDT,"S",0);^50.9008PA^^
     121 ;;
     122D ;;
     123 ;;^PSCST(PSDT,"V",DIV,0);DIV;^PSCST(PSDT,"V",0);^50.9006PA^^
     124 ;;^PSCST(PSDT,"V",DIV,"D",DRG,0);DRG;^PSCST(PSDT,"V",DIV,"D",0);^50.9007PA^^
     125 ;;^PSCST(PSDT,"V",DIV,"P",PHYS,0);PHYS;^PSCST(PSDT,"V",DIV,"P",0);^50.901PA^^

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODEA.m

    r613 r623  
    1 PSODEA  ;BHAM ISC/  - HELP TEXT FOR DEA FIELD IN DRUG FILE ; 10/17/07 7:41am
    2         ;;7.0;OUTPATIENT PHARMACY;**206**;DEC 1997;Build 39
    3         W !,"THE SPECIAL HANDLING CODE IS A 2 TO 6 POSTION FIELD.  IF APPLICABLE,",!,"A SCHEDULE CODE MUST APPEAR IN THE FIRST POSITION.  FOR EXAMPLE,"
    4         W !,"A SCHEDULE 3 NARCOTIC WILL BE CODED '3A' AND A SCHEDULE 2 DEPRESSANT",!,"WILL BE CODED '2L'.  THE CODES ARE:",!
    5         F I=1:1 S AA=$P($T(D+I),";",3,99) Q:AA=""  W !?10,AA
    6 D       K AA Q
    7         ;;0          MANUFACTURED IN PHARMACY
    8         ;;1          SCHEDULE 1 ITEM
    9         ;;2          SCHEDULE 2 ITEM
    10         ;;3          SCHEDULE 3 ITEM
    11         ;;4          SCHEDULE 4 ITEM
    12         ;;5          SCHEDULE 5 ITEM
    13         ;;6          LEGEND ITEM
    14         ;;9          OVER-THE-COUNTER
    15         ;;L          DEPRESSANTS AND STIMULANTS
    16         ;;A          NARCOTICS AND ALCOHOLICS
    17         ;;P          DATED DRUGS
    18         ;;I          INVESTIGATIONAL DRUGS
    19         ;;M          BULK COMPOUND ITEMS
    20         ;;C          CONTROLLED SUBSTANCES - NON NARCOTIC
    21         ;;R          RESTRICTED ITEMS
    22         ;;S          SUPPLY ITEMS
    23         ;;B          ALLOW REFILL (SCH. 3, 4, 5 ONLY)
    24         ;;W          NOT RENEWABLE
    25         ;;
    26 EDIT    ;INPUT XFORM FOR DEA FIELD IN DRUG FILE
    27         I X["B",(+X<3) W !,"The B designation is only valid for schedule 3, 4, 5 !",$C(7) K X Q
    28         Q
     1PSODEA ;BHAM ISC/  - HELP TEXT FOR DEA FIELD IN DRUG FILE ; 06/03/92 17:28
     2 ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
     3 W !,"THE SPECIAL HANDLING CODE IS A 2 TO 6 POSTION FIELD.  IF APPLICABLE,",!,"A SCHEDULE CODE MUST APPEAR IN THE FIRST POSITION.  FOR EXAMPLE,"
     4 W !,"A SCHEDULE 3 NARCOTIC WILL BE CODED '3A' AND A SCHEDULE 2 DEPRESSANT",!,"WILL BE CODED '2L'.  THE CODES ARE:",!
     5 F I=1:1 S AA=$P($T(D+I),";",3,99) Q:AA=""  W !?10,AA
     6D K AA Q
     7 ;;0          MANUFACTURED IN PHARMACY
     8 ;;1          SCHEDULE 1 ITEM
     9 ;;2          SCHEDULE 2 ITEM
     10 ;;3          SCHEDULE 3 ITEM
     11 ;;4          SCHEDULE 4 ITEM
     12 ;;5          SCHEDULE 5 ITEM
     13 ;;6          LEGEND ITEM
     14 ;;9          OVER-THE-COUNTER
     15 ;;L          DEPRESSANTS AND STIMULANTS
     16 ;;A          NARCOTICS AND ALCOHOLICS
     17 ;;P          DATED DRUGS
     18 ;;I          INVESTIGATIONAL DRUGS
     19 ;;M          BULK COMPOUND ITEMS
     20 ;;C          CONTROLLED SUBSTANCES - NON NARCOTIC
     21 ;;R          RESTRICTED ITEMS
     22 ;;S          SUPPLY ITEMS
     23 ;;B          ALLOW REFILL (SCH. 3, 4, 5 NARCOTICS ONLY)
     24 ;;W          NOT RENEWABLE
     25 ;;
     26EDIT ;INPUT XFORM FOR DEA FIELD IN DRUG FILE
     27 I X["B",(+X<3!(X'["A")) W !,"The B designation is only valid for schedule 3, 4, 5 narcotics !",$C(7) K X Q
     28 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODGDGI.m

    r613 r623  
    1 PSODGDGI        ;BIR/SAB - drug drug interaction checker ; 6/28/07 7:36am
    2         ;;7.0;OUTPATIENT PHARMACY;**10,27,48,130,144,132,188,207,243,274**;DEC 1997;Build 8
    3         ;External reference to ^PS(56 supported by DBIA 2229
    4         ;External reference to ^PSDRUG supported by DBIA 221
    5         ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
    6         ;External reference to DDIEX^PSNAPIS supported by DBIA 2574
    7         ;External references to ^ORRDI1 supported by DBIA 4659
    8         ;External reference ^XTMP("ORRDI" supported by DBIA 4660
    9         Q:$$DDIEX^PSNAPIS($P(PSODRUG("NDF"),"A"),$P(PSODRUG("NDF"),"A",2))
    10         N PSOICT S (CRIT,DRG,LSI,DGI,DGS,SER,SERS,STA,PSOICT)=""
    11         F  S STA=$O(PSOSD(STA)) Q:STA=""!($G(PSORX("DFLG")))  F  S DRG=$O(PSOSD(STA,DRG)) Q:DRG=""!($G(PSORX("DFLG")))  I $P(PSOSD(STA,DRG),"^",2)<10 D
    12         .Q:$P(PSOSD(STA,DRG),"^",7)']""
    13         .S NDF=$P(PSOSD(STA,DRG),"^",7)
    14         .;New logic to Loop All interactions and filter-up a critical if it exists
    15         .S IT=0,PSOICT=""
    16         .F  S IT=$O(^PS(56,"APD",NDF,PSODRUG("NDF"),IT)) Q:'IT  D
    17         ..Q:$$DDIEX^PSNAPIS($P(NDF,"A"),$P(NDF,"A",2))
    18         ..Q:$P(^PS(56,IT,0),"^",7)&($P(^PS(56,IT,0),"^",7)<DT)
    19         ..I 'PSOICT S PSOICT=IT Q
    20         ..I $P($G(^PS(56,IT,0)),"^",4)=1 S PSOICT=IT Q
    21         ..Q
    22         .I 'PSOICT Q
    23         .S IT=PSOICT
    24         .I STA="ZNONVA" S DNM=DRG W ! D NVA^PSODRDU1 K DNM,IT,PSOICT Q
    25         .D BLD Q:+$G(PSORX("DFLG"))
    26         .Q
    27         I '$D(^XUSEC("PSORPH",DUZ)),$G(DGI)]"" S:+CRIT PSONEW("STATUS")=4 W $C(7),!,"DRUG INTERACTION WITH RX #s: "_LSI,! K LSI,DRG,IT,NDF,PSOICT
    28         K IT
    29         ; CHECK FOR REMOTE DRUG INTERACTIONS
    30         I +$G(PSORX("DFLG")) Q
    31         I $T(HAVEHDR^ORRDI1)']"" Q
    32         I '$$HAVEHDR^ORRDI1 Q
    33         I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) D  Q
    34         .I $T(REMOTE^PSORX1)]"" Q
    35         .W !,"Remote data not available - Only local order checks processed." D PAUSE^PSOORRD2
    36         I $P($G(^XTMP("ORRDI","PSOO",PSODFN,0)),"^",3)<0 W !,"Remote data not available - Only local order checks processed." D PAUSE^PSOORRD2 Q
    37         I $D(^TMP($J,"DI"_PSODFN)) K ^TMP($J,"DI") M ^TMP($J,"DI")=^TMP($J,"DI"_PSODFN) D DRGINT^PSOORRD2
    38         K ^TMP($J,"DI"_PSODFN),^TMP($J,"DI")
    39         Q
    40 TECH    ;add tech entry to RX VERIFY file (#52.4)
    41         I +CRIT S PSODI=1,DIC="^PS(52.4,",DLAYGO=52.4,DIC(0)="L",(DINUM,X)=PSOX("IRXN"),DIC("DR")="1////"_PSODFN_";2////"_DUZ_";4///"_DT_";7///"_1_";7.1///"_SER_";7.2///"_DGI K DD,DO D FILE^DICN K DD,DO
    42         S:$G(DGS)'="" $P(^PSRX(PSOX("IRXN"),"DRI"),"^")=SERS,$P(^PSRX(PSOX("IRXN"),"DRI"),"^",2)=DGS  K PSODI,CRIT,DIC,DLAYGO,DINUM,DGI,DGS,SER,SERS Q
    43 BLD     I $D(^XUSEC("PSORPH",DUZ)) D PHARM Q
    44         S LSI=$P(^PSRX(+PSOSD(STA,DRG),0),"^")_"/"_$P(^PSDRUG($P(^(0),"^",6),0),"^")_","_LSI,DGI=$P(PSOSD(STA,DRG),"^")_","_DGI,SER=IT_","_SER I $P(PSOSD(STA,DRG),"^",9),$P(^PS(56,IT,0),"^",4)=1 S $P(^PSRX(+PSOSD(STA,DRG),"STA"),"^")=4
    45         I $P(^PS(56,IT,0),"^",4)=2 S SERS=IT_","_SERS,DGS=$P(PSOSD(STA,DRG),"^")_","_DGS
    46         S:$P(^PS(56,IT,0),"^",4)=1 CRIT=1 Q
    47 PHARM   ;pharmacist verification of drug interaction
    48         D PSOL^PSSLOCK($P(PSOSD(STA,DRG),"^")) I '$G(PSOMSG) D  K PSOMSG S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR S PSORX("DFLG")=1 Q
    49         .I $P($G(PSOMSG),"^",2)'="" W !!,$P(PSOMSG,"^",2) D  Q
    50         ..W !,"Rx: "_$P($G(^PSRX($P(PSOSD(STA,DRG),"^"),0)),"^")_"    Drug: "_$P($G(^PSDRUG(+$P($G(^(0)),"^",6),0)),"^")
    51         ..W !,"which interacts with the drug you are entering!",!
    52         .W !!,"Another person is editing Rx "_$P($G(^PSRX($P(PSOSD(STA,DRG),"^"),0)),"^")_",",!,"which interacts with the drug you are entering!",!
    53         S PSODGRLX=$P(PSOSD(STA,DRG),"^")
    54         S SER=^PS(56,IT,0),DIR("?",1)="Answer 'YES' if you DO want to "_$S($P(SER,"^",4)=1:"continue processing",1:"enter an intervention for")_" this medication,"
    55         S DIR("?")="       'NO' if you DON'T want to "_$S($P(SER,"^",4)=1:"continue processing",1:"enter an intervention for")_" this medication,"
    56         W $C(7),$C(7) S DIR("A",1)="***"_$S($P(SER,"^",4)=1:"CRITICAL",1:"SIGNIFICANT")_"*** "_"Drug Interaction with RX #"_$P(^PSRX($P(PSOSD(STA,DRG),"^"),0),"^"),DIR("A",2)="DRUG: "_$P(DRG,"^")
    57         S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to "_$S($P(SER,"^",4)=1:"Continue? ",1:"Intervene? "),DIR("B")="Y" D ^DIR
    58         I 'Y,$P(SER,"^",4)=1 S PSORX("DFLG")=1,DGI="" K DIR,DTOUT,DIRUT,DIROUT,DUOUT
    59         I Y,$P(SER,"^",4)=1 S PSORX("INTERVENE")=1,DGI="" K DIR,DTOUT,DIRUT,DIROUT,DUOUT G CRI Q
    60         I 'Y,$P(SER,"^",4)=2 K DIR,DTOUT,DIRUT,DIROUT,DUOUT D ULRX Q
    61         I Y,$P(SER,"^",4)=2 S PSORX("INTERVENE")=2,DGI="" K DIR,DTOUT,DIRUT,DIROUT,DUOUT
    62         D ULRX
    63         Q
    64 CRI     ;process new drug interactions entered by pharmacist
    65         K DIR G:$P(PSOSD(STA,DRG),"^",9) CRITN S DIR("A",1)="",DIR("A",2)="Do you want to Process medication",DIR("A")=PSODRUG("NAME")_": ",DIR(0)="SA^1:PROCESS;0:ABORT ORDER ENTRY",DIR("B")="P"
    66         S DIR("?",1)="Enter '1' or 'P' to Activate medication",DIR("?")="      '0' or 'A' to Abort Order Entry process" D ^DIR K X1,DIR I 'Y S PSORX("DFLG")=1,DGI="" K DTOUT,DIRUT,DIROUT,DUOUT,PSORX("INTERVENE") D ULRX Q
    67         I $P(SER,"^",4)=1 D
    68         .D SIG^XUSESIG I X1="" K PSORX("INTERVENE") S PSORX("DFLG")=1 Q
    69         .S PSORX("INTERVENE")=$P(SER,"^",4)
    70         K DUOUT,DTOUT,DIRUT,DIROUT D ULRX Q
    71 CRITN   ;process multiple new drug interactions
    72         K X1,DIR S DIR("A",1)="",DIR("A",2)="Do you want to: ",DIR("A",3)=" 1.  Delete NEW medication "_PSODRUG("NAME"),DIR("A",4)=" 2.  Cancel ACTIVE New Rx #"_$P(^PSRX($P(PSOSD(STA,DRG),"^"),0),"^")_" DRUG: "_$P(DRG,"^")
    73         S DIR("A",5)=" 3.  Delete 1 and Cancel 2",DIR("A")=" 4.  Continue ?: ",DIR(0)="SA^1:NEW MEDICATION;2:ACTIVE New Rx "_$P(DRG,"^")_";3:BOTH;4:CONTINUE"
    74         S DIR("?",1)="Enter '1' or 'N' to Delete New Medication and Dispense Rx #"_$P(^PSRX(+PSOSD(STA,DRG),0),"^")
    75         S DIR("?",2)="      '2' or 'A' to Cancel Active Rx #"_$P(^PSRX(+PSOSD(STA,DRG),0),"^")_" and Dispense New Rx"
    76         S DIR("?",3)="      '3' or 'B' to Delete 1 and Cancel 2",DIR("?")="      '4' or 'C' to do nothing to either Rx" D ^DIR K DIR
    77         I Y=1 S PSORX("DFLG")=1,DGI="",PSHLDDRG=PSODRUG("IEN") D  D ULRX Q
    78         .I $G(PSORXED) D  Q
    79         ..D NOOR^PSOCAN4 I $D(DIRUT) W $C(7)," ACTION NOT TAKEN!",! S PSORX("DFLG")=1 K PSORX("INTERVENE") Q
    80         ..S DA=$P(PSOLST(ORN),"^",2) D MESS,ENQ^PSORXDL,FULL^VALM1
    81         ..K PSOSD($P(PSOLST(ORN),"^",3),PSODRUG("NAME")),DTOUT,DIROUT,DIRUT,DUOUT S:$G(PSOSD) PSOSD=PSOSD-1 S ZONE=1
    82         .S PSODRUG("IEN")=$P(^PSRX($P(PSOSD(STA,DRG),"^"),0),"^",6) D FULL^VALM1,^PSORXI
    83         .S PSODRUG("IEN")=PSHLDDRG,VALMBCK="R"
    84         .K DTOUT,DIRUT,DIROUT,DUOUT,PSHLDDRG
    85         .I $G(OR0) D
    86         ..D NOOR^PSOCAN4 I $D(DIRUT) D  Q
    87         ...W $C(7)," ACTION NOT TAKEN!",! K PSORX("INTERVENE") S PSORX("DFLG")=1
    88         ..D DC^PSOORFI2
    89         I Y=2 S (DA,PSOHOLDA)=+PSOSD(STA,DRG) D  D ULRX Q
    90         .D NOOR^PSOCAN4 I $D(DIRUT) D  Q
    91         ..W $C(7)," ACTION NOT TAKEN!",! K PSORX("INTERVENE") S PSORX("DFLG")=1
    92         .D MESS,ENQ^PSORXDL
    93         .S DA=PSOHOLDA D FULL^VALM1,EN1^PSORXI(.DA),PPL
    94         .K PSOSD(STA,DRG),DTOUT,DIROUT,DIRUT,DUOUT,PSOHOLDA
    95         .S:$G(PSOSD) PSOSD=PSOSD-1 S VALMBCK="R"
    96         I Y=3 S (DA,PSOHOLDA)=+PSOSD(STA,DRG) D  S VALMBCK="R"
    97         .D NOOR^PSOCAN4 I $D(DIRUT) D  Q
    98         ..W $C(7)," ACTION NOT TAKEN!",! K PSORX("INTERVENE") S PSORX("DFLG")=1
    99         .S:$G(PSOSD) PSOSD=PSOSD-1 S PSORX("DFLG")=1 D MESS,ENQ^PSORXDL
    100         .I $G(OR0) D DC^PSOORFI2
    101         .S DA=PSOHOLDA D FULL^VALM1,EN1^PSORXI(.DA),PPL K PSOSD(STA,DRG),PSOHOLDA
    102         .I $G(PSORXED) D
    103         ..S DA=$P(PSOLST(ORN),"^",2) D MESS,ENQ^PSORXDL,FULL^VALM1
    104         ..K PSOSD($P(PSOLST(ORN),"^",3),PSODRUG("NAME")),DTOUT,DIROUT,DIRUT,DUOUT S:$G(PSOSD) PSOSD=PSOSD-1 S ZONE=1
    105         K DTOUT,DIROUT,DIRUT,DUOUT
    106         D ULRX
    107         Q
    108 MESS    W !!,"Canceling Rx: "_$P($G(^PSRX(DA,0)),"^")_"   "_"Drug: "_$P($G(^PSDRUG($P(^PSRX(DA,0),"^",6),0)),"^"),! Q
    109 PPL     F PSOSL=0:0 S PSOSL=$O(PSORX("PSOL",PSOSL)) Q:'PSOSL  S PSOX2=PSOSL
    110         I $G(PSOX2) D
    111         .F PSOSL=0:1:PSOX2 S PSOSL=$O(PSORX("PSOL",PSOSL)) Q:'PSOSL  F ENT=1:1:$L(PSORX("PSOL",PSOSL),",") I $P(PSORX("PSOL",PSOSL),",",ENT)=$P(PSOSD(STA,DRG),"^") S PSOL(PSOSL,ENT)=""
    112         .F PSOL=0:0 S PSOL=$O(PSOL(PSOL)) Q:'PSOL  F ENT=0:0 S ENT=$O(PSOL(PSOL,ENT)) Q:'ENT  D
    113         ..I ENT=1,'$P(PSORX("PSOL",PSOL),",",2) K PSORX("PSOL",PSOL) Q
    114         ..I ENT=1,$P(PSORX("PSOL",PSOL),",",2) S PSORX("PSOL",PSOL)=$P(PSORX("PSOL",PSOL),",",2,99) Q
    115         ..S PSORX("PSOL",PSOL)=$P(PSORX("PSOL",PSOL),",",1,ENT-1)_","_$P(PSORX("PSOL",PSOL),",",ENT+1,99)
    116         K PSOX2,PSOSL,PSOL,ENT Q
    117 ULRX    ;
    118         I '$G(PSODGRLX) Q
    119         D PSOUL^PSSLOCK(PSODGRLX) K PSODGRLX
    120         Q
     1PSODGDGI ;BIR/SAB - drug drug interaction checker ;4/14/93
     2 ;;7.0;OUTPATIENT PHARMACY;**10,27,48,130,144,132,188,207,243**;DEC 1997;Build 22
     3 ;External reference to ^PS(56 supported by DBIA 2229
     4 ;External reference to ^PSDRUG supported by DBIA 221
     5 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
     6 ;External reference to DDIEX^PSNAPIS supported by DBIA 2574
     7 ;External references to ^ORRDI1 supported by DBIA 4659
     8 ;External reference ^XTMP("ORRDI" supported by DBIA 4660
     9 Q:$$DDIEX^PSNAPIS($P(PSODRUG("NDF"),"A"),$P(PSODRUG("NDF"),"A",2))
     10 N PSOICT S (CRIT,DRG,LSI,DGI,DGS,SER,SERS,STA,PSOICT)=""
     11 F  S STA=$O(PSOSD(STA)) Q:STA=""!($G(PSORX("DFLG")))  F  S DRG=$O(PSOSD(STA,DRG)) Q:DRG=""!($G(PSORX("DFLG")))  I $P(PSOSD(STA,DRG),"^",2)<10 D
     12 .Q:$P(PSOSD(STA,DRG),"^",7)']""
     13 .S NDF=$P(PSOSD(STA,DRG),"^",7)
     14 .;New logic to Loop All interactions and filter-up a critical if it exists
     15 .S IT=0,PSOICT=""
     16 .F  S IT=$O(^PS(56,"APD",NDF,PSODRUG("NDF"),IT)) Q:'IT  D
     17 ..Q:$$DDIEX^PSNAPIS($P(NDF,"A"),$P(NDF,"A",2))
     18 ..Q:$P(^PS(56,IT,0),"^",7)&($P(^PS(56,IT,0),"^",7)<DT)
     19 ..I 'PSOICT S PSOICT=IT Q
     20 ..I $P($G(^PS(56,IT,0)),"^",4)=1 S PSOICT=IT Q
     21 ..Q
     22 .I 'PSOICT Q
     23 .S IT=PSOICT
     24 .I STA="ZNONVA" S DNM=DRG W ! D NVA^PSODRDU1 K DNM,IT,PSOICT Q
     25 .D BLD Q:+$G(PSORX("DFLG"))
     26 .Q
     27 I '$D(^XUSEC("PSORPH",DUZ)),$G(DGI)]"" S:+CRIT PSONEW("STATUS")=4 W $C(7),!,"DRUG INTERACTION WITH RX #s: "_LSI,! K LSI,DRG,IT,NDF,PSOICT
     28 K IT
     29 ; CHECK FOR REMOTE DRUG INTERACTIONS
     30 I +$G(PSORX("DFLG")) Q
     31 I $T(HAVEHDR^ORRDI1)']"" Q
     32 I '$$HAVEHDR^ORRDI1 Q
     33 I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) D  Q
     34 .I $T(REMOTE^PSORX1)]"" Q
     35 .W !,"Remote data not available - Only local order checks processed." D PAUSE^PSOORRD2
     36 I $P($G(^XTMP("ORRDI","PSOO",PSODFN,0)),"^",3)<0 W !,"Remote data not available - Only local order checks processed." D PAUSE^PSOORRD2 Q
     37 I $D(^TMP($J,"DI"_PSODFN)) K ^TMP($J,"DI") M ^TMP($J,"DI")=^TMP($J,"DI"_PSODFN) D DRGINT^PSOORRD2
     38 K ^TMP($J,"DI"_PSODFN),^TMP($J,"DI")
     39 Q
     40TECH ;add tech entry to RX VERIFY file (#52.4)
     41 I +CRIT S PSODI=1,DIC="^PS(52.4,",DLAYGO=52.4,DIC(0)="L",(DINUM,X)=PSOX("IRXN"),DIC("DR")="1////"_PSODFN_";2////"_DUZ_";4///"_DT_";7///"_1_";7.1///"_SER_";7.2///"_DGI K DD,DO D FILE^DICN K DD,DO
     42 S:$G(DGS)'="" $P(^PSRX(PSOX("IRXN"),"DRI"),"^")=SERS,$P(^PSRX(PSOX("IRXN"),"DRI"),"^",2)=DGS  K PSODI,CRIT,DIC,DLAYGO,DINUM,DGI,DGS,SER,SERS Q
     43BLD I $D(^XUSEC("PSORPH",DUZ)) S PSORX("PHARM")=DUZ D PHARM Q
     44 S LSI=$P(^PSRX(+PSOSD(STA,DRG),0),"^")_"/"_$P(^PSDRUG($P(^(0),"^",6),0),"^")_","_LSI,DGI=$P(PSOSD(STA,DRG),"^")_","_DGI,SER=IT_","_SER I $P(PSOSD(STA,DRG),"^",9),$P(^PS(56,IT,0),"^",4)=1 S $P(^PSRX(+PSOSD(STA,DRG),"STA"),"^")=4
     45 I $P(^PS(56,IT,0),"^",4)=2 S SERS=IT_","_SERS,DGS=$P(PSOSD(STA,DRG),"^")_","_DGS
     46 S:$P(^PS(56,IT,0),"^",4)=1 CRIT=1 Q
     47PHARM ;pharmacist verification of drug interaction
     48 D PSOL^PSSLOCK($P(PSOSD(STA,DRG),"^")) I '$G(PSOMSG) D  K PSOMSG S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR S PSORX("DFLG")=1 Q
     49 .I $P($G(PSOMSG),"^",2)'="" W !!,$P(PSOMSG,"^",2) D  Q
     50 ..W !,"Rx: "_$P($G(^PSRX($P(PSOSD(STA,DRG),"^"),0)),"^")_"    Drug: "_$P($G(^PSDRUG(+$P($G(^(0)),"^",6),0)),"^")
     51 ..W !,"which interacts with the drug you are entering!",!
     52 .W !!,"Another person is editing Rx "_$P($G(^PSRX($P(PSOSD(STA,DRG),"^"),0)),"^")_",",!,"which interacts with the drug you are entering!",!
     53 S PSODGRLX=$P(PSOSD(STA,DRG),"^")
     54 S SER=^PS(56,IT,0),DIR("?",1)="Answer 'YES' if you DO want to "_$S($P(SER,"^",4)=1:"continue processing",1:"enter an intervention for")_" this medication,"
     55 S DIR("?")="       'NO' if you DON'T want to "_$S($P(SER,"^",4)=1:"continue processing",1:"enter an intervention for")_" this medication,"
     56 W $C(7),$C(7) S DIR("A",1)="***"_$S($P(SER,"^",4)=1:"CRITICAL",1:"SIGNIFICANT")_"*** "_"Drug Interaction with RX #"_$P(^PSRX($P(PSOSD(STA,DRG),"^"),0),"^"),DIR("A",2)="DRUG: "_$P(DRG,"^")
     57 S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to "_$S($P(SER,"^",4)=1:"Continue? ",1:"Intervene? "),DIR("B")="Y" D ^DIR
     58 I 'Y,$P(SER,"^",4)=1 S PSORX("DFLG")=1,DGI="" K DIR,DTOUT,DIRUT,DIROUT,DUOUT
     59 I Y,$P(SER,"^",4)=1 S PSORX("INTERVENE")=1,DGI="" K DIR,DTOUT,DIRUT,DIROUT,DUOUT G CRI Q
     60 I 'Y,$P(SER,"^",4)=2 K DIR,DTOUT,DIRUT,DIROUT,DUOUT D ULRX Q
     61 I Y,$P(SER,"^",4)=2 S PSORX("INTERVENE")=2,DGI="" K DIR,DTOUT,DIRUT,DIROUT,DUOUT
     62 D ULRX
     63 Q
     64CRI ;process new drug interactions entered by pharmacist
     65 K DIR G:$P(PSOSD(STA,DRG),"^",9) CRITN S DIR("A",1)="",DIR("A",2)="Do you want to Process medication",DIR("A")=PSODRUG("NAME")_": ",DIR(0)="SA^1:PROCESS;0:ABORT ORDER ENTRY",DIR("B")="P"
     66 S DIR("?",1)="Enter '1' or 'P' to Activate medication",DIR("?")="      '0' or 'A' to Abort Order Entry process" D ^DIR K X1,DIR I 'Y S PSORX("DFLG")=1,DGI="" K DTOUT,DIRUT,DIROUT,DUOUT,PSORX("INTERVENE") D ULRX Q
     67 I $P(SER,"^",4)=1 D
     68 .D SIG^XUSESIG I X1="" K PSORX("INTERVENE") S PSORX("DFLG")=1 Q
     69 .S PSORX("INTERVENE")=$P(SER,"^",4)
     70 K DUOUT,DTOUT,DIRUT,DIROUT D ULRX Q
     71CRITN ;process multiple new drug interactions
     72 K X1,DIR S DIR("A",1)="",DIR("A",2)="Do you want to: ",DIR("A",3)=" 1.  Delete NEW medication "_PSODRUG("NAME"),DIR("A",4)=" 2.  Cancel ACTIVE New Rx #"_$P(^PSRX($P(PSOSD(STA,DRG),"^"),0),"^")_" DRUG: "_$P(DRG,"^")
     73 S DIR("A",5)=" 3.  Delete 1 and Cancel 2",DIR("A")=" 4.  Continue ?: ",DIR(0)="SA^1:NEW MEDICATION;2:ACTIVE New Rx "_$P(DRG,"^")_";3:BOTH;4:CONTINUE"
     74 S DIR("?",1)="Enter '1' or 'N' to Delete New Medication and Dispense Rx #"_$P(^PSRX(+PSOSD(STA,DRG),0),"^")
     75 S DIR("?",2)="      '2' or 'A' to Cancel Active Rx #"_$P(^PSRX(+PSOSD(STA,DRG),0),"^")_" and Dispense New Rx"
     76 S DIR("?",3)="      '3' or 'B' to Delete 1 and Cancel 2",DIR("?")="      '4' or 'C' to do nothing to either Rx" D ^DIR K DIR
     77 I Y=1 S PSORX("DFLG")=1,DGI="",PSHLDDRG=PSODRUG("IEN") D  D ULRX Q
     78 .I $G(PSORXED) D  Q
     79 ..D NOOR^PSOCAN4 I $D(DIRUT) W $C(7)," ACTION NOT TAKEN!",! S PSORX("DFLG")=1 K PSORX("INTERVENE") Q
     80 ..S DA=$P(PSOLST(ORN),"^",2) D MESS,ENQ^PSORXDL,FULL^VALM1
     81 ..K PSOSD($P(PSOLST(ORN),"^",3),PSODRUG("NAME")),DTOUT,DIROUT,DIRUT,DUOUT S:$G(PSOSD) PSOSD=PSOSD-1 S ZONE=1
     82 .S PSODRUG("IEN")=$P(^PSRX($P(PSOSD(STA,DRG),"^"),0),"^",6) D FULL^VALM1,^PSORXI
     83 .S PSODRUG("IEN")=PSHLDDRG,VALMBCK="R"
     84 .K DTOUT,DIRUT,DIROUT,DUOUT,PSHLDDRG
     85 .I $G(OR0) D
     86 ..D NOOR^PSOCAN4 I $D(DIRUT) D  Q
     87 ...W $C(7)," ACTION NOT TAKEN!",! K PSORX("INTERVENE") S PSORX("DFLG")=1
     88 ..D DC^PSOORFI2
     89 I Y=2 S (DA,PSOHOLDA)=+PSOSD(STA,DRG) D  D ULRX Q
     90 .D NOOR^PSOCAN4 I $D(DIRUT) D  Q
     91 ..W $C(7)," ACTION NOT TAKEN!",! K PSORX("INTERVENE") S PSORX("DFLG")=1
     92 .D MESS,ENQ^PSORXDL
     93 .S DA=PSOHOLDA D FULL^VALM1,EN1^PSORXI(.DA),PPL
     94 .K PSOSD(STA,DRG),DTOUT,DIROUT,DIRUT,DUOUT,PSOHOLDA
     95 .S:$G(PSOSD) PSOSD=PSOSD-1 S VALMBCK="R"
     96 I Y=3 S (DA,PSOHOLDA)=+PSOSD(STA,DRG) D  S VALMBCK="R"
     97 .D NOOR^PSOCAN4 I $D(DIRUT) D  Q
     98 ..W $C(7)," ACTION NOT TAKEN!",! K PSORX("INTERVENE") S PSORX("DFLG")=1
     99 .S:$G(PSOSD) PSOSD=PSOSD-1 S PSORX("DFLG")=1 D MESS,ENQ^PSORXDL
     100 .I $G(OR0) D DC^PSOORFI2
     101 .S DA=PSOHOLDA D FULL^VALM1,EN1^PSORXI(.DA),PPL K PSOSD(STA,DRG),PSOHOLDA
     102 .I $G(PSORXED) D
     103 ..S DA=$P(PSOLST(ORN),"^",2) D MESS,ENQ^PSORXDL,FULL^VALM1
     104 ..K PSOSD($P(PSOLST(ORN),"^",3),PSODRUG("NAME")),DTOUT,DIROUT,DIRUT,DUOUT S:$G(PSOSD) PSOSD=PSOSD-1 S ZONE=1
     105 K DTOUT,DIROUT,DIRUT,DUOUT
     106 D ULRX
     107 Q
     108MESS W !!,"Canceling Rx: "_$P($G(^PSRX(DA,0)),"^")_"   "_"Drug: "_$P($G(^PSDRUG($P(^PSRX(DA,0),"^",6),0)),"^"),! Q
     109PPL F PSOSL=0:0 S PSOSL=$O(PSORX("PSOL",PSOSL)) Q:'PSOSL  S PSOX2=PSOSL
     110 I $G(PSOX2) D
     111 .F PSOSL=0:1:PSOX2 S PSOSL=$O(PSORX("PSOL",PSOSL)) Q:'PSOSL  F ENT=1:1:$L(PSORX("PSOL",PSOSL),",") I $P(PSORX("PSOL",PSOSL),",",ENT)=$P(PSOSD(STA,DRG),"^") S PSOL(PSOSL,ENT)=""
     112 .F PSOL=0:0 S PSOL=$O(PSOL(PSOL)) Q:'PSOL  F ENT=0:0 S ENT=$O(PSOL(PSOL,ENT)) Q:'ENT  D
     113 ..I ENT=1,'$P(PSORX("PSOL",PSOL),",",2) K PSORX("PSOL",PSOL) Q
     114 ..I ENT=1,$P(PSORX("PSOL",PSOL),",",2) S PSORX("PSOL",PSOL)=$P(PSORX("PSOL",PSOL),",",2,99) Q
     115 ..S PSORX("PSOL",PSOL)=$P(PSORX("PSOL",PSOL),",",1,ENT-1)_","_$P(PSORX("PSOL",PSOL),",",ENT+1,99)
     116 K PSOX2,PSOSL,PSOL,ENT Q
     117ULRX ;
     118 I '$G(PSODGRLX) Q
     119 D PSOUL^PSSLOCK(PSODGRLX) K PSODGRLX
     120 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIAG.m

    r613 r623  
    1 PSODIAG ;BIR/LE - Diagnosis code prompts ;02/27/04
    2         ;;7.0;OUTPATIENT PHARMACY;**143,219,239,268,225**;DEC 1997;Build 29
    3         ;Ext ref to ^XUSEC sup by DBIA 10076
    4         ;Ext ref to $$ICDDX^ICDCODE sup DBIA 3990
    5         ;Ext ref to $$STATCHK^ICDAPIU sup DBIA 3991
    6 EN      ;
    7         ;don't ask icd's if user doesn't hold provider key
    8         Q:$T(CIDC^IBBAPI)']""
    9         Q:'$D(^XUSEC("PROVIDER",DUZ))
    10         N PSODDFN S PSODDFN=$S($D(DFN):DFN,$D(PSODFN):PSODFN,1:"")  ;need to do this since PU patient update deletes DFN and in case some other function does
    11         I PSODDFN'="" I '$$CIDC^IBBAPI(PSODDFN) S:(+$G(PSONEW("DFLG")))&(+$G(PSOEDIT)=1)&('$D(DA)) PSONEW("DFLG")=0 Q  ;is CIDC activated; does patient have insurance
    12         ;new variables and initialize variables based on CPRS or backdoor order.
    13         N DX,POP,I,J,X,Y,Z,OLD,OLDI,SOLDI,NEW,TNEW,RAR,CPRS,FILDAT,STATCHK,STATCHK2
    14         I '$G(PSOX("IRXN")) N PSOX S:$G(PSORXED("IRXN")) PSOX("IRXN")=PSORXED("IRXN")
    15         K DIC
    16         S CPRS=0
    17         I $G(PSORXED) S RAR="PSORXED",@RAR@("DFLG")=0,PSORXED("FLD",39.3)=""
    18         E  S RAR="PSONEW",@RAR@("DFLG")=0 I $G(ORD) D
    19         . I $D(^PS(52.41,ORD)) S CPRS=1 M PSONEW("ICD")=PSORXED("ICD") K PSORXED("ICD"),PSORXED("FLD",39.3)
    20         ;
    21         S FILDAT="",FILDAT=DT I $G(PSOX("IRXN")) S FILDAT=$$GET1^DIQ(52,PSOX("IRXN")_",","22","I")
    22         ;display any previously entered ICD's
    23         W !!,"Previously entered ICD-9 diagnosis codes: "
    24         I 'CPRS D  ;&(RAR="PSORXED"!(RAR="PSONEW")) D
    25         . I $D(PSOX("IRXN")) I '$D(PSORXED("ICD")) I $D(^PSRX(PSOX("IRXN"),"ICD")) F I=1:1:8 Q:'$D(^PSRX(PSOX("IRXN"),"ICD",I,0))  D
    26         .. S OLD(I)=$$GET1^DIQ(52.052311,I_","_PSOX("IRXN")_",",".01")
    27         .. S OLDI(I)=$$GET1^DIQ(52.052311,I_","_PSOX("IRXN")_",",".01","I")
    28         . I ($D(@RAR@("ICD"))&('$D(OLD)))!($G(PSOCOPY)) D
    29         .. F I=1:1:8 Q:'$D(@RAR@("ICD",I))  I @RAR@("ICD",I)'="" S OLDI(I)=@RAR@("ICD",I) D
    30         ... S OLD(I)=$P(^ICD9(OLDI(I),0),"^",1)
    31         ... S J=I-1 I I=1 W OLD(I) Q
    32         . F I=1:1:8 Q:'$D(OLD(I))  D WRITE
    33         E  I CPRS D
    34         . I '$G(PSONEW("ICD")) F I=1:1:8 Q:'$D(^PS(52.41,ORD,"ICD",I,0))  D
    35         .. S OLD(I)=$$GET1^DIQ(52.41311,I_","_ORD_",",".01")
    36         .. S OLDI(I)=$$GET1^DIQ(52.41311,I_","_ORD_",",".01","I")
    37         . I $D(PSONEW("ICD")) K OLD,OLDI D
    38         .. F I=1:1:8 Q:'$D(PSONEW("ICD",I))  S OLDI(I)=PSONEW("ICD",I) D
    39         ... S OLD(I)=$P(^ICD9(OLDI(I),0),"^",1)
    40         . F I=1:1:8 Q:'$D(OLD(I))  D WRITE
    41         M SOLDI=OLDI
    42         ;
    43 EN2     ;ask for ICD's or display previously entered ones for editing
    44         ;note: because ICD's are not longer required, could not use standard
    45         ;       FileMan calls everywhere because of need to control deleted
    46         ;       entries and cross-references.
    47         W !
    48         F I=1:1:8 D  Q:+$G(Y)=-1!(@RAR@("DFLG"))
    49         . I '$G(PSORXED)&('$G(CPRS)) S RAR="PSONEW"
    50         .K DIC S DIC("A")=$S(I=1:"Select Primary ICD-9 Code: ",1:"Select Secondary ICD-9 Code: ")
    51         . I $D(OLD(I)),(OLD(I)'="") S DIC("B")=OLD(I)
    52         . S X="" W !,DIC("A") D  R X:60   ;did this so that I have control of the deletes
    53         .. I $D(OLD(I)),(OLD(I)'="") W OLD(I)_"// "
    54         . I $D(OLD(I)) S:X="" X=OLD(I)
    55         . I X="" S Y=-1 Q
    56         . I X["?" W !,"Enter a valid ICD-9 diagnosis code." S I=1-1 Q
    57         . I X="@" D DELETE Q
    58         . I X="^" S Y=-1 Q
    59         . K DIC S DIC=80,DIC(0)="EMZQ"
    60         . ;S DIC("S")="I $P($$ICDDX^ICDCODE(Y,FILDAT),U,10)&($P($$ICDDX^ICDCODE(Y,FILDAT),U,17)>$P($$ICDDX^ICDCODE(Y,FILDAT),U,12))"
    61         . S DIC("S")="I $$STATCHK^PSODIAG(Y,FILDAT)"
    62         . K DTOUT,DUOUT D ^DIC K DIC
    63         . I X="^" S I=I-1,Y="" Q
    64         . I $G(DUOUT)!($G(DTOUT)) S Y=-1,X="^" Q
    65         . I +Y=-1&(X'=""!(X'="^")) I $D(^ICD9("BA",X)) S I=I-1,(X,Y)="" Q  ;user said No to are you sure ?.
    66         . I Y=-1&(X?1A.A) S I=I-1,Y="" Q  ;user said not to Yes? question.
    67         . I Y'=-1 D  I STATCHK2=1 S I=I-1,Y="" Q
    68         .. S (STATCHK,STATCHK2)="",STATCHK=$$STATCHK^ICDAPIU($P(Y,U,2),FILDAT) D
    69         ... I $P(STATCHK,"^",2)=-1 W !!,"Invalid ICD-9 diagnosis code.  Please choose another.",! S STATCHK2=1 Q
    70         ... I +STATCHK=0 W !!,"Inactivated ICD-9 Diagnosis Code.  Please choose another.",! S STATCHK2=1 Q
    71         . I +Y=-1 S I=I-1,Y="" W !!,"Invalid or inactivated ICD-9 diagnosis code.  Please choose another.",! Q
    72         . S (POP,J)=0 F J=1:1:I D
    73         ..I $G(DX(J))=+Y W $C(7),!," Duplicate entry.  Please select a different ICD-9 diagnosis code.",! S I=I-1,(Y,X)="",POP=1
    74         . Q:POP
    75         . S NEW("ICD",I)=$P(Y,U,1),DX(I)=+Y
    76         ;
    77         ;resequence entered ICD's and removed deleted ones from file
    78         ;I X="^"&(RAR="PSONEW")&('CPRS) S @RAR@("DFLG")=0 K DUOUT,DTOUT,Y,X Q
    79         ;
    80         I '$D(NEW("ICD")) I $D(OLDI) M NEW("ICD")=OLDI ;if user ^ out on first icd
    81         K PSOICDD I '$D(NEW("ICD"))&($G(PSOCOPY)) S PSOICDD=1
    82         ;
    83         S J=0 F I=1:1:8 Q:'$D(NEW("ICD",I))  I NEW("ICD",I)'="" S J=J+1,@RAR@("ICD",J)=NEW("ICD",I)
    84         S TNEW=I
    85         I X="^" D  ;if up arrow out, set all icd's past ^ point into array
    86         . ;S Y=TNEW-1 F  S Y=$O(OLDI(Y)) Q:Y=""  S J=J+1,@RAR@("ICD",J)=OLDI(Y)
    87         . K @RAR@("ICD") S Y="" F  S Y=$O(SOLDI(Y)) Q:Y=""  S @RAR@("ICD",Y)=SOLDI(Y)
    88         . K PSORXED("FLD",39.3)  ;7/12/04
    89         I $G(CPRS) K PSORX("ICD") M PSORXED("ICD")=@RAR@("ICD"),PSORX("ICD")=@RAR@("ICD")
    90         I $G(PSORXED) K PSORX("ICD") M PSORX("ICD")=@RAR@("ICD")
    91         I '$D(@RAR@("ICD"))&(CPRS) S PSONEW("IDFLG")=1 ;user deleted all in finish/complete order
    92         Q:(RAR="PSONEW")
    93         I '$D(@RAR@("ICD"))&('CPRS)&($D(^PSRX(PSOX("IRXN"),"ICD",1,0))) S PSORXED("IDFLG")=1  ;user deleted all
    94         Q
    95         ;
    96         ;called from above to write previously entered ICD's to screen.
    97 WRITE   S J=I-1 I I=1 W !,?10,"Primary: ",OLD(I),?30,$P($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4) Q
    98 WRITE2  I I=2 W !,?3,"Secondaries #"_J_": ",OLD(I),?30,$P($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4) Q
    99         I I>2 W !,?15,"#"_J_": ",OLD(I),?30,$P($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4)
    100         Q
    101 STATCHK(ICDIEN,FILDAT)  ;called from above to check active/inactive date during FileMan call.
    102         N X S X=""
    103         S ICDIEN=$P(^ICD9(ICDIEN,0),"^",1) S X=$$STATCHK^ICDAPIU(ICDIEN,FILDAT)
    104         Q +X
    105 DELETE  ;called from above to verify delete with user and to delete said entries
    106         W !,"SURE YOU WANT TO DELETE? " S X="" R X:30 S X=$TR(X,"yn","YN")
    107         I X'="Y"&(X'="N") W !,"Enter Y or N" G DELETE
    108         I X="N" S I=I-1 Q
    109         F J=I:1:8 Q:'$D(OLDI(J))  D
    110         . I $D(OLDI(J+1)) S OLDI(J)=OLDI(J+1),OLD(J)=OLD(J+1) D
    111         .. I CPRS&($D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=PSONEW("ICD",J+1)
    112         .. E  I CPRS&('$D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=OLDI(J+1)
    113         .. I $G(PSOCOPY) D
    114         ... I ($D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=PSONEW("ICD",J+1)
    115         ... I ($D(PSORXED("ICD",J+1))) S PSORXED("ICD",J)=PSORXED("ICD",J+1)
    116         . E  K OLD(J),OLDI(J),PSONEW("ICD",J),PSORXED("ICD",J)
    117         . ;I CPRS!($G(PSOCOPY)) K PSONEW("ICD",J),PSORXED("ICD",J)
    118         S I=I-1,(X,Y)=""
    119         Q
    120         ;
    121 ICD     ;called from PSON52 cause PSON52'S too large.  Stores ICD info for new Rx's (CPRS and backdoor) using variables from copy function and new order functions.
    122         N D,DDATA,ICD,II
    123         I $G(PSOCOPY)&('$D(PSOX("ICD")))&('$G(PSOICDD)) D
    124         . S D=0 F D=1:1 Q:'$D(PSOX("ICD",D))
    125         . F D=D:1:8 K ^PSRX(PSOX("IRXN"),"ICD",D,0)  ;remove any icd's del
    126         . I $D(^PSRX(PSOX("OIRXN"),"ICD",0)) F D=1:1:8 Q:'$D(^PSRX(PSOX("OIRXN"),"ICD",D,0))  S PSOX("ICD",D)=$P(^PSRX(PSOX("OIRXN"),"ICD",D,0),U,1)
    127         I $G(ORD) I $D(^PS(52.41,ORD,0))&($D(PSORX("ICD"))) M PSOX("ICD")=PSONEW("ICD")
    128         I $D(PSOX("ICD")) F D=1:1:8 Q:'$D(PSOX("ICD",D))  S ICD=$G(PSOX("ICD",D)) D
    129         . S DDATA=ICD_"^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$S(PSOSCP>49:$G(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$G(PSOANSQ("SC")),1:"")_"^"_$G(PSOANSQ("PGW"))_"^"_$G(PSOANSQ("MST"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV"))
    130         . S DDATA=DDATA_"^"_$G(PSOANSQ("SHAD"))
    131         . I $P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1 I PSOSCP<50&($D(PSOANSQ("SC>50"))) S $P(DDATA,"^",4)=PSOANSQ("SC>50")  ;for times when sc has no % defined.
    132         . S ^PSRX(PSOX("IRXN"),"ICD",D,0)=DDATA,II=D
    133         E  S D=1 D
    134         . S DDATA="^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$S(PSOSCP>49:$G(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$G(PSOANSQ("SC")),1:"")
    135         . S DDATA=DDATA_"^"_$G(PSOANSQ("PGW"))_"^"_$G(PSOANSQ("MST"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV"))_"^"_$G(PSOANSQ("SHAD"))
    136         . S ^PSRX(PSOX("IRXN"),"ICD",D,0)=DDATA,II=D
    137         . I $P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1 I PSOSCP<50&($D(PSOANSQ("SC>50"))) S $P(^PSRX(PSOX("IRXN"),"ICD",D,0),"^",4)=PSOANSQ("SC>50")
    138         S ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311P^"_II_"^"_II
    139         K PSOX("ICD"),PSORXED("ICD"),PSONEW("ICD"),PSORX("ICD")
    140         Q
    141         ;
    142 UPDATE  ;was in PSOORED6; now called from PSOORED6; removes deletes for edits and stores data.
    143         ;
    144         N TNEW,DA,DIK,SCEI,I,II
    145         S DA=PSORXED("IRXN")
    146         I '$D(PSORXED("ICD"))&($G(PSORXED("IDFLG"))) D  K PSORXED("IDFLG") Q
    147         . I $D(^PSRX(PSORXED("IRXN"),"ICD",1,0)) D
    148         .. S TNEW=2 K ^PSRX(PSORXED("IRXN"),"ICD","B") S $P(^PSRX(PSORXED("IRXN"),"ICD",1,0),U,1)=""
    149         .. F I=TNEW:1:8 Q:'$D(^PSRX(PSORXED("IRXN"),"ICD",I,0))  S DIK="^PSRX("_PSORXED("IRXN")_","_$C(34)_"ICD"_$C(34)_",",DA=I,DA(1)=PSORXED("IRXN") D ^DIK K DA,DIK
    150         ;
    151         I $D(PSORXED("ICD")) D
    152         . S SCEI=$G(^PSRX(DA,"ICD",1,0)),$P(SCEI,"^")=""
    153         . K ^PSRX(DA,"ICD")
    154         . F I=1:1:8 Q:'$D(PSORXED("ICD",I))  S $P(SCEI,"^")=PSORXED("ICD",I),^PSRX(DA,"ICD",I,0)=SCEI,^PSRX(DA,"ICD","B",$P(SCEI,"^"),I)="",II=I
    155         . S ^PSRX(DA,"ICD",0)="^52.052311P^"_II_U_II
    156         Q
    157         ;
    158 CSET    ;Called from PSOHLNEW due to it's routine size.  Requires PSOICD & PENDING variable.  Sets ICD node for orders passed from CPRS.
    159         N EE,EEE
    160         S (EE,EEE)=0 F  S EE=$O(PSOICD(EE)) Q:EE=""  D
    161         .S EEE=EEE+1,^PS(52.41,PENDING,"ICD",EEE,0)=PSOICD(EE) S:$P(PSOICD(EE),"^")'="" ^PS(52.41,PENDING,"ICD","B",$P(PSOICD(EE),"^"),EEE)=""
    162         .S ^PS(52.41,PENDING,"ICD",0)="^52.41311PA"_U_EEE_U_EEE
    163         Q
     1PSODIAG ;BIR/LE - Diagnosis code prompts ;02/27/04
     2 ;;7.0;OUTPATIENT PHARMACY;**143,219,239,268**;DEC 1997;Build 9
     3 ;Ext ref to ^XUSEC sup by DBIA 10076
     4 ;Ext ref to $$ICDDX^ICDCODE sup DBIA 3990
     5 ;Ext ref to $$STATCHK^ICDAPIU sup DBIA 3991
     6EN ;
     7 ;don't ask icd's if user doesn't hold provider key
     8 Q:$T(CIDC^IBBAPI)']""
     9 Q:'$D(^XUSEC("PROVIDER",DUZ))
     10 N PSODDFN S PSODDFN=$S($D(DFN):DFN,$D(PSODFN):PSODFN,1:"")  ;need to do this since PU patient update deletes DFN and in case some other function does
     11 I PSODDFN'="" I '$$CIDC^IBBAPI(PSODDFN) S:(+$G(PSONEW("DFLG")))&(+$G(PSOEDIT)=1)&('$D(DA)) PSONEW("DFLG")=0 Q  ;is CIDC activated; does patient have insurance
     12 ;new variables and initialize variables based on CPRS or backdoor order.
     13 N DX,POP,I,J,X,Y,Z,OLD,OLDI,SOLDI,NEW,TNEW,RAR,CPRS,FILDAT,STATCHK,STATCHK2
     14 I '$G(PSOX("IRXN")) N PSOX S:$G(PSORXED("IRXN")) PSOX("IRXN")=PSORXED("IRXN")
     15 K DIC
     16 S CPRS=0
     17 I $G(PSORXED) S RAR="PSORXED",@RAR@("DFLG")=0,PSORXED("FLD",39.3)=""
     18 E  S RAR="PSONEW",@RAR@("DFLG")=0 I $G(ORD) D
     19 . I $D(^PS(52.41,ORD)) S CPRS=1 M PSONEW("ICD")=PSORXED("ICD") K PSORXED("ICD"),PSORXED("FLD",39.3)
     20 ;
     21 S FILDAT="",FILDAT=DT I $G(PSOX("IRXN")) S FILDAT=$$GET1^DIQ(52,PSOX("IRXN")_",","22","I")
     22 ;display any previously entered ICD's
     23 W !!,"Previously entered ICD-9 diagnosis codes: "
     24 I 'CPRS D  ;&(RAR="PSORXED"!(RAR="PSONEW")) D
     25 . I $D(PSOX("IRXN")) I '$D(PSORXED("ICD")) I $D(^PSRX(PSOX("IRXN"),"ICD")) F I=1:1:8 Q:'$D(^PSRX(PSOX("IRXN"),"ICD",I,0))  D
     26 .. S OLD(I)=$$GET1^DIQ(52.052311,I_","_PSOX("IRXN")_",",".01")
     27 .. S OLDI(I)=$$GET1^DIQ(52.052311,I_","_PSOX("IRXN")_",",".01","I")
     28 . I ($D(@RAR@("ICD"))&('$D(OLD)))!($G(PSOCOPY)) D
     29 .. F I=1:1:8 Q:'$D(@RAR@("ICD",I))  I @RAR@("ICD",I)'="" S OLDI(I)=@RAR@("ICD",I) D
     30 ... S OLD(I)=$P(^ICD9(OLDI(I),0),"^",1)
     31 ... S J=I-1 I I=1 W OLD(I) Q
     32 . F I=1:1:8 Q:'$D(OLD(I))  D WRITE
     33 E  I CPRS D
     34 . I '$G(PSONEW("ICD")) F I=1:1:8 Q:'$D(^PS(52.41,ORD,"ICD",I,0))  D
     35 .. S OLD(I)=$$GET1^DIQ(52.41311,I_","_ORD_",",".01")
     36 .. S OLDI(I)=$$GET1^DIQ(52.41311,I_","_ORD_",",".01","I")
     37 . I $D(PSONEW("ICD")) K OLD,OLDI D
     38 .. F I=1:1:8 Q:'$D(PSONEW("ICD",I))  S OLDI(I)=PSONEW("ICD",I) D
     39 ... S OLD(I)=$P(^ICD9(OLDI(I),0),"^",1)
     40 . F I=1:1:8 Q:'$D(OLD(I))  D WRITE
     41 M SOLDI=OLDI
     42 ;
     43EN2 ;ask for ICD's or display previously entered ones for editing
     44 ;note: because ICD's are not longer required, could not use standard
     45 ;       FileMan calls everywhere because of need to control deleted
     46 ;       entries and cross-references.
     47 W !
     48 F I=1:1:8 D  Q:+$G(Y)=-1!(@RAR@("DFLG"))
     49 . I '$G(PSORXED)&('$G(CPRS)) S RAR="PSONEW"
     50 .K DIC S DIC("A")=$S(I=1:"Select Primary ICD-9 Code: ",1:"Select Secondary ICD-9 Code: ")
     51 . I $D(OLD(I)),(OLD(I)'="") S DIC("B")=OLD(I)
     52 . S X="" W !,DIC("A") D  R X:60   ;did this so that I have control of the deletes
     53 .. I $D(OLD(I)),(OLD(I)'="") W OLD(I)_"// "
     54 . I $D(OLD(I)) S:X="" X=OLD(I)
     55 . I X="" S Y=-1 Q
     56 . I X["?" W !,"Enter a valid ICD-9 diagnosis code." S I=1-1 Q
     57 . I X="@" D DELETE Q
     58 . I X="^" S Y=-1 Q
     59 . K DIC S DIC=80,DIC(0)="EMZQ"
     60 . ;S DIC("S")="I $P($$ICDDX^ICDCODE(Y,FILDAT),U,10)&($P($$ICDDX^ICDCODE(Y,FILDAT),U,17)>$P($$ICDDX^ICDCODE(Y,FILDAT),U,12))"
     61 . S DIC("S")="I $$STATCHK^PSODIAG(Y,FILDAT)"
     62 . K DTOUT,DUOUT D ^DIC K DIC
     63 . I X="^" S I=I-1,Y="" Q
     64 . I $G(DUOUT)!($G(DTOUT)) S Y=-1,X="^" Q
     65 . I +Y=-1&(X'=""!(X'="^")) I $D(^ICD9("BA",X)) S I=I-1,(X,Y)="" Q  ;user said No to are you sure ?.
     66 . I Y=-1&(X?1A.A) S I=I-1,Y="" Q  ;user said not to Yes? question.
     67 . I Y'=-1 D  I STATCHK2=1 S I=I-1,Y="" Q
     68 .. S (STATCHK,STATCHK2)="",STATCHK=$$STATCHK^ICDAPIU($P(Y,U,2),FILDAT) D
     69 ... I $P(STATCHK,"^",2)=-1 W !!,"Invalid ICD-9 diagnosis code.  Please choose another.",! S STATCHK2=1 Q
     70 ... I +STATCHK=0 W !!,"Inactivated ICD-9 Diagnosis Code.  Please choose another.",! S STATCHK2=1 Q
     71 . I +Y=-1 S I=I-1,Y="" W !!,"Invalid or inactivated ICD-9 diagnosis code.  Please choose another.",! Q
     72 . S (POP,J)=0 F J=1:1:I D
     73 ..I $G(DX(J))=+Y W $C(7),!," Duplicate entry.  Please select a different ICD-9 diagnosis code.",! S I=I-1,(Y,X)="",POP=1
     74 . Q:POP
     75 . S NEW("ICD",I)=$P(Y,U,1),DX(I)=+Y
     76 ;
     77 ;resequence entered ICD's and removed deleted ones from file
     78 ;I X="^"&(RAR="PSONEW")&('CPRS) S @RAR@("DFLG")=0 K DUOUT,DTOUT,Y,X Q
     79 ;
     80 I '$D(NEW("ICD")) I $D(OLDI) M NEW("ICD")=OLDI ;if user ^ out on first icd
     81 K PSOICDD I '$D(NEW("ICD"))&($G(PSOCOPY)) S PSOICDD=1
     82 ;
     83 S J=0 F I=1:1:8 Q:'$D(NEW("ICD",I))  I NEW("ICD",I)'="" S J=J+1,@RAR@("ICD",J)=NEW("ICD",I)
     84 S TNEW=I
     85 I X="^" D  ;if up arrow out, set all icd's past ^ point into array
     86 . ;S Y=TNEW-1 F  S Y=$O(OLDI(Y)) Q:Y=""  S J=J+1,@RAR@("ICD",J)=OLDI(Y)
     87 . K @RAR@("ICD") S Y="" F  S Y=$O(SOLDI(Y)) Q:Y=""  S @RAR@("ICD",Y)=SOLDI(Y)
     88 . K PSORXED("FLD",39.3)  ;7/12/04
     89 I $G(CPRS) K PSORX("ICD") M PSORXED("ICD")=@RAR@("ICD"),PSORX("ICD")=@RAR@("ICD")
     90 I $G(PSORXED) K PSORX("ICD") M PSORX("ICD")=@RAR@("ICD")
     91 I '$D(@RAR@("ICD"))&(CPRS) S PSONEW("IDFLG")=1 ;user deleted all in finish/complete order
     92 Q:(RAR="PSONEW")
     93 I '$D(@RAR@("ICD"))&('CPRS)&($D(^PSRX(PSOX("IRXN"),"ICD",1,0))) S PSORXED("IDFLG")=1  ;user deleted all
     94 Q
     95 ;
     96 ;called from above to write previously entered ICD's to screen.
     97WRITE S J=I-1 I I=1 W !,?10,"Primary: ",OLD(I),?30,$P($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4) Q
     98WRITE2 I I=2 W !,?3,"Secondaries #"_J_": ",OLD(I),?30,$P($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4) Q
     99 I I>2 W !,?15,"#"_J_": ",OLD(I),?30,$P($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4)
     100 Q
     101STATCHK(ICDIEN,FILDAT) ;called from above to check active/inactive date during FileMan call.
     102 N X S X=""
     103 S ICDIEN=$P(^ICD9(ICDIEN,0),"^",1) S X=$$STATCHK^ICDAPIU(ICDIEN,FILDAT)
     104 Q +X
     105DELETE ;called from above to verify delete with user and to delete said entries
     106 W !,"SURE YOU WANT TO DELETE? " S X="" R X:30 S X=$TR(X,"yn","YN")
     107 I X'="Y"&(X'="N") W !,"Enter Y or N" G DELETE
     108 I X="N" S I=I-1 Q
     109 F J=I:1:8 Q:'$D(OLDI(J))  D
     110 . I $D(OLDI(J+1)) S OLDI(J)=OLDI(J+1),OLD(J)=OLD(J+1) D
     111 .. I CPRS&($D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=PSONEW("ICD",J+1)
     112 .. E  I CPRS&('$D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=OLDI(J+1)
     113 .. I $G(PSOCOPY) D
     114 ... I ($D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=PSONEW("ICD",J+1)
     115 ... I ($D(PSORXED("ICD",J+1))) S PSORXED("ICD",J)=PSORXED("ICD",J+1)
     116 . E  K OLD(J),OLDI(J),PSONEW("ICD",J),PSORXED("ICD",J)
     117 . ;I CPRS!($G(PSOCOPY)) K PSONEW("ICD",J),PSORXED("ICD",J)
     118 S I=I-1,(X,Y)=""
     119 Q
     120 ;
     121ICD ;called from PSON52 cause PSON52'S too large.  Stores ICD info for new Rx's (CPRS and backdoor) using variables from copy function and new order functions.
     122 N D,DDATA,ICD,II
     123 I $G(PSOCOPY)&('$D(PSOX("ICD")))&('$G(PSOICDD)) D
     124 . S D=0 F D=1:1 Q:'$D(PSOX("ICD",D))
     125 . F D=D:1:8 K ^PSRX(PSOX("IRXN"),"ICD",D,0)  ;remove any icd's del
     126 . I $D(^PSRX(PSOX("OIRXN"),"ICD",0)) F D=1:1:8 Q:'$D(^PSRX(PSOX("OIRXN"),"ICD",D,0))  S PSOX("ICD",D)=$P(^PSRX(PSOX("OIRXN"),"ICD",D,0),U,1)
     127 I $G(ORD) I $D(^PS(52.41,ORD,0))&($D(PSORX("ICD"))) M PSOX("ICD")=PSONEW("ICD")
     128 I $D(PSOX("ICD")) F D=1:1:8 Q:'$D(PSOX("ICD",D))  S ICD=$G(PSOX("ICD",D)) D
     129 . S DDATA="",DDATA=ICD_"^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$S(PSOSCP>49:$G(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$G(PSOANSQ("SC")),1:"")_"^"_$G(PSOANSQ("PGW"))_"^"_$G(PSOANSQ("MST"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV"))
     130 . I $P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1 I PSOSCP<50&($D(PSOANSQ("SC>50"))) S $P(DDATA,"^",4)=PSOANSQ("SC>50")  ;for times when sc has no % defined.
     131 . S ^PSRX(PSOX("IRXN"),"ICD",D,0)=DDATA,II=D
     132 E  S D=1 D
     133 . S DDATA="",DDATA="^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$S(PSOSCP>49:$G(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$G(PSOANSQ("SC")),1:"")
     134 . S DDATA=DDATA_"^"_$G(PSOANSQ("PGW"))_"^"_$G(PSOANSQ("MST"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV"))
     135 . S ^PSRX(PSOX("IRXN"),"ICD",D,0)=DDATA,II=D
     136 . I $P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1 I PSOSCP<50&($D(PSOANSQ("SC>50"))) S $P(^PSRX(PSOX("IRXN"),"ICD",D,0),"^",4)=PSOANSQ("SC>50")
     137 S ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311P^"_II_"^"_II
     138 K PSOX("ICD"),PSORXED("ICD"),PSONEW("ICD"),PSORX("ICD")
     139 Q
     140 ;
     141UPDATE ;was in PSOORED6; now called from PSOORED6; removes deletes for edits and stores data.
     142 ;
     143 N TNEW,DA,DIK,SCEI,I,II
     144 S DA=PSORXED("IRXN")
     145 I '$D(PSORXED("ICD"))&($G(PSORXED("IDFLG"))) D  K PSORXED("IDFLG") Q
     146 . I $D(^PSRX(PSORXED("IRXN"),"ICD",1,0)) D
     147 .. S TNEW=2 K ^PSRX(PSORXED("IRXN"),"ICD","B") S $P(^PSRX(PSORXED("IRXN"),"ICD",1,0),U,1)=""
     148 .. F I=TNEW:1:8 Q:'$D(^PSRX(PSORXED("IRXN"),"ICD",I,0))  S DIK="^PSRX("_PSORXED("IRXN")_","_$C(34)_"ICD"_$C(34)_",",DA=I,DA(1)=PSORXED("IRXN") D ^DIK K DA,DIK
     149 ;
     150 I $D(PSORXED("ICD")) D
     151 . S SCEI=$G(^PSRX(DA,"ICD",1,0)),$P(SCEI,"^")=""
     152 . K ^PSRX(DA,"ICD")
     153 . F I=1:1:8 Q:'$D(PSORXED("ICD",I))  S $P(SCEI,"^")=PSORXED("ICD",I),^PSRX(DA,"ICD",I,0)=SCEI,^PSRX(DA,"ICD","B",$P(SCEI,"^"),I)="",II=I
     154 . S ^PSRX(DA,"ICD",0)="^52.052311P^"_II_U_II
     155 Q
     156 ;
     157CSET ;Called from PSOHLNEW due to it's routine size.  Requires PSOICD & PENDING variable.  Sets ICD node for orders passed from CPRS.
     158 N EE,EEE
     159 S (EE,EEE)=0 F  S EE=$O(PSOICD(EE)) Q:EE=""  D
     160 .S EEE=EEE+1,^PS(52.41,PENDING,"ICD",EEE,0)=PSOICD(EE) S:$P(PSOICD(EE),"^")'="" ^PS(52.41,PENDING,"ICD","B",$P(PSOICD(EE),"^"),EEE)=""
     161 .S ^PS(52.41,PENDING,"ICD",0)="^52.41311PA"_U_EEE_U_EEE
     162 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR.m

    r613 r623  
    1 PSODIR  ;BHAM ISC/SAB - asks data for rx order entry ; 9/17/07 5:03pm
    2         ;;7.0;OUTPATIENT PHARMACY;**37,46,111,117,146,164,211,264,275**;DEC 1997;Build 8
    3         ;External reference PSDRUG( supported by DBIA 221
    4         ;External reference PS(50.7 supported by DBIA 2223
    5         ;External reference to VA(200 is supported by DBIA 10060
    6         ;----------------------------------------------------------------
    7         ;
    8 PROV(PSODIR)    ;
    9 PROVEN  ; Entry point for failed lookup
    10         K DIC,X,Y S:$G(PSOFDR)&($G(OR0)) DIC("B")=$P(^VA(200,$P($G(OR0),"^",5),0),"^")
    11         I $G(PSODIR("PROVIDER"))]"" S PSODIR("OLD VAL")=PSODIR("PROVIDER")
    12         S DIC="^VA(200,",DIC(0)="QEAM",PSODIR("FIELD")=0
    13         S DIC("W")="W ""     "",$P(^(""PS""),""^"",9)"
    14         S DIC("A")="PROVIDER: ",DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)"
    15         I $G(PSOTPBFG),$G(PSOFROM)="NEW" S DIC("S")=DIC("S")_",$P($G(^(""TPB"")),""^""),$P($G(^(""TPB"")),""^"",5)=0"
    16         S:$G(PSORX("PROVIDER NAME"))]"" DIC("B")=PSORX("PROVIDER NAME")
    17         D ^DIC K DIC
    18         I X[U,$L(X)>1 D:'$G(PSOEDIT) JUMP G PROVX
    19         I $D(DTOUT)!$D(DUOUT) S PSODIR("DFLG")=1 G PROVX
    20         I '$G(SPEED),Y=-1 G PROVEN
    21         Q:$G(SPEED)&(Y=-1)
    22         ;PSO*7*211; ADD CHECK FOR DEA# AND VA#
    23         I $P($G(PSODIR("CS")),"^",1)!($D(CLOZPAT)) I '$L($P($G(^VA(200,+Y,"PS")),U,2)),'$L($P($G(^VA(200,+Y,"PS")),U,3)) D  G PROVEN
    24         .W $C(7),!!,"Provider must have a DEA# or VA#"_$S($D(CLOZPAT):" to write prescriptions for clozapine.",1:""),!
    25         I $D(CLOZPAT),'$D(^XUSEC("YSCL AUTHORIZED",+Y)) D  G PROVEN
    26         .W $C(7),!!,"Provider must hold YSCL AUTHORIZED key to write prescriptions for clozapine.",!
    27         I '$G(PSODRUG("IEN")),'$G(PSORENW("DRUG IEN")) G NODRUG
    28         ;I '$G(SPEED),$P($G(^PSDRUG($S($G(PSODRUG("IEN")):PSODRUG("IEN"),1:PSORENW("DRUG IEN")),"CLOZ1")),"^")="PSOCLO1",$P(^VA(200,+Y,"PS"),"^",2)'?2U7N D  K Y,PSORX("PROVIDER NAME"),DIC("B") G PROVEN
    29         ;.W $C(7),!!,"Only providers with DEA numbers can write prescriptions for clozapine.",!
    30 NODRUG  S PSODIR("PROVIDER")=+Y
    31         S (PSODIR("PROVIDER NAME"),PSORX("PROVIDER NAME"))=$P(Y,"^",2)
    32         I $G(PSODIR("OLD VAL"))'=+Y K PSODIR("GENERIC PROVIDER"),PSODIR("COSIGNING PROVIDER")
    33         I $G(PSODIR("OLD VAL"))'=$G(PSODIR("PROVIDER")),$P(Y,"^",2)="PROVIDER,OTHER"!($P(Y,"^",2)="PROVIDER,OUTSIDE") D GENERIC
    34         I $P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",7),$P(^("PS"),"^",8) D COSIGN
    35         I $G(PSODIR("COSIGNING PROVIDER")),'$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",7) K PSODIR("COSIGNING PROVIDER")
    36 PROVX   K X,Y
    37         Q
    38         ;
    39 GENERIC ;
    40         K DIR,DIC,PSODIR("GENERIC PROVIDER")
    41         S DIR(0)="52,30"
    42         D DIR G:PSODIR("DFLG")!PSODIR("FIELD") GENERICX
    43         S PSODIR("GENERIC PROVIDER")=Y
    44 GENERICX        K X,Y
    45         Q
    46         ;
    47 COSIGN  ;
    48         K DIC
    49         I '$G(PSODIR("COSIGNING PROVIDER")),$P($G(RX3),"^",3) S PSODIR("COSIGNING PROVIDER")=$P(RX3,"^",3) G COSIGN1
    50         I $P($G(RX3),"^",3),$P($G(RX3),"^",3)'=$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8) D
    51         .W !!,"Previous Co-Signing Provider: "_$P(^VA(200,$P(RX3,"^",3),0),"^")
    52         .S PSODIR("COSIGNING PROVIDER")=$S($P(RX3,"^",3)'=PSODIR("COSIGNING PROVIDER"):PSODIR("COSIGNING PROVIDER"),1:$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8))
    53 COSIGN1 S DIC(0)="QEAM",DIC="^VA(200,",DIC("B")=$S($G(PSODIR("COSIGNING PROVIDER")):$P(^VA(200,PSODIR("COSIGNING PROVIDER"),0),"^"),1:$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8))
    54         S DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)"
    55         S DIC("W")="W ""     "",$P(^(""PS""),""^"",9)",DIC("S")=DIC("S")_",'$P(^(""PS""),""^"",7)"
    56         S DIC("A")="COSIGNING PROVIDER: " D ^DIC K DIC
    57         I $D(DTOUT)!$D(DUOUT) S PSODIR("DFLG")=1 G COSIGNX
    58         S:+Y>0 PSODIR("COSIGNING PROVIDER")=+Y G:Y<0 COSIGN
    59 COSIGNX K X,Y
    60         Q
    61 DOSE(PSODIR)    ;add dosing info
    62         D DOSE1^PSOORED5(.PSODIR)
    63 EX      K PSODOSE,PSOSCH,DOSE,DOOR,SCH,VERB,NOUN,DOSEOR,ENT,PSORTE,DRUA,DIR,X,Y,DIRUT,RTE,ERTE,DD,INS1,SINS1
    64         Q
    65 INS(PSODIR)     ;patient instructions
    66         N DA K INS1,DD,DIR,DIRUT S D=0 F  S D=$O(PSODIR("SIG",D)) Q:'D  S DD=$G(DD)+1
    67         I $G(DD)=1 S PSODIR("INS")=$G(PSODIR("SIG",1)) G INSD
    68         ;PSO*7*275 remove check for PSOINSFL just check for multi line sig
    69         I $G(DD)>1 D  G EX
    70         .K ^TMP($J) S D=0 F  S D=$O(PSODIR("SIG",D)) Q:'D  S ^TMP($J,"SIG",D,0)=PSODIR("SIG",D)
    71         .S DWPK=2,DWLW=80,DIC="^TMP($J,""SIG""," D EN^DIWE K PSODIR("SIG")
    72         .S D=0 F  S D=$O(^TMP($J,"SIG",D)) Q:'D  S PSODIR("SIG",D)=^TMP($J,"SIG",D,0)
    73         .D EN^PSOFSIG(.PSODIR,1) K DWLW,D,DWPK,^TMP($J)
    74         I $G(PSOINSFL)=0 G INSD
    75         I $G(PSOFDR),$G(ORD),$P($G(^PS(52.41,+$G(ORD),"EXT")),"^")'="" G INSD
    76         I $G(PSODIR("INS"))']"",$G(^PS(50.7,PSODRUG("OI"),"INS"))]"" S DIR("B")=^PS(50.7,PSODRUG("OI"),"INS")
    77 INSD    S DIR(0)="52,114" S:$G(PSODIR("INS"))]"" DIR("B")=PSODIR("INS")
    78         D DIR G:$G(PSODIR("DFLG"))!(PSODIR("FIELD")) EX
    79         I X'="",X'="@" S PSODIR("INS")=Y D SIG^PSOHELP G INSD:'$D(X)
    80         I $G(INS1)]"" D EN^DDIOL($E(INS1,2,9999999)) S (PSODIR("SIG",1),PSODIR("SIG"))=$E(INS1,2,9999999)
    81         I X="@" K PSODIR("INS"),PSODIR("SIG")
    82         D EN^PSOFSIG(.PSODIR,1) I $O(SIG(0)) S SIGOK=1
    83         G EX
    84         Q
    85 SINS(PSODIR)    ;other lang. patient instructions
    86         K SINS1,DIR
    87         S DIR(0)="52,114.1" S:$G(PSODIR("SINS"))]"" DIR("B")=PSODIR("SINS")
    88         I $G(PSODIR("SINS"))']"",$G(^PS(50.7,PSODRUG("OI"),"INS1"))]"" S DIR("B")=^PS(50.7,PSODRUG("OI"),"INS1")
    89         D DIR G:$G(PSODIR("DFLG")) EX
    90         I X'="",X'="@" S PSODIR("SINS")=Y D SSIG^PSOHELP
    91         I $G(SINS1)]"" D EN^DDIOL($E(SINS1,2,9999999)) S PSODIR("SINS")=$E(SINS1,2,9999999)
    92         I X="@" K PSODIR("SINS")
    93         G EX
    94         Q
    95         ;
    96 DIR     ;
    97         S PSODIR("FIELD")=0
    98         G:$G(DIR(0))']"" DIRX
    99         D ^DIR K DIR,DIE,DIC,DA
    100         I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1 S PSODIR("DFLG")=1 G DIRX
    101         I X[U,$L(X)>1 D:'$G(PSOEDIT) JUMP
    102 DIRX    K DIRUT,DTOUT,DUOUT,DIROUT,PSOX
    103         Q
    104         ;
    105 JUMP    ;
    106         I $G(PSOEDIT)!($G(OR0)) S PSODIR("DFLG")=1 Q
    107         S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC
    108         I Y=-1 S PSODIR("FIELD")=$G(PSODIR("FLD")) G JUMPX
    109         I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX
    110         I $G(PSOREF1)=0 D JUMP^PSOREF1 G JUMPX
    111         I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX
    112         I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX
    113 JUMPX   S X="^"_X
    114         Q
     1PSODIR ;BHAM ISC/SAB - asks data for rx order entry ;02/12/93 8:49
     2 ;;7.0;OUTPATIENT PHARMACY;**37,46,111,117,146,164,211,264**;DEC 1997;Build 19
     3 ;External reference PSDRUG( supported by DBIA 221
     4 ;External reference PS(50.7 supported by DBIA 2223
     5 ;External reference to VA(200 is supported by DBIA 10060
     6 ;----------------------------------------------------------------
     7 ;
     8PROV(PSODIR) ;
     9PROVEN ; Entry point for failed lookup
     10 K DIC,X,Y S:$G(PSOFDR)&($G(OR0)) DIC("B")=$P(^VA(200,$P($G(OR0),"^",5),0),"^")
     11 I $G(PSODIR("PROVIDER"))]"" S PSODIR("OLD VAL")=PSODIR("PROVIDER")
     12 S DIC="^VA(200,",DIC(0)="QEAM",PSODIR("FIELD")=0
     13 S DIC("W")="W ""     "",$P(^(""PS""),""^"",9)"
     14 S DIC("A")="PROVIDER: ",DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)"
     15 I $G(PSOTPBFG),$G(PSOFROM)="NEW" S DIC("S")=DIC("S")_",$P($G(^(""TPB"")),""^""),$P($G(^(""TPB"")),""^"",5)=0"
     16 S:$G(PSORX("PROVIDER NAME"))]"" DIC("B")=PSORX("PROVIDER NAME")
     17 D ^DIC K DIC
     18 I X[U,$L(X)>1 D:'$G(PSOEDIT) JUMP G PROVX
     19 I $D(DTOUT)!$D(DUOUT) S PSODIR("DFLG")=1 G PROVX
     20 I '$G(SPEED),Y=-1 G PROVEN
     21 Q:$G(SPEED)&(Y=-1)
     22 ;PSO*7*211; ADD CHECK FOR DEA# AND VA#
     23 I $P($G(PSODIR("CS")),"^",1)!($D(CLOZPAT)) I '$L($P($G(^VA(200,+Y,"PS")),U,2)),'$L($P($G(^VA(200,+Y,"PS")),U,3)) D  G PROVEN
     24 .W $C(7),!!,"Provider must have a DEA# or VA#"_$S($D(CLOZPAT):" to write prescriptions for clozapine.",1:""),!
     25 I $D(CLOZPAT),'$D(^XUSEC("YSCL AUTHORIZED",+Y)) D  G PROVEN
     26 .W $C(7),!!,"Provider must hold YSCL AUTHORIZED key to write prescriptions for clozapine.",!
     27 I '$G(PSODRUG("IEN")),'$G(PSORENW("DRUG IEN")) G NODRUG
     28 ;I '$G(SPEED),$P($G(^PSDRUG($S($G(PSODRUG("IEN")):PSODRUG("IEN"),1:PSORENW("DRUG IEN")),"CLOZ1")),"^")="PSOCLO1",$P(^VA(200,+Y,"PS"),"^",2)'?2U7N D  K Y,PSORX("PROVIDER NAME"),DIC("B") G PROVEN
     29 ;.W $C(7),!!,"Only providers with DEA numbers can write prescriptions for clozapine.",!
     30NODRUG S PSODIR("PROVIDER")=+Y
     31 S (PSODIR("PROVIDER NAME"),PSORX("PROVIDER NAME"))=$P(Y,"^",2)
     32 I $G(PSODIR("OLD VAL"))'=+Y K PSODIR("GENERIC PROVIDER"),PSODIR("COSIGNING PROVIDER")
     33 I $G(PSODIR("OLD VAL"))'=$G(PSODIR("PROVIDER")),$P(Y,"^",2)="PROVIDER,OTHER"!($P(Y,"^",2)="PROVIDER,OUTSIDE") D GENERIC
     34 I $P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",7),$P(^("PS"),"^",8) D COSIGN
     35 I $G(PSODIR("COSIGNING PROVIDER")),'$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",7) K PSODIR("COSIGNING PROVIDER")
     36PROVX K X,Y
     37 Q
     38 ;
     39GENERIC ;
     40 K DIR,DIC,PSODIR("GENERIC PROVIDER")
     41 S DIR(0)="52,30"
     42 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") GENERICX
     43 S PSODIR("GENERIC PROVIDER")=Y
     44GENERICX K X,Y
     45 Q
     46 ;
     47COSIGN ;
     48 K DIC
     49 I '$G(PSODIR("COSIGNING PROVIDER")),$P($G(RX3),"^",3) S PSODIR("COSIGNING PROVIDER")=$P(RX3,"^",3) G COSIGN1
     50 I $P($G(RX3),"^",3),$P($G(RX3),"^",3)'=$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8) D
     51 .W !!,"Previous Co-Signing Provider: "_$P(^VA(200,$P(RX3,"^",3),0),"^")
     52 .S PSODIR("COSIGNING PROVIDER")=$S($P(RX3,"^",3)'=PSODIR("COSIGNING PROVIDER"):PSODIR("COSIGNING PROVIDER"),1:$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8))
     53COSIGN1 S DIC(0)="QEAM",DIC="^VA(200,",DIC("B")=$S($G(PSODIR("COSIGNING PROVIDER")):$P(^VA(200,PSODIR("COSIGNING PROVIDER"),0),"^"),1:$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8))
     54 S DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)"
     55 S DIC("W")="W ""     "",$P(^(""PS""),""^"",9)",DIC("S")=DIC("S")_",'$P(^(""PS""),""^"",7)"
     56 S DIC("A")="COSIGNING PROVIDER: " D ^DIC K DIC
     57 I $D(DTOUT)!$D(DUOUT) S PSODIR("DFLG")=1 G COSIGNX
     58 S:+Y>0 PSODIR("COSIGNING PROVIDER")=+Y G:Y<0 COSIGN
     59COSIGNX K X,Y
     60 Q
     61DOSE(PSODIR) ;add dosing info
     62 D DOSE1^PSOORED5(.PSODIR)
     63EX K PSODOSE,PSOSCH,DOSE,DOOR,SCH,VERB,NOUN,DOSEOR,ENT,PSORTE,DRUA,DIR,X,Y,DIRUT,RTE,ERTE,DD,INS1,SINS1
     64 Q
     65INS(PSODIR) ;patient instructions
     66 N DA K INS1,DD,DIR,DIRUT S D=0 F  S D=$O(PSODIR("SIG",D)) Q:'D  S DD=$G(DD)+1
     67 I $G(DD)=1 S PSODIR("INS")=$G(PSODIR("SIG",1)) G INSD
     68 I ($G(PSOINSFL)=1&($G(DD)>1))!($G(PSOFDR)&($G(ORD))&($P($G(^PS(52.41,+$G(ORD),"EXT")),"^")'="")&($G(DD)>1)) D  G EX
     69 .K ^TMP($J) S D=0 F  S D=$O(PSODIR("SIG",D)) Q:'D  S ^TMP($J,"SIG",D,0)=PSODIR("SIG",D)
     70 .S DWPK=2,DWLW=80,DIC="^TMP($J,""SIG""," D EN^DIWE K PSODIR("SIG")
     71 .S D=0 F  S D=$O(^TMP($J,"SIG",D)) Q:'D  S PSODIR("SIG",D)=^TMP($J,"SIG",D,0)
     72 .D EN^PSOFSIG(.PSODIR,1) K DWLW,D,DWPK,^TMP($J)
     73 I $G(PSOINSFL)=0 G INSD
     74 I $G(PSOFDR),$G(ORD),$P($G(^PS(52.41,+$G(ORD),"EXT")),"^")'="" G INSD
     75 I $G(PSODIR("INS"))']"",$G(^PS(50.7,PSODRUG("OI"),"INS"))]"" S DIR("B")=^PS(50.7,PSODRUG("OI"),"INS")
     76INSD S DIR(0)="52,114" S:$G(PSODIR("INS"))]"" DIR("B")=PSODIR("INS")
     77 D DIR G:$G(PSODIR("DFLG"))!(PSODIR("FIELD")) EX
     78 I X'="",X'="@" S PSODIR("INS")=Y D SIG^PSOHELP G INSD:'$D(X)
     79 I $G(INS1)]"" D EN^DDIOL($E(INS1,2,9999999)) S (PSODIR("SIG",1),PSODIR("SIG"))=$E(INS1,2,9999999)
     80 I X="@" K PSODIR("INS"),PSODIR("SIG")
     81 D EN^PSOFSIG(.PSODIR,1) I $O(SIG(0)) S SIGOK=1
     82 G EX
     83 Q
     84SINS(PSODIR) ;other lang. patient instructions
     85 K SINS1,DIR
     86 S DIR(0)="52,114.1" S:$G(PSODIR("SINS"))]"" DIR("B")=PSODIR("SINS")
     87 I $G(PSODIR("SINS"))']"",$G(^PS(50.7,PSODRUG("OI"),"INS1"))]"" S DIR("B")=^PS(50.7,PSODRUG("OI"),"INS1")
     88 D DIR G:$G(PSODIR("DFLG")) EX
     89 I X'="",X'="@" S PSODIR("SINS")=Y D SSIG^PSOHELP
     90 I $G(SINS1)]"" D EN^DDIOL($E(SINS1,2,9999999)) S PSODIR("SINS")=$E(SINS1,2,9999999)
     91 I X="@" K PSODIR("SINS")
     92 G EX
     93 Q
     94 ;
     95DIR ;
     96 S PSODIR("FIELD")=0
     97 G:$G(DIR(0))']"" DIRX
     98 D ^DIR K DIR,DIE,DIC,DA
     99 I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1 S PSODIR("DFLG")=1 G DIRX
     100 I X[U,$L(X)>1 D:'$G(PSOEDIT) JUMP
     101DIRX K DIRUT,DTOUT,DUOUT,DIROUT,PSOX
     102 Q
     103 ;
     104JUMP ;
     105 I $G(PSOEDIT)!($G(OR0)) S PSODIR("DFLG")=1 Q
     106 S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC
     107 I Y=-1 S PSODIR("FIELD")=$G(PSODIR("FLD")) G JUMPX
     108 I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX
     109 I $G(PSOREF1)=0 D JUMP^PSOREF1 G JUMPX
     110 I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX
     111 I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX
     112JUMPX S X="^"_X
     113 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR1.m

    r613 r623  
    1 PSODIR1 ;IHS/DSD - ASKS DATA FOR RX ORDER ENTRY CONT. ;6/21/07 8:22am
    2         ;;7.0;OUTPATIENT PHARMACY;**23,46,78,102,121,131,146,166,184,222,268,206**;DEC 1997;Build 39
    3         ;Ext ref ^PS(55-DBIA 2228, ^PSDRUG(-DBIA 221
    4 PTSTAT(PSODIR)  ;
    5 PTSTATEN        K DIC,DR,DIE S PSODIR("FIELD")=0
    6         I $G(PSOTPBFG),$G(PSOFROM)="NEW" K PSORX("PATIENT STATUS"),PSODIR("PATIENT STATUS") N PSOFNDRX,PSOFNDFL,PSOFNDPS D
    7         .S PSOFNDFL=0 F PSOFNDPS=0:0 S PSOFNDPS=$O(^PS(53,PSOFNDPS)) Q:'PSOFNDPS!(PSOFNDFL)  D
    8         ..S PSOFNDRX=$P($G(^PS(53,PSOFNDPS,0)),"^") S PSOFNDRX=$$UP^XLFSTR(PSOFNDRX) I PSOFNDRX="NON-VA" S PSOFNDFL=1 S (PSORX("PATIENT STATUS"),DIC("B"))=$P($G(^PS(53,PSOFNDPS,0)),"^")
    9         I $G(PSOTPBFG),$G(PSOFROM)="NEW",$G(PSORX("PATIENT STATUS"))="" W !,"Could not find a 'NON-VA' Patient Status in the RX PATIENT STATUS file (#53)!" D PSTPB D  S PSODIR("DFLG")=1 G PTSTATX
    10         .K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
    11         I $G(PSOTPBFG),$G(PSOFROM)="NEW" G TPBB
    12         N PSOX
    13         S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^"),DIC("B")=PSORX("PATIENT STATUS")
    14         S:$G(PSODIR("PATIENT STATUS"))]"" DIC("B")=PSODIR("PATIENT STATUS")
    15 TPBB    ;
    16         D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):"     SC%: "_$P(VAEL(3),"^",2),1:"")
    17         S N=0 F  S N=$O(VAEL(1,N)) Q:'N  W !,?10,$P(VAEL(1,N),"^",2)
    18         S DIC("A")="RX PATIENT STATUS: "
    19         S DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC
    20         I $G(PSOTPBFG),$G(PSOFROM)="NEW" N PSOPSDIR,PSOFNDZZ,PSOPSUPA S (PSOPSDIR,PSOPSUPA)=0 D  I PSOPSDIR S:PSOPSUPA PSODIR("DFLG")=1 G:PSOPSUPA PTSTATX W ! D PSTPB G PTSTATEN
    21         .I +Y'>0!($D(DTOUT))!($D(DUOUT)) S (PSOPSDIR,PSOPSUPA)=1 Q
    22         .S (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y,PSODIR("PTST NODE")=Y(0)
    23         .S PSOFNDZZ=$P($G(^PS(53,+Y,0)),"^") S PSOFNDZZ=$$UP^XLFSTR(PSOFNDZZ) I PSOFNDZZ'="NON-VA" S PSOPSDIR=1 K PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"),PSODIR("PTST NODE")
    24         I $G(PSOTPBFG),$G(PSOFROM)="NEW" G TPBSC
    25         I X[U,$L(X)>1 D:'$G(PSOEDIT) JUMP G PTSTATX
    26         I $D(DUOUT)!$D(DTOUT) S PSODIR("DFLG")=1 G PTSTATX
    27         I Y=-1 W $C(7)," Required" G PTSTATEN
    28         N PSOFNDX,PSOFNDXY,PSOFNDXX,PSOFNDYY
    29         S PSOFNDXY=$G(Y),PSOFNDYY=$G(Y(0))
    30         I '$G(PSOTPBFG),$G(PSOFROM)="NEW" S PSOFNDX=$P($G(^PS(53,+Y,0)),"^") S PSOFNDXX=$$UP^XLFSTR(PSOFNDX) I PSOFNDXX="NON-VA" K PSOFNDX,PSOFNDXY,PSOFNDYY,PSOFNDXX,Y W !!,"Cannot select 'NON-VA' Rx Patient Status!",! G PTSTATEN
    31         S Y=$G(PSOFNDXY),Y(0)=$G(PSOFNDYY)
    32         K PSOFNDXY,PSOFNDYY,PSOFNDX,PSOFNDXX
    33         S (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y
    34         S PSODIR("PTST NODE")=Y(0)
    35 TPBSC   ;
    36         I $G(PSOFDR),$P($G(OR0),"^",17)="C" G PTSTATX
    37         L +^PS(55,PSODFN):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T G PTSTATX
    38         S DIE="55",DR="3////"_+Y,DA=PSODFN D ^DIE K DIE,DA,D0
    39         L -^PS(55,PSODFN)
    40 PTSTATX K DTOUT,DUOUT,X,Y,DA
    41         Q
    42 SIG(PSODIR)     ;
    43         I $G(PSOFDR),$G(PSODIR("SIG"))']"" D SIGOK G:$G(SIGOK)!($G(PSODIR("DFLG"))) SIGX
    44         K DIR,DIC
    45         S DIR(0)="52,10"
    46         S:$G(PSODRUG("SIG"))]"" DIR("B")=PSODRUG("SIG")
    47         S:$G(PSODIR("SIG"))]"" DIR("B")=PSODIR("SIG")
    48         D DIR G:PSODIR("DFLG")!PSODIR("FIELD") SIGX
    49         S PSODIR("SIG")=Y,SIGOK=0 K SIG
    50 SIGX    K X,Y
    51         Q
    52 QTY(PSODIR)     ;
    53 QTYA    K DIR,DIC
    54         I $G(CLOZPAT)=1 S DIR("A",1)="Patient Eligible for 14 day supply or 7 day supply with 1 refill"
    55         I $G(CLOZPAT)=2 S DIR("A",1)="Patient Eligible 28 day supply or 14 day supply with 1 refill or 7 day supply with 3 refill"
    56         S DIR(0)="52,7" S:$G(PSODRUG("IEN")) DIR("A")="QTY ( "_$G(PSODRUG("UNIT"))_" ) "_$S($P($G(^PSDRUG(+PSODRUG("IEN"),5)),"^")]"":$P(^PSDRUG(+PSODRUG("IEN"),5),"^"),1:"")
    57         K QTYHLD I $G(PSODIR("QTY"))]"" S QTYHLD=PSODIR("QTY") K PSODIR("QTY")
    58         D:'$G(PSOQTY) QTY^PSOSIG(.PSODIR)
    59         I '$G(SPEED),$G(QTYHLD),'$G(PSODIR("QTY")) S PSODIR("QTY")=QTYHLD
    60         K QTYHLD K:'$G(PSODIR("QTY")) PSODIR("QTY")
    61         I $G(SPEED),$G(PSODIR("QTY"))']"" S PSODIR("QTY")=$P(^PSRX(PSORENW("OIRXN"),0),"^",7)
    62         S:$G(PSODIR("QTY"))]"" DIR("B")=PSODIR("QTY")
    63         D DIR G:PSODIR("DFLG")!PSODIR("FIELD") QTYX
    64         I $G(Y),$G(PSODRUG("MAXDOSE"))]"",$G(PSODIR("DAYS SUPPLY")),(Y/+PSODIR("DAYS SUPPLY")>PSODRUG("MAXDOSE")) D  G:$G(PSODIR("DFLG")) QTYX  G QTYA
    65         .W !,$C(7)," Greater than Maximum dose of "_PSODRUG("MAXDOSE")_" per day" D DAYSEN
    66         S PSODIR("QTY")=Y
    67 QTYX    K X,Y
    68         Q
    69 COPIES(PSODIR)  ;
    70         K DIR,DIC
    71         S DIR(0)="52,10.6"
    72         S DIR("B")=$S($G(PSODIR("COPIES"))]"":PSODIR("COPIES"),1:1)
    73         D DIR G:PSODIR("DFLG")!PSODIR("FIELD") COPIESX
    74         S PSODIR("COPIES")=Y
    75 COPIESX K X,Y
    76         Q
    77 DAYS(PSODIR)    ;
    78 DAYSEN  K DIR,DIC
    79         S DIR(0)="N^1:"_$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90)
    80         S DIR("B")=$S($D(CLOZPAT)&('$G(PSODIR("DAYS SUPPLY"))):7,$G(PSODIR("DAYS SUPPLY"))]"":PSODIR("DAYS SUPPLY"),$P($G(PSODIR("PTST NODE")),"^",3):$P(PSODIR("PTST NODE"),"^",3),1:30)
    81         S DIR("A")="DAYS SUPPLY",DIR("?")="Enter a whole number between 1 and "_$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90)
    82         D DIR G:PSODIR("DFLG")!PSODIR("FIELD") DAYSX
    83         I $G(Y),$G(PSODRUG("MAXDOSE"))]"",$G(PSODIR("QTY"))]"",(+PSODIR("QTY")/Y>PSODRUG("MAXDOSE")) W !,$C(7)," Greater than Maximum dose of "_PSODRUG("MAXDOSE")_" per day" G DAYSEN
    84         S PSODIR("DAYS SUPPLY")=Y D:$G(PSOFROM)="NEW"
    85         .K QTYHLD S:$G(PSODIR("QTY")) QTYHLD=PSODIR("QTY") D QTY^PSOSIG(.PSODIR)
    86         .I $G(QTYHLD),'$G(PSODIR("QTY")) S PSODIR("QTY")=QTYHLD
    87         .K QTYHLD K:'$G(PSODIR("QTY")) PSODIR("QTY")
    88         S:$G(CLOZPAT)=0 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0
    89         D:$G(CLOZPAT)=2
    90         .S:PSODIR("DAYS SUPPLY")=28 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0
    91         .S:PSODIR("DAYS SUPPLY")=14 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=1
    92         .S:PSODIR("DAYS SUPPLY")=7 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=3
    93         D:$G(CLOZPAT)=1
    94         .S:PSODIR("DAYS SUPPLY")=14 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0
    95         .S:PSODIR("DAYS SUPPLY")=7 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=1
    96         K QTYHLD S:$G(PSODIR("QTY")) QTYHLD=PSODIR("QTY") D QTY^PSOSIG(.PSODIR)
    97         I $G(QTYHLD),'$G(PSODIR("QTY")) S PSODIR("QTY")=QTYHLD
    98         K QTYHLD K:'$G(PSODIR("QTY")) PSODIR("QTY")
    99 DAYSX   K X,Y
    100         Q
    101 REFILL(PSODIR)  ;
    102         I $G(OR0) G REFOR
    103         S PSODIR("CS")=0 K DIR,DIC,PSOX
    104         F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSODIR("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSODIR("CS"),"^",2)=1
    105         I PSODIR("CS") D
    106         .S PSOX=5,PSOX1=$S($P($G(PSODIR("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSODIR("PTST NODE")),"^",4)),PSOX=$S(PSOX1=5:PSOX,1:PSOX1)
    107         .S PSOX=$S('PSOX:0,PSODIR("DAYS SUPPLY")=90:1,1:PSOX),PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
    108         E  D
    109         .S PSOX=11,PSOX1=$S($P($G(PSODIR("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSODIR("PTST NODE")),"^",4)),PSOX=$S(PSOX1=11:PSOX,1:PSOX1)
    110         .S PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
    111         I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) D  G REFILLX
    112         .I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2)!'$O(^PSRX(+$G(PSODIR("IRXN")),1,0))!('$G(PSOLOKED)) D  Q
    113         ..S VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics.") W !,VALMSG,!
    114         ..S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0
    115         ..Q
    116         .;reset refills to the # given
    117         .D RFRSET^PSODIR2
    118         .Q
    119         I $P($G(PSODIR("CS")),"^",2)=1 W !,"No refills allowed on Schedule 2 drugs...",! S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0 G REFILLX
    120         I $D(CLOZPAT) S PSOX=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,1:0)
    121         S DIR(0)="N^"_$S($G(RFTT):RFTT,1:0)_":"_PSOX,DIR("A")="# OF REFILLS"
    122         S DIR("B")=$S($G(COPY):PSODIR("# OF REFILLS"),$G(PSODIR("N# REF"))]"":PSODIR("N# REF"),$G(PSODIR("# OF REFILLS"))]"":PSODIR("# OF REFILLS"),$G(PSOX1)]""&(PSOX>PSOX1):PSOX1,1:PSOX)
    123         S DIR("?")="Enter a whole number.  The maximum is set by the DAYS SUPPLY field."
    124         D DIR G:PSODIR("DFLG")!PSODIR("FIELD") REFILLX
    125         S (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=Y
    126 REFILLX S:$G(PSODIR("# OF REFILLS"))']"" PSODIR("# OF REFILLS")=$S($G(PSODIR("N# REF"))]"":PSODIR("N# REF"),$G(PSOX1)]""&($G(PSOX)>PSOX1):PSOX1,1:PSOX)
    127         K X,Y,PSOX,PSOX1,PSDY,PSDY1,DEA,PSOCS
    128         Q
    129         ;OERR CALL
    130 REFOR   ;
    131         D REFOR^PSODIR3
    132         G REFILLX
    133         Q
    134 DIR     ;
    135         S (PSODIR("FIELD"),PSODIR("DFLG"))=0
    136         G:$G(DIR(0))']"" DIRX
    137         D ^DIR K DIR,DIE,DIC,DA
    138         I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1!(Y="") S PSODIR("DFLG")=1 G DIRX
    139         I $D(DIRUT)!($D(DIROUT)),$G(SPEED) S PSODIR("DFLG")=1 G DIRX
    140         I X[U,$L(X)>1 D JUMP
    141 DIRX    K DIRUT,DTOUT,DUOUT,DIROUT
    142         Q
    143 JUMP    ;
    144         I $G(PSOEDIT)!($G(OR0)) S PSODIR("DFLG")=1 Q
    145         S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC
    146         I Y=-1 S PSODIR("FIELD")=PSODIR("FLD") G JUMPX
    147         I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX
    148         I $G(PSOREF1)=0 D JUMP^PSOREF1 G JUMPX
    149         I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX
    150         I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX
    151 JUMPX   S X="^"_X
    152         Q
    153 SIGOK   ;review and decide on oerr sig
    154         I '$O(SIG(0)) S SIGOK=0 Q
    155         K SIGOK W !,"SIG: "
    156         F SIG=0:0 S SIG=$O(SIG(SIG)) W SIG(SIG)_" ",!?5 Q:'$O(SIG(SIG))
    157         K DIR,DIRUT,DUOUT,DTOUT S DIR("B")="YES",DIR(0)="Y",DIR("A")="Is this SIG correct" D ^DIR K DIR I $D(DIRUT) S PSODIR("DFLG")=1 K DIRUT,DUOUT,DTOUT Q
    158         S SIGOK=Y I Y K PSODIR("SIG")
    159         Q
    160 PSTPB   ;
    161         W !,"New orders entered through this option must have a Patient Status of 'NON-VA'!",!
    162         Q
     1PSODIR1 ;IHS/DSD - ASKS DATA FOR RX ORDER ENTRY CONT. ;02/17/93 17:03
     2 ;;7.0;OUTPATIENT PHARMACY;**23,46,78,102,121,131,146,166,184,222,268**;DEC 1997;Build 9
     3 ;Ext ref ^PS(55-DBIA 2228, ^PSDRUG(-DBIA 221
     4PTSTAT(PSODIR) ;
     5PTSTATEN K DIC,DR,DIE S PSODIR("FIELD")=0
     6 I $G(PSOTPBFG),$G(PSOFROM)="NEW" K PSORX("PATIENT STATUS"),PSODIR("PATIENT STATUS") N PSOFNDRX,PSOFNDFL,PSOFNDPS D
     7 .S PSOFNDFL=0 F PSOFNDPS=0:0 S PSOFNDPS=$O(^PS(53,PSOFNDPS)) Q:'PSOFNDPS!(PSOFNDFL)  D
     8 ..S PSOFNDRX=$P($G(^PS(53,PSOFNDPS,0)),"^") S PSOFNDRX=$$UP^XLFSTR(PSOFNDRX) I PSOFNDRX="NON-VA" S PSOFNDFL=1 S (PSORX("PATIENT STATUS"),DIC("B"))=$P($G(^PS(53,PSOFNDPS,0)),"^")
     9 I $G(PSOTPBFG),$G(PSOFROM)="NEW",$G(PSORX("PATIENT STATUS"))="" W !,"Could not find a 'NON-VA' Patient Status in the RX PATIENT STATUS file (#53)!" D PSTPB D  S PSODIR("DFLG")=1 G PTSTATX
     10 .K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
     11 I $G(PSOTPBFG),$G(PSOFROM)="NEW" G TPBB
     12 N PSOX
     13 S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^"),DIC("B")=PSORX("PATIENT STATUS")
     14 S:$G(PSODIR("PATIENT STATUS"))]"" DIC("B")=PSODIR("PATIENT STATUS")
     15TPBB ;
     16 D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):"     SC%: "_$P(VAEL(3),"^",2),1:"")
     17 S N=0 F  S N=$O(VAEL(1,N)) Q:'N  W !,?10,$P(VAEL(1,N),"^",2)
     18 S DIC("A")="RX PATIENT STATUS: "
     19 S DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC
     20 I $G(PSOTPBFG),$G(PSOFROM)="NEW" N PSOPSDIR,PSOFNDZZ,PSOPSUPA S (PSOPSDIR,PSOPSUPA)=0 D  I PSOPSDIR S:PSOPSUPA PSODIR("DFLG")=1 G:PSOPSUPA PTSTATX W ! D PSTPB G PTSTATEN
     21 .I +Y'>0!($D(DTOUT))!($D(DUOUT)) S (PSOPSDIR,PSOPSUPA)=1 Q
     22 .S (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y,PSODIR("PTST NODE")=Y(0)
     23 .S PSOFNDZZ=$P($G(^PS(53,+Y,0)),"^") S PSOFNDZZ=$$UP^XLFSTR(PSOFNDZZ) I PSOFNDZZ'="NON-VA" S PSOPSDIR=1 K PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"),PSODIR("PTST NODE")
     24 I $G(PSOTPBFG),$G(PSOFROM)="NEW" G TPBSC
     25 I X[U,$L(X)>1 D:'$G(PSOEDIT) JUMP G PTSTATX
     26 I $D(DUOUT)!$D(DTOUT) S PSODIR("DFLG")=1 G PTSTATX
     27 I Y=-1 W $C(7)," Required" G PTSTATEN
     28 N PSOFNDX,PSOFNDXY,PSOFNDXX,PSOFNDYY
     29 S PSOFNDXY=$G(Y),PSOFNDYY=$G(Y(0))
     30 I '$G(PSOTPBFG),$G(PSOFROM)="NEW" S PSOFNDX=$P($G(^PS(53,+Y,0)),"^") S PSOFNDXX=$$UP^XLFSTR(PSOFNDX) I PSOFNDXX="NON-VA" K PSOFNDX,PSOFNDXY,PSOFNDYY,PSOFNDXX,Y W !!,"Cannot select 'NON-VA' Rx Patient Status!",! G PTSTATEN
     31 S Y=$G(PSOFNDXY),Y(0)=$G(PSOFNDYY)
     32 K PSOFNDXY,PSOFNDYY,PSOFNDX,PSOFNDXX
     33 S (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y
     34 S PSODIR("PTST NODE")=Y(0)
     35TPBSC ;
     36 I $G(PSOFDR),$P($G(OR0),"^",17)="C" G PTSTATX
     37 L +^PS(55,PSODFN):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T G PTSTATX
     38 S DIE="55",DR="3////"_+Y,DA=PSODFN D ^DIE K DIE,DA,D0
     39 L -^PS(55,PSODFN)
     40PTSTATX K DTOUT,DUOUT,X,Y,DA
     41 Q
     42SIG(PSODIR) ;
     43 I $G(PSOFDR),$G(PSODIR("SIG"))']"" D SIGOK G:$G(SIGOK)!($G(PSODIR("DFLG"))) SIGX
     44 K DIR,DIC
     45 S DIR(0)="52,10"
     46 S:$G(PSODRUG("SIG"))]"" DIR("B")=PSODRUG("SIG")
     47 S:$G(PSODIR("SIG"))]"" DIR("B")=PSODIR("SIG")
     48 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") SIGX
     49 S PSODIR("SIG")=Y,SIGOK=0 K SIG
     50SIGX K X,Y
     51 Q
     52QTY(PSODIR) ;
     53QTYA K DIR,DIC
     54 I $G(CLOZPAT)=1 S DIR("A",1)="Patient Eligible for 14 day supply or 7 day supply with 1 refill"
     55 I $G(CLOZPAT)=2 S DIR("A",1)="Patient Eligible 28 day supply or 14 day supply with 1 refill or 7 day supply with 3 refill"
     56 S DIR(0)="52,7" S:$G(PSODRUG("IEN")) DIR("A")="QTY ( "_$G(PSODRUG("UNIT"))_" ) "_$S($P($G(^PSDRUG(+PSODRUG("IEN"),5)),"^")]"":$P(^PSDRUG(+PSODRUG("IEN"),5),"^"),1:"")
     57 K QTYHLD I $G(PSODIR("QTY"))]"" S QTYHLD=PSODIR("QTY") K PSODIR("QTY")
     58 D:'$G(PSOQTY) QTY^PSOSIG(.PSODIR)
     59 I '$G(SPEED),$G(QTYHLD),'$G(PSODIR("QTY")) S PSODIR("QTY")=QTYHLD
     60 K QTYHLD K:'$G(PSODIR("QTY")) PSODIR("QTY")
     61 I $G(SPEED),$G(PSODIR("QTY"))']"" S PSODIR("QTY")=$P(^PSRX(PSORENW("OIRXN"),0),"^",7)
     62 S:$G(PSODIR("QTY"))]"" DIR("B")=PSODIR("QTY")
     63 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") QTYX
     64 I $G(Y),$G(PSODRUG("MAXDOSE"))]"",$G(PSODIR("DAYS SUPPLY")),(Y/+PSODIR("DAYS SUPPLY")>PSODRUG("MAXDOSE")) D  G:$G(PSODIR("DFLG")) QTYX  G QTYA
     65 .W !,$C(7)," Greater than Maximum dose of "_PSODRUG("MAXDOSE")_" per day" D DAYSEN
     66 S PSODIR("QTY")=Y
     67QTYX K X,Y
     68 Q
     69COPIES(PSODIR) ;
     70 K DIR,DIC
     71 S DIR(0)="52,10.6"
     72 S DIR("B")=$S($G(PSODIR("COPIES"))]"":PSODIR("COPIES"),1:1)
     73 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") COPIESX
     74 S PSODIR("COPIES")=Y
     75COPIESX K X,Y
     76 Q
     77DAYS(PSODIR) ;
     78DAYSEN K DIR,DIC
     79 S DIR(0)="N^1:"_$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90)
     80 S DIR("B")=$S($D(CLOZPAT)&('$G(PSODIR("DAYS SUPPLY"))):7,$G(PSODIR("DAYS SUPPLY"))]"":PSODIR("DAYS SUPPLY"),$P($G(PSODIR("PTST NODE")),"^",3):$P(PSODIR("PTST NODE"),"^",3),1:30)
     81 S DIR("A")="DAYS SUPPLY",DIR("?")="Enter a whole number between 1 and "_$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90)
     82 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") DAYSX
     83 I $G(Y),$G(PSODRUG("MAXDOSE"))]"",$G(PSODIR("QTY"))]"",(+PSODIR("QTY")/Y>PSODRUG("MAXDOSE")) W !,$C(7)," Greater than Maximum dose of "_PSODRUG("MAXDOSE")_" per day" G DAYSEN
     84 S PSODIR("DAYS SUPPLY")=Y D:$G(PSOFROM)="NEW"
     85 .K QTYHLD S:$G(PSODIR("QTY")) QTYHLD=PSODIR("QTY") D QTY^PSOSIG(.PSODIR)
     86 .I $G(QTYHLD),'$G(PSODIR("QTY")) S PSODIR("QTY")=QTYHLD
     87 .K QTYHLD K:'$G(PSODIR("QTY")) PSODIR("QTY")
     88 S:$G(CLOZPAT)=0 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0
     89 D:$G(CLOZPAT)=2
     90 .S:PSODIR("DAYS SUPPLY")=28 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0
     91 .S:PSODIR("DAYS SUPPLY")=14 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=1
     92 .S:PSODIR("DAYS SUPPLY")=7 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=3
     93 D:$G(CLOZPAT)=1
     94 .S:PSODIR("DAYS SUPPLY")=14 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0
     95 .S:PSODIR("DAYS SUPPLY")=7 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=1
     96 K QTYHLD S:$G(PSODIR("QTY")) QTYHLD=PSODIR("QTY") D QTY^PSOSIG(.PSODIR)
     97 I $G(QTYHLD),'$G(PSODIR("QTY")) S PSODIR("QTY")=QTYHLD
     98 K QTYHLD K:'$G(PSODIR("QTY")) PSODIR("QTY")
     99DAYSX K X,Y
     100 Q
     101REFILL(PSODIR) ;
     102 I $G(OR0) G REFOR
     103 S PSODIR("CS")=0 K DIR,DIC,PSOX
     104 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSODIR("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSODIR("CS"),"^",2)=1
     105 I PSODIR("CS") D
     106 .S PSOX=5,PSOX1=$S($P($G(PSODIR("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSODIR("PTST NODE")),"^",4)),PSOX=$S(PSOX1=5:PSOX,1:PSOX1)
     107 .S PSOX=$S('PSOX:0,PSODIR("DAYS SUPPLY")=90:1,1:PSOX),PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
     108 E  D
     109 .S PSOX=11,PSOX1=$S($P($G(PSODIR("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSODIR("PTST NODE")),"^",4)),PSOX=$S(PSOX1=11:PSOX,1:PSOX1)
     110 .S PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
     111 I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") D  G REFILLX
     112 .I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!'$O(^PSRX(+$G(PSODIR("IRXN")),1,0))!('$G(PSOLOKED)) D  Q
     113 ..S VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics.") W !,VALMSG,!
     114 ..S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0
     115 ..Q
     116 .;reset refills to the # given
     117 .D RFRSET^PSODIR2
     118 .Q
     119 I $P($G(PSODIR("CS")),"^",2)=1 W !,"No refills allowed on Schedule 2 drugs...",! S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0 G REFILLX
     120 I $D(CLOZPAT) S PSOX=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,1:0)
     121 S DIR(0)="N^"_$S($G(RFTT):RFTT,1:0)_":"_PSOX,DIR("A")="# OF REFILLS"
     122 S DIR("B")=$S($G(COPY):PSODIR("# OF REFILLS"),$G(PSODIR("N# REF"))]"":PSODIR("N# REF"),$G(PSODIR("# OF REFILLS"))]"":PSODIR("# OF REFILLS"),$G(PSOX1)]""&(PSOX>PSOX1):PSOX1,1:PSOX)
     123 S DIR("?")="Enter a whole number.  The maximum is set by the DAYS SUPPLY field."
     124 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") REFILLX
     125 S (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=Y
     126REFILLX S:$G(PSODIR("# OF REFILLS"))']"" PSODIR("# OF REFILLS")=$S($G(PSODIR("N# REF"))]"":PSODIR("N# REF"),$G(PSOX1)]""&($G(PSOX)>PSOX1):PSOX1,1:PSOX)
     127 K X,Y,PSOX,PSOX1,PSDY,PSDY1,DEA,PSOCS
     128 Q
     129 ;OERR CALL
     130REFOR ;
     131 D REFOR^PSODIR3
     132 G REFILLX
     133 Q
     134DIR ;
     135 S (PSODIR("FIELD"),PSODIR("DFLG"))=0
     136 G:$G(DIR(0))']"" DIRX
     137 D ^DIR K DIR,DIE,DIC,DA
     138 I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1!(Y="") S PSODIR("DFLG")=1 G DIRX
     139 I $D(DIRUT)!($D(DIROUT)),$G(SPEED) S PSODIR("DFLG")=1 G DIRX
     140 I X[U,$L(X)>1 D JUMP
     141DIRX K DIRUT,DTOUT,DUOUT,DIROUT
     142 Q
     143JUMP ;
     144 I $G(PSOEDIT)!($G(OR0)) S PSODIR("DFLG")=1 Q
     145 S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC
     146 I Y=-1 S PSODIR("FIELD")=PSODIR("FLD") G JUMPX
     147 I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX
     148 I $G(PSOREF1)=0 D JUMP^PSOREF1 G JUMPX
     149 I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX
     150 I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX
     151JUMPX S X="^"_X
     152 Q
     153SIGOK ;review and decide on oerr sig
     154 I '$O(SIG(0)) S SIGOK=0 Q
     155 K SIGOK W !,"SIG: "
     156 F SIG=0:0 S SIG=$O(SIG(SIG)) W SIG(SIG)_" ",!?5 Q:'$O(SIG(SIG))
     157 K DIR,DIRUT,DUOUT,DTOUT S DIR("B")="YES",DIR(0)="Y",DIR("A")="Is this SIG correct" D ^DIR K DIR I $D(DIRUT) S PSODIR("DFLG")=1 K DIRUT,DUOUT,DTOUT Q
     158 S SIGOK=Y I Y K PSODIR("SIG")
     159 Q
     160PSTPB ;
     161 W !,"New orders entered through this option must have a Patient Status of 'NON-VA'!",!
     162 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR3.m

    r613 r623  
    1 PSODIR3 ;ISC-BIRM/SAB - rx order entry contd ;4/25/07 8:28am
    2         ;;7.0;OUTPATIENT PHARMACY;**3,46,184,222,206**;DEC 1997;Build 39
    3         ;
    4 EXP(PSODIR)     ;
    5         K DIC,DIR
    6         I $G(PSODRUG("EXPIRATION DATE"))]"" S Y=PSODRUG("EXPIRATION DATE") X ^DD("DD") S PSORX("EXPIRATION DATE")=Y
    7         S DIR("A")="EXPIRES",DIR("B")=$S($G(PSORX("EXPIRATION DATE"))]"":PSORX("EXPIRATION DATE"),1:"T+6M")
    8         S DIR(0)="D^NOW::EX",DIR("?")="Both the month and date are required." D ^DIR
    9         G:PSODIR("DFLG")!PSODIR("FIELD") EXPX
    10         S PSODIR("EXPIRATION DATE")=Y
    11 EXPX    K X,Y
    12         Q
    13         ;
    14 MW(PSODIR)      ;
    15         K DIR,DIC
    16         S DIR(0)="52,11"
    17         S DIR("B")=$S($G(PSORX("MAIL/WINDOW"))]"":PSORX("MAIL/WINDOW"),1:"WINDOW")
    18         D DIR G:PSODIR("DFLG")!PSODIR("FIELD") MWX
    19         I $G(Y(0))']"" S PSODIR("DFLG")=1 G MWX
    20         S PSODIR("MAIL/WINDOW")=Y,PSORX("MAIL/WINDOW")=Y(0)
    21         I $G(PSORX("EDIT"))]"",PSODIR("MAIL/WINDOW")'="W" K PSODIR("METHOD OF PICK-UP")
    22 MW1     G:PSODIR("MAIL/WINDOW")'="W"!('$P($G(PSOPAR),"^",12)) MWX
    23         S DIR(0)="52,35O"
    24         S:$G(PSORX("METHOD OF PICK-UP"))]"" DIR("B")=PSORX("METHOD OF PICK-UP")
    25         D DIR G:PSODIR("DFLG") MWX
    26         I X[U W !,"Cannot jump to another field ..",! G MW1
    27         S (PSODIR("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y
    28 MWX     K X,Y
    29         Q
    30         ;
    31 FILLDT(PSODIR)  ;
    32         K DIR,DIC
    33         S DIR("A")="FILL DATE",DIR("B")=$S($G(PSORX("FILL DATE"))]"":PSORX("FILL DATE"),1:"TODAY")
    34         S DIR(0)="D^"_$S($G(PSODIR("ISSUE DATE"))]"":PSODIR("ISSUE DATE"),1:DT)_$S($G(DUZ("AG"))="I":":"_DT_":EX",1:"::EX")
    35         S DIR("?",1)="The earliest fill date allowed is determined by the ISSUE DATE,"
    36         S DIR("?",2)="the FILL DATE cannot be before the ISSUE DATE."
    37         S DIR("?")="Both the month and date are required."
    38         D DIR G:PSODIR("DFLG")!PSODIR("FIELD") FILLDTX
    39         S PSODIR("FILL DATE")=Y
    40         X ^DD("DD") S PSORX("FILL DATE")=Y
    41 FILLDTX K X,Y
    42         Q
    43         ;
    44 CLERK(PSODIR)   ;
    45         I $G(DUZ("AG"))'="I",$G(DUZ) S PSODIR("CLERK CODE")=DUZ,PSORX("CLERK CODE")=$P($G(^VA(200,DUZ,0)),"^") G CLERKX
    46         K DIR,DIC
    47         S DIR("A")="CLERK",DIR("B")=$S($G(PSORX("CLERK CODE"))]"":PSORX("CLERK CODE"),1:$P($G(^VA(200,DUZ,0)),"^",2)),DIR(0)="52,16"
    48         D DIR G:PSODIR("DFLG")!PSODIR("FIELD") CLERKX
    49         S PSODIR("CLERK CODE")=+Y,PSORX("CLERK CODE")=$P(Y,"^")
    50 CLERKX  Q
    51         ;
    52 DIR     ;
    53         S PSODIR("FIELD")=0
    54         G:$G(DIR(0))']"" DIRX
    55         D ^DIR K DIR,DIE,DIC,DA
    56         I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1!(Y="") S PSODIR("DFLG")=1 G DIRX
    57         I X[U,$L(X)>1 D JUMP
    58 DIRX    K DIRUT,DTOUT,DUOUT,DIROUT,PSOX
    59         Q
    60         ;
    61 JUMP    ;
    62         I $G(PSOEDIT)!($G(OR0)) S PSODIR("DFLG")=1 Q
    63         S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC
    64         I Y=-1 S PSODIR("FIELD")=PSODIR("FLD") G JUMPX
    65         I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX
    66         I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX
    67         I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX
    68 JUMPX   S X="^"_X
    69         Q
    70         ;Continued from PSODIR1, Tag REFOR, Added PSOCS set and changed G REFILLX references to a QUIT
    71 REFOR   ;
    72         F DEA=1:1 Q:$E($G(PSODRUG("DEA")),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSOCS,"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSOCS,"^",2)=1
    73         I $G(PSOCS) D
    74         .S (PSOX,PSOMAX)=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,$D(CLOZPAT):0,1:5)
    75         .S PSOX=$S('PSOX:0,PSODIR("DAYS SUPPLY")=90:1,1:PSOX),PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
    76         E  D
    77         .S (PSOX,PSOMAX)=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,$D(CLOZPAT):0,1:11)
    78         .S PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
    79         K PSOELSE I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F")!($G(PSODRUG("DEA"))[1)!($G(PSODRUG("DEA"))[2) D  Q
    80         .S VALMSG="No refills allowed on "_$S($G(PSODRUG("DEA"))["A":"this narcotic drug.",1:"this drug.")
    81         .W !,VALMSG,!
    82         .S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0
    83         I $D(CLOZPAT) D
    84         .S PSOX=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,1:0)
    85         .S (PSODIR("# OF REFILLS"),PSODIR("N# REF"))=PSOX
    86         S DIR(0)="N^0:"_PSOX,DIR("A")="# OF REFILLS"
    87         S DIR("B")=$S($G(POERR)&($G(PSODIR("# OF REFILLS"))):PSODIR("# OF REFILLS"),$G(PSODIR("N# REF"))]"":PSODIR("N# REF"),$G(PSODIR("# OF REFILLS"))]"":PSODIR("# OF REFILLS"),$G(PSOX1)]""&(PSOX>PSOX1):PSOX1,1:PSOX)
    88         S DIR("?")="Enter a whole number.  The maximum is set by the DAYS SUPPLY field."
    89         D DIR Q:PSODIR("DFLG")!PSODIR("FIELD")
    90         S (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=Y
    91         Q
     1PSODIR3 ;ISC-BIRM/SAB - rx order entry contd ;09/27/96
     2 ;;7.0;OUTPATIENT PHARMACY;**3,46,184,222**;DEC 1997;Build 12
     3 ;
     4EXP(PSODIR) ;
     5 K DIC,DIR
     6 I $G(PSODRUG("EXPIRATION DATE"))]"" S Y=PSODRUG("EXPIRATION DATE") X ^DD("DD") S PSORX("EXPIRATION DATE")=Y
     7 S DIR("A")="EXPIRES",DIR("B")=$S($G(PSORX("EXPIRATION DATE"))]"":PSORX("EXPIRATION DATE"),1:"T+6M")
     8 S DIR(0)="D^NOW::EX",DIR("?")="Both the month and date are required." D ^DIR
     9 G:PSODIR("DFLG")!PSODIR("FIELD") EXPX
     10 S PSODIR("EXPIRATION DATE")=Y
     11EXPX K X,Y
     12 Q
     13 ;
     14MW(PSODIR) ;
     15 K DIR,DIC
     16 S DIR(0)="52,11"
     17 S DIR("B")=$S($G(PSORX("MAIL/WINDOW"))]"":PSORX("MAIL/WINDOW"),1:"WINDOW")
     18 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") MWX
     19 I $G(Y(0))']"" S PSODIR("DFLG")=1 G MWX
     20 S PSODIR("MAIL/WINDOW")=Y,PSORX("MAIL/WINDOW")=Y(0)
     21 I $G(PSORX("EDIT"))]"",PSODIR("MAIL/WINDOW")'="W" K PSODIR("METHOD OF PICK-UP")
     22MW1 G:PSODIR("MAIL/WINDOW")'="W"!('$P($G(PSOPAR),"^",12)) MWX
     23 S DIR(0)="52,35O"
     24 S:$G(PSORX("METHOD OF PICK-UP"))]"" DIR("B")=PSORX("METHOD OF PICK-UP")
     25 D DIR G:PSODIR("DFLG") MWX
     26 I X[U W !,"Cannot jump to another field ..",! G MW1
     27 S (PSODIR("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y
     28MWX K X,Y
     29 Q
     30 ;
     31FILLDT(PSODIR) ;
     32 K DIR,DIC
     33 S DIR("A")="FILL DATE",DIR("B")=$S($G(PSORX("FILL DATE"))]"":PSORX("FILL DATE"),1:"TODAY")
     34 S DIR(0)="D^"_$S($G(PSODIR("ISSUE DATE"))]"":PSODIR("ISSUE DATE"),1:DT)_$S($G(DUZ("AG"))="I":":"_DT_":EX",1:"::EX")
     35 S DIR("?",1)="The earliest fill date allowed is determined by the ISSUE DATE,"
     36 S DIR("?",2)="the FILL DATE cannot be before the ISSUE DATE."
     37 S DIR("?")="Both the month and date are required."
     38 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") FILLDTX
     39 S PSODIR("FILL DATE")=Y
     40 X ^DD("DD") S PSORX("FILL DATE")=Y
     41FILLDTX K X,Y
     42 Q
     43 ;
     44CLERK(PSODIR) ;
     45 I $G(DUZ("AG"))'="I",$G(DUZ) S PSODIR("CLERK CODE")=DUZ,PSORX("CLERK CODE")=$P($G(^VA(200,DUZ,0)),"^") G CLERKX
     46 K DIR,DIC
     47 S DIR("A")="CLERK",DIR("B")=$S($G(PSORX("CLERK CODE"))]"":PSORX("CLERK CODE"),1:$P($G(^VA(200,DUZ,0)),"^",2)),DIR(0)="52,16"
     48 D DIR G:PSODIR("DFLG")!PSODIR("FIELD") CLERKX
     49 S PSODIR("CLERK CODE")=+Y,PSORX("CLERK CODE")=$P(Y,"^")
     50CLERKX Q
     51 ;
     52DIR ;
     53 S PSODIR("FIELD")=0
     54 G:$G(DIR(0))']"" DIRX
     55 D ^DIR K DIR,DIE,DIC,DA
     56 I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1!(Y="") S PSODIR("DFLG")=1 G DIRX
     57 I X[U,$L(X)>1 D JUMP
     58DIRX K DIRUT,DTOUT,DUOUT,DIROUT,PSOX
     59 Q
     60 ;
     61JUMP ;
     62 I $G(PSOEDIT)!($G(OR0)) S PSODIR("DFLG")=1 Q
     63 S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC
     64 I Y=-1 S PSODIR("FIELD")=PSODIR("FLD") G JUMPX
     65 I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX
     66 I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX
     67 I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX
     68JUMPX S X="^"_X
     69 Q
     70 ;Continued from PSODIR1, Tag REFOR, Added PSOCS set and changed G REFILLX references to a QUIT
     71REFOR ;
     72 F DEA=1:1 Q:$E($G(PSODRUG("DEA")),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSOCS,"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSOCS,"^",2)=1
     73 I $G(PSOCS) D
     74 .S (PSOX,PSOMAX)=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,$D(CLOZPAT):0,1:5)
     75 .S PSOX=$S('PSOX:0,PSODIR("DAYS SUPPLY")=90:1,1:PSOX),PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
     76 E  D
     77 .S (PSOX,PSOMAX)=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,$D(CLOZPAT):0,1:11)
     78 .S PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
     79 K PSOELSE I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F") D  Q
     80 .S VALMSG="No refills allowed on "_$S($G(PSODRUG("DEA"))["F":"this drug.",1:"Narcotics ..")
     81 .W !,VALMSG,!
     82 .S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0
     83 I $D(CLOZPAT) D
     84 .S PSOX=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,1:0)
     85 .S (PSODIR("# OF REFILLS"),PSODIR("N# REF"))=PSOX
     86 S DIR(0)="N^0:"_PSOX,DIR("A")="# OF REFILLS"
     87 S DIR("B")=$S($G(POERR)&($G(PSODIR("# OF REFILLS"))):PSODIR("# OF REFILLS"),$G(PSODIR("N# REF"))]"":PSODIR("N# REF"),$G(PSODIR("# OF REFILLS"))]"":PSODIR("# OF REFILLS"),$G(PSOX1)]""&(PSOX>PSOX1):PSOX1,1:PSOX)
     88 S DIR("?")="Enter a whole number.  The maximum is set by the DAYS SUPPLY field."
     89 D DIR Q:PSODIR("DFLG")!PSODIR("FIELD")
     90 S (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=Y
     91 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODISP.m

    r613 r623  
    1 PSODISP ;BIR/SAB,PWC-MANUAL BARCODE RELEASE FUNCTION ;03/02/93
    2         ;;7.0;OUTPATIENT PHARMACY;**15,71,131,156,185,148,247,200,208**;DEC 1997;Build 41
    3         ; Modified from FOIA VISTA,
    4         ; Copyright (C) 2007 WorldVistA
    5         ;
    6         ; This program is free software; you can redistribute it and/or modify
    7         ; it under the terms of the GNU General Public License as published by
    8         ; the Free Software Foundation; either version 2 of the License, or
    9         ; (at your option) any later version.
    10         ;
    11         ; This program is distributed in the hope that it will be useful,
    12         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ; GNU General Public License for more details.
    15         ;
    16         ; You should have received a copy of the GNU General Public License
    17         ; along with this program; if not, write to the Free Software
    18         ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    19         ;Reference to $$SERV^IBARX1 supported by DBIA 2245
    20         ;Reference to ^PSD(58.8 supported by DBIA 1036
    21         ;Reference to ^PS(55 supported by DBIA 2228
    22         ;Reference to ^PSDRUG supported by DBIA 221
    23         ;Reference to ^PSDRUG("AQ" supported by DBIA 3165
    24         ;Reference to ^XTMP("PSA" supported by DBIA 1036
    25         ;Reference to ^PS(59.7 supported by DBIA 694
    26         ;Reference to ^DIC(19.2 supported by DBIA 1064
    27 AC      K CX,PSODA,PSODT,PSRH,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSOPID
    28         K ^UTILITY($J,"PSOHL") S PSOPID=1
    29         I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,?5,"Site Parameters must be defined to use the Release option!",! G EXIT
    30         S Y=$G(^PS(59,PSOSITE,"IB")),PSOIBSS=$$SERV^IBARX1(+Y) I 'PSOIBSS D IBSSR^PSOUTL I 'PSOIBFL D   G EXIT
    31         .W $C(7),!!,"The IB SERVICE/SECTION defined in your site parameter file is not valid.",!,"You will not be able to release any medication until this is corrected!",!
    32 AC1     I $G(PSOAFYN)'="Y" W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2) ;vfah - VOE
    33         I $G(PSOAFYN)="Y" S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2) ;vfah - VOE
    34         I $G(PSOAFYN)'="Y" S DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))",DIC("A")="Enter PHARMACIST: ",DIC="^VA(200,",DIC(0)="QEAM" D ^DIC G:"^"[X EXIT K DIC G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(Y=-1) EXIT S PSRH=+Y ;vfah - VOE
    35         I $G(PSOAFYN)="Y" S PSRH=DUZ,PSZAR="0" ;vfah - VOE
    36         ;check for Drug Acct background job K8 & K7.1
    37         S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19.2 D ^DIC I Y=-1 K DIC,X,Y G BC
    38         I $P($G(Y(0)),U,2)>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT G BC
    39         S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19 D ^DIC K DIC,X G:Y=-1 BC
    40         K DIQ,PSA S DA=+Y,DIC=19,DIQ="PSA",DR=200,DIQ(0)="IN" D EN^DIQ1
    41         I '$D(PSA(19,DA,200,"I")) K DIC,DA,X,Y,DIQ G BC
    42         I PSA(19,DA,200,"I")>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT
    43         K PSA,DIC,DA,X,Y,DIQ
    44 BC      ;
    45         I $G(PSOAFYN)="Y",$G(PSZAR)="1" Q  ;vfah - VOE
    46         K MAN I $G(RXP),$D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
    47         I $G(PSOAFYN)'="Y" Q:$G(POERR)  W !! K CMOP,ISUF,DIR,LBL,LBLP S DIR("A")="Enter/Wand PRESCRIPTION number",DIR("?")="^D HELP^PSODISP",DIR(0)="FO" D ^DIR ;vfah - VOE
    48         I $G(PSOAFYN)="Y" S X=RXN,PSZAR="1" ;vfah - VOE
    49         I $D(DIRUT)!($D(DTOUT))!($D(DUOUT)) K DIRUT,DTOUT,DUOUT G AC1
    50         I X'["-" D BCI W:'$G(RXP) !,"INVALID PRESCRIPTION NUMBER" G:'$G(RXP) BC S MAN=1 G BC1
    51         I X["-",$P(X,"-")'=$P($$SITE^VASITE(),"^",3) W !?7,$C(7),$C(7),"   INVALID STATION NUMBER !!",$C(7),$C(7),! G BC
    52         I X["-" S RXP=$P(X,"-",2) I '$D(^PSRX(+$G(RXP),0))!($G(RXP)']"") W !?7,$C(7),$C(7),$C(7),"   NON-EXISTENT PRESCRIPTION" G BC
    53         I $D(^PSRX(RXP,0)) D  G BC1
    54         .S PSOLOUD=1 D:$P($G(^PS(55,+$P(^PSRX(+RXP,0),"^",2),0)),"^",6)'=2 EN^PSOHLUP($P(^PSRX(+RXP,0),"^",2)) K PSOLOUD
    55         W !?7,$C(7),$C(7),$C(7),"   IMPROPER BARCODE FORMAT" G BC
    56 BC1     ;
    57         D ICN^PSODPT(+$P(^PSRX(RXP,0),"^",2))
    58         I +$P($G(^PSRX(+RXP,"PKI")),"^") D  Q:$G(POERR)  G BC
    59         .I $G(SPEED) W !!?7,$C(7),$C(7),"Rx# "_$P(^PSRX(RXP,0),"^") S PSOLIST=4
    60         .W !!,?7,"UNABLE TO RELEASE - THIS ORDER MUST BE RELEASED THROUGH THE OUTPATIENT",!,?7,"RX'S [PSD OUTPATIENT] OPTION IN THE CONTROLLED SUBSTANCE MENU"
    61         I +$P($G(^PSRX(+RXP,"STA")),"^")=13!(+$P($G(^PSRX(+RXP,0)),"^",2)=0) W !?7,$C(7),$C(7),"    PRESCRIPTION IS A DELETED PRESCRIPTION NUMBER" Q:$G(POERR)  D DCHK G BC
    62         I +$P($G(^PSRX(+RXP,"STA")),"^"),$S($P(^("STA"),"^")=2:0,$P(^("STA"),"^")=5:0,$P(^("STA"),"^")=11:0,$P(^("STA"),"^")=12:0,$P(^("STA"),"^")=14:0,$P(^("STA"),"^")=15:0,1:1) D STAT^PSODISPS Q:$G(POERR)  D DCHK G BC
    63         ;drug stocked in Drug Acct Location?
    64         S PSODA(1)=$S($D(^PSD(58.8,+$O(^PSD(58.8,"AOP",+PSOSITE,0)),1,+$P(^PSRX(RXP,0),U,6))):1,1:0)
    65         I $P(^PSRX(RXP,2),"^",13) S Y=$P(^PSRX(RXP,2),"^",13) X ^DD("DD") S OUT=1 D  K OUT Q:$G(POERR)  D DCHK G BC
    66         .W !!?7,$C(7),$C(7),$S($G(SPEED):"Rx# "_$P(^PSRX(RXP,0),"^"),1:"Original prescription")_" was last released on "_Y,!?7,"Checking for unreleased refills/partials " D REF
    67 BATCH   ;
    68         I $P(^PSRX(RXP,2),"^",15),'$P(^(2),"^",14) S RESK=$P(^(2),"^",15)  W !!?5,"Rx# "_$P(^PSRX(RXP,0),"^")_" Original Fill returned to stock on "_$E(RESK,4,5)_"/"_$E(RESK,6,7)_"/"_$E(RESK,2,3),! G REF
    69         ;flag to determine if site is running HL7 v.2.4 Dispense Machines
    70         N PSODISP S PSODISP=$$GET1^DIQ(59,PSOSITE_",",105,"I")
    71         S PSOCPN=$P(^PSRX(RXP,0),"^",2),QTY=$P($G(^PSRX(RXP,0)),"^",7),QDRUG=$P(^PSRX(RXP,0),"^",6)
    72         ;original
    73         I '$P($G(^PSRX(RXP,2)),"^",13),+$P($G(^(2)),"^",2)'<PSIN S RXFD=$P(^(2),"^",2) D  D:$G(LBLP) UPDATE I $G(ISUF) D UPDATE G REF
    74         .S SUPN=$O(^PS(52.5,"B",RXP,0)) I SUPN,$D(^PS(52.5,"C",RXFD,SUPN)),$G(^PS(52.5,SUPN,"P"))'=1,'$P($G(^(0)),"^",5) S ISUF=1 Q
    75         .I $D(^PSDRUG("AQ",QDRUG)) K CMOP D OREL^PSOCMOPB(RXP) K CMOP I $G(ISUF) K ISUF,CMOP Q
    76         .;
    77         .F LBL=0:0 S LBL=$O(^PSRX(RXP,"L",LBL)) Q:'LBL  I '+$P(^PSRX(RXP,"L",LBL,0),"^",2),'$P(^(0),"^",5),$P(^(0),"^",3)'["INTERACTION" S LBLP=1
    78         .D CHKADDR^PSODISPS(RXP)
    79         .Q:'$G(LBLP)
    80         .;
    81         .; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects / NDC Editing
    82         .I $$MANREL^PSOBPSUT(RXP,0,$G(PSOPID))="^" K LBLP Q
    83         .;
    84         .S:$D(^PSDRUG(QDRUG,660.1))&($G(PSOAFYN)'="Y") ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY ;vfah - VOE
    85         .D NOW^%DTC S DIE="^PSRX(",DA=RXP,DR="31///"_%_";23////"_PSRH_";32.1///@;32.2///@",PSODT=% D ^DIE K DIE,DR,DA,LBL
    86         .;
    87         .; - Notifying IB through ECME of the Rx has been released
    88         .D IBSEND^PSOBPSUT(RXP,0)
    89         .;
    90         .D EN^PSOHLSN1(RXP,"ZD")
    91         .;if appropriate update ^XTMP("PSA", for Drug Acct
    92         .I $G(PSODA),$G(PSODA(1)),'$D(^PSRX("AR",+PSODT,+RXP,0)) S ^XTMP("PSA",+PSOSITE,+QDRUG,+DT)=$G(^XTMP("PSA",+PSOSITE,+QDRUG,+DT))+QTY
    93 REF     ;release refills and partials
    94         K LBLP,IFN F XTYPE=1,"P" K IFN D QTY^PSODISPS
    95         Q:+$G(OUT)!($G(POERR))  D DCHK
    96         G BC
    97 UPDATE  I $G(ISUF) W $C(7),!!?7,"Prescription "_$P(^PSRX(RXP,0),"^")_" - Original Fill on Suspense !",!,$C(7) Q
    98         N BFILL S BFILL=0
    99         S PSOCPRX=$P(^PSRX(RXP,0),"^") D CP^PSOCP
    100         I $G(PSOAFYN)'="Y" W !?7,"Prescription Number "_$P(^PSRX(RXP,0),"^")_" Released" ;vfah - VOE
    101         ;initialize bingo board variables
    102         I $G(LBLP),$P(^PSRX(RXP,0),"^",11)["W" S BINGRO="W",BINGNAM=$P(^PSRX(RXP,0),"^",2),BINGDIV=$P(^PSRX(RXP,2),"^",9)
    103         I $G(PSODISP)=2.4 D    ;HL7 v2.4 dispensing machines
    104         . F I=0:0 S SUB=$O(^PSRX(RXP,"A",I)) Q:'I  I $P(^PSRX(RXP,"A",I,0),"^",2)="N" D XMIT    ;only send release dt/time transmission for dispensed orders
    105         Q
    106 EXIT    ;
    107         K OUT,RX2,RXFD,RESK,ISUF,SUPN,%,DIC,IFN,J,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,PSOIBSS,PSOIBFL,PSOIBLP,PSOIBST,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSRH,XX,Y,PSIN,MAN,PSODISP,SUB
    108         Q
    109 GETFILL ; get the fill number
    110         S NFLD=0,UU="" F  S UU=$O(^PSRX(+RXP,1,UU)) Q:UU=""  S:$D(^PSRX(+RXP,1,UU,0)) NFLD=NFLD+1
    111         Q
    112 HELP    W !!,"Wand the barcode number of the prescription or manually key in",!,"the number below the barcode or the prescription number.",!,"The barcode number should be of the format - 'NNN-NNNNNNN'"
    113         Q
    114 BCI     S RXP=0
    115 RXP     S RXP=$O(^PSRX("B",X,RXP)) I $P($G(^PSRX(+RXP,"STA")),"^")=13 G RXP ;GET RECORD NUMBER FROM SCRIPT NUMBER
    116         Q
    117 DCHK    ;checks for duplicate
    118         Q:'$G(MAN)
    119         I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
    120         S RXP=$O(^PSRX("B",$P(^PSRX(RXP,0),"^"),RXP)) I 'RXP K POERR,MAN Q
    121         I $P($G(^PSRX(RXP,"STA")),"^")=13 G DCHK
    122         I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
    123         W !!,"Duplicate Rx # "_$P(^PSRX(RXP,0),"^")_" found."
    124         S POERR=1 D BC1^PSODISP
    125         I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
    126         G DCHK
    127         Q
    128 XMIT    D NOW^%DTC S PSODTM=%
    129         S IDGN=$P(^PSRX(+RXP,0),"^",6)
    130         K ^UTILITY($J,"PSOHL")
    131         S ^UTILITY($J,"PSOHL",1)=+RXP_"^"_IDGN_"^"_PSODTM_"^"_+$G(PDUZ)_"^0^^PSO DISP^^^"_FP_"^"_FPN
    132         S ZTRTN="INIT^PSORELDT",ZTDESC="EXTERNAL INTERFACE FOR RELEASE DATE/TIME",ZTIO="",ZTDTH=$H,ZTSAVE("^UTILITY($J,""PSOHL"",")="",ZTSAVE("PSOSITE")="",ZTSAVE("RXP")="",ZTSAVE("PSOLAP")="" D ^%ZTLOAD K ^UTILITY($J,"PSOHL")
    133         Q
     1PSODISP ;BIR/SAB,PWC-MANUAL BARCODE RELEASE FUNCTION ;03/02/93
     2 ;;7.0;OUTPATIENT PHARMACY;**15,71,131,156,185,148,247,200,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 ;Reference to $$SERV^IBARX1 supported by DBIA 2245
     20 ;Reference to ^PSD(58.8 supported by DBIA 1036
     21 ;Reference to ^PS(55 supported by DBIA 2228
     22 ;Reference to ^PSDRUG supported by DBIA 221
     23 ;Reference to ^PSDRUG("AQ" supported by DBIA 3165
     24 ;Reference to ^XTMP("PSA" supported by DBIA 1036
     25 ;Reference to ^PS(59.7 supported by DBIA 694
     26 ;Reference to ^DIC(19.2 supported by DBIA 1064
     27AC K CX,PSODA,PSODT,PSRH,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSOPID
     28 K ^UTILITY($J,"PSOHL") S PSOPID=1
     29 I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,?5,"Site Parameters must be defined to use the Release option!",! G EXIT
     30 S Y=$G(^PS(59,PSOSITE,"IB")),PSOIBSS=$$SERV^IBARX1(+Y) I 'PSOIBSS D IBSSR^PSOUTL I 'PSOIBFL D   G EXIT
     31 .W $C(7),!!,"The IB SERVICE/SECTION defined in your site parameter file is not valid.",!,"You will not be able to release any medication until this is corrected!",!
     32AC1 I $G(PSOAFYN)'="Y" W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2) ;vfah - VOE
     33 I $G(PSOAFYN)="Y" S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2) ;vfah - VOE
     34 I $G(PSOAFYN)'="Y" S DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))",DIC("A")="Enter PHARMACIST: ",DIC="^VA(200,",DIC(0)="QEAM" D ^DIC G:"^"[X EXIT K DIC G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(Y=-1) EXIT S PSRH=+Y ;vfah - VOE
     35 I $G(PSOAFYN)="Y" S PSRH=DUZ,PSZAR="0" ;vfah - VOE
     36 ;check for Drug Acct background job K8 & K7.1
     37 S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19.2 D ^DIC I Y=-1 K DIC,X,Y G BC
     38 I $P($G(Y(0)),U,2)>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT G BC
     39 S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19 D ^DIC K DIC,X G:Y=-1 BC
     40 K DIQ,PSA S DA=+Y,DIC=19,DIQ="PSA",DR=200,DIQ(0)="IN" D EN^DIQ1
     41 I '$D(PSA(19,DA,200,"I")) K DIC,DA,X,Y,DIQ G BC
     42 I PSA(19,DA,200,"I")>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT
     43 K PSA,DIC,DA,X,Y,DIQ
     44BC ;
     45 I $G(PSOAFYN)="Y",$G(PSZAR)="1" Q  ;vfah - VOE
     46 K MAN I $G(RXP),$D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
     47 I $G(PSOAFYN)'="Y" Q:$G(POERR)  W !! K CMOP,ISUF,DIR,LBL,LBLP S DIR("A")="Enter/Wand PRESCRIPTION number",DIR("?")="^D HELP^PSODISP",DIR(0)="FO" D ^DIR ;vfah - VOE
     48 I $G(PSOAFYN)="Y" S X=RXN,PSZAR="1" ;vfah - VOE
     49 I $D(DIRUT)!($D(DTOUT))!($D(DUOUT)) K DIRUT,DTOUT,DUOUT G AC1
     50 I X'["-" D BCI W:'$G(RXP) !,"INVALID PRESCRIPTION NUMBER" G:'$G(RXP) BC S MAN=1 G BC1
     51 I X["-",$P(X,"-")'=$P($$SITE^VASITE(),"^",3) W !?7,$C(7),$C(7),"   INVALID STATION NUMBER !!",$C(7),$C(7),! G BC
     52 I X["-" S RXP=$P(X,"-",2) I '$D(^PSRX(+$G(RXP),0))!($G(RXP)']"") W !?7,$C(7),$C(7),$C(7),"   NON-EXISTENT PRESCRIPTION" G BC
     53 I $D(^PSRX(RXP,0)) D  G BC1
     54 .S PSOLOUD=1 D:$P($G(^PS(55,+$P(^PSRX(+RXP,0),"^",2),0)),"^",6)'=2 EN^PSOHLUP($P(^PSRX(+RXP,0),"^",2)) K PSOLOUD
     55 W !?7,$C(7),$C(7),$C(7),"   IMPROPER BARCODE FORMAT" G BC
     56BC1 ;
     57 D ICN^PSODPT(+$P(^PSRX(RXP,0),"^",2))
     58 I +$P($G(^PSRX(+RXP,"PKI")),"^") D  Q:$G(POERR)  G BC
     59 .I $G(SPEED) W !!?7,$C(7),$C(7),"Rx# "_$P(^PSRX(RXP,0),"^") S PSOLIST=4
     60 .W !!,?7,"UNABLE TO RELEASE - THIS ORDER MUST BE RELEASED THROUGH THE OUTPATIENT",!,?7,"RX'S [PSD OUTPATIENT] OPTION IN THE CONTROLLED SUBSTANCE MENU"
     61 I +$P($G(^PSRX(+RXP,"STA")),"^")=13!(+$P($G(^PSRX(+RXP,0)),"^",2)=0) W !?7,$C(7),$C(7),"    PRESCRIPTION IS A DELETED PRESCRIPTION NUMBER" Q:$G(POERR)  D DCHK G BC
     62 I +$P($G(^PSRX(+RXP,"STA")),"^"),$S($P(^("STA"),"^")=2:0,$P(^("STA"),"^")=5:0,$P(^("STA"),"^")=11:0,$P(^("STA"),"^")=12:0,$P(^("STA"),"^")=14:0,$P(^("STA"),"^")=15:0,1:1) D STAT^PSODISPS Q:$G(POERR)  D DCHK G BC
     63 ;drug stocked in Drug Acct Location?
     64 S PSODA(1)=$S($D(^PSD(58.8,+$O(^PSD(58.8,"AOP",+PSOSITE,0)),1,+$P(^PSRX(RXP,0),U,6))):1,1:0)
     65 I $P(^PSRX(RXP,2),"^",13) S Y=$P(^PSRX(RXP,2),"^",13) X ^DD("DD") S OUT=1 D  K OUT Q:$G(POERR)  D DCHK G BC
     66 .W !!?7,$C(7),$C(7),$S($G(SPEED):"Rx# "_$P(^PSRX(RXP,0),"^"),1:"Original prescription")_" was last released on "_Y,!?7,"Checking for unreleased refills/partials " D REF
     67BATCH ;
     68 I $P(^PSRX(RXP,2),"^",15),'$P(^(2),"^",14) S RESK=$P(^(2),"^",15)  W !!?5,"Rx# "_$P(^PSRX(RXP,0),"^")_" Original Fill returned to stock on "_$E(RESK,4,5)_"/"_$E(RESK,6,7)_"/"_$E(RESK,2,3),! G REF
     69 ;flag to determine if site is running HL7 v.2.4 Dispense Machines
     70 N PSODISP S PSODISP=$$GET1^DIQ(59,PSOSITE_",",105,"I")
     71 S PSOCPN=$P(^PSRX(RXP,0),"^",2),QTY=$P($G(^PSRX(RXP,0)),"^",7),QDRUG=$P(^PSRX(RXP,0),"^",6)
     72 ;original
     73 I '$P($G(^PSRX(RXP,2)),"^",13),+$P($G(^(2)),"^",2)'<PSIN S RXFD=$P(^(2),"^",2) D  D:$G(LBLP) UPDATE I $G(ISUF) D UPDATE G REF
     74 .S SUPN=$O(^PS(52.5,"B",RXP,0)) I SUPN,$D(^PS(52.5,"C",RXFD,SUPN)),$G(^PS(52.5,SUPN,"P"))'=1,'$P($G(^(0)),"^",5) S ISUF=1 Q
     75 .I $D(^PSDRUG("AQ",QDRUG)) K CMOP D OREL^PSOCMOPB(RXP) K CMOP I $G(ISUF) K ISUF,CMOP Q
     76 .;
     77 .F LBL=0:0 S LBL=$O(^PSRX(RXP,"L",LBL)) Q:'LBL  I '+$P(^PSRX(RXP,"L",LBL,0),"^",2),'$P(^(0),"^",5),$P(^(0),"^",3)'["INTERACTION" S LBLP=1
     78 .D CHKADDR^PSODISPS(RXP)
     79 .Q:'$G(LBLP)
     80 .;
     81 .; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects / NDC Editing
     82 .I $$MANREL^PSOBPSUT(RXP,0,$G(PSOPID))="^" K LBLP Q
     83 .;
     84 .S:$D(^PSDRUG(QDRUG,660.1))&($G(PSOAFYN)'="Y") ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY ;vfah - VOE
     85 .D NOW^%DTC S DIE="^PSRX(",DA=RXP,DR="31///"_%_";23////"_PSRH_";32.1///@;32.2///@",PSODT=% D ^DIE K DIE,DR,DA,LBL
     86 .;
     87 .; - Notifying IB through ECME of the Rx has been released
     88 .D IBSEND^PSOBPSUT(RXP,0)
     89 .;
     90 .D EN^PSOHLSN1(RXP,"ZD")
     91 .;if appropriate update ^XTMP("PSA", for Drug Acct
     92 .I $G(PSODA),$G(PSODA(1)),'$D(^PSRX("AR",+PSODT,+RXP,0)) S ^XTMP("PSA",+PSOSITE,+QDRUG,+DT)=$G(^XTMP("PSA",+PSOSITE,+QDRUG,+DT))+QTY
     93REF ;release refills and partials
     94 K LBLP,IFN F XTYPE=1,"P" K IFN D QTY^PSODISPS
     95 Q:+$G(OUT)!($G(POERR))  D DCHK
     96 G BC
     97UPDATE I $G(ISUF) W $C(7),!!?7,"Prescription "_$P(^PSRX(RXP,0),"^")_" - Original Fill on Suspense !",!,$C(7) Q
     98 N BFILL S BFILL=0
     99 S PSOCPRX=$P(^PSRX(RXP,0),"^") D CP^PSOCP
     100 I $G(PSOAFYN)'="Y" W !?7,"Prescription Number "_$P(^PSRX(RXP,0),"^")_" Released" ;vfah - VOE
     101 ;initialize bingo board variables
     102 I $G(LBLP),$P(^PSRX(RXP,0),"^",11)["W" S BINGRO="W",BINGNAM=$P(^PSRX(RXP,0),"^",2),BINGDIV=$P(^PSRX(RXP,2),"^",9)
     103 I $G(PSODISP)=2.4 D    ;HL7 v2.4 dispensing machines
     104 . F I=0:0 S SUB=$O(^PSRX(RXP,"A",I)) Q:'I  I $P(^PSRX(RXP,"A",I,0),"^",2)="N" D XMIT    ;only send release dt/time transmission for dispensed orders
     105 Q
     106EXIT ;
     107 K OUT,RX2,RXFD,RESK,ISUF,SUPN,%,DIC,IFN,J,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,PSOIBSS,PSOIBFL,PSOIBLP,PSOIBST,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSRH,XX,Y,PSIN,MAN,PSODISP,SUB
     108 Q
     109GETFILL ; get the fill number
     110 S NFLD=0,UU="" F  S UU=$O(^PSRX(+RXP,1,UU)) Q:UU=""  S:$D(^PSRX(+RXP,1,UU,0)) NFLD=NFLD+1
     111 Q
     112HELP W !!,"Wand the barcode number of the prescription or manually key in",!,"the number below the barcode or the prescription number.",!,"The barcode number should be of the format - 'NNN-NNNNNNN'"
     113 Q
     114BCI S RXP=0
     115RXP S RXP=$O(^PSRX("B",X,RXP)) I $P($G(^PSRX(+RXP,"STA")),"^")=13 G RXP ;GET RECORD NUMBER FROM SCRIPT NUMBER
     116 Q
     117DCHK ;checks for duplicate
     118 Q:'$G(MAN)
     119 I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
     120 S RXP=$O(^PSRX("B",$P(^PSRX(RXP,0),"^"),RXP)) I 'RXP K POERR,MAN Q
     121 I $P($G(^PSRX(RXP,"STA")),"^")=13 G DCHK
     122 I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
     123 W !!,"Duplicate Rx # "_$P(^PSRX(RXP,0),"^")_" found."
     124 S POERR=1 D BC1^PSODISP
     125 I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
     126 G DCHK
     127 Q
     128XMIT D NOW^%DTC S PSODTM=%
     129 S IDGN=$P(^PSRX(+RXP,0),"^",6)
     130 K ^UTILITY($J,"PSOHL")
     131 S ^UTILITY($J,"PSOHL",1)=+RXP_"^"_IDGN_"^"_PSODTM_"^"_+$G(PDUZ)_"^0^^PSO DISP^^^"_FP_"^"_FPN
     132 S ZTRTN="INIT^PSORELDT",ZTDESC="EXTERNAL INTERFACE FOR RELEASE DATE/TIME",ZTIO="",ZTDTH=$H,ZTSAVE("^UTILITY($J,""PSOHL"",")="",ZTSAVE("PSOSITE")="",ZTSAVE("RXP")="",ZTSAVE("PSOLAP")="" D ^%ZTLOAD K ^UTILITY($J,"PSOHL")
     133 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODISPS.m

    r613 r623  
    1 PSODISPS        ;BIR/SAB-CONTINUATION OF RELEASE FUNCTION ;3/2/93
    2         ;;7.0;OUTPATIENT PHARMACY;**15,13,9,27,67,71,156,118,148,247,200,208**;DEC 1997;Build 41
    3         ; Modified from FOIA VISTA,
    4         ; Copyright (C) 2007 WorldVistA
    5         ;
    6         ; This program is free software; you can redistribute it and/or modify
    7         ; it under the terms of the GNU General Public License as published by
    8         ; the Free Software Foundation; either version 2 of the License, or
    9         ; (at your option) any later version.
    10         ;
    11         ; This program is distributed in the hope that it will be useful,
    12         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ; GNU General Public License for more details.
    15         ;
    16         ; You should have received a copy of the GNU General Public License
    17         ; along with this program; if not, write to the Free Software
    18         ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    19         ;External reference ^PS(59.7 supported by DBIA 694
    20         ;External reference to ^PSDRUG("AQ" supported by DBIA 3165
    21         ;External reference ^XTMP("PSA" supported by DBIA 1036
    22         ;External reference $$SERV^IBARX1 supported by DBIA 2245
    23         ;External reference ^PSDRUG( supported by DBIA 221
    24         ;Reference to ^DIC(19.2 supported by DBIA 1064
    25         ;
    26 QTY     ; Refill Release
    27         S PSOCPN=$P(^PSRX(RXP,0),"^",2),QDRUG=$P(^PSRX(RXP,0),"^",6) K LBLP
    28         F YY=0:0 S YY=$O(^PSRX(RXP,XTYPE,YY)) Q:'YY  D:$P($G(^PSRX(RXP,XTYPE,YY,0)),"^")'<PSIN  K ISUF,LBLP
    29         .S RXFD=$E($P(^PSRX(RXP,XTYPE,YY,0),"^"),1,7),SUPN=$O(^PS(52.5,"B",RXP,0)) I SUPN,$D(^PS(52.5,"C",RXFD,SUPN)),$G(^PS(52.5,SUPN,"P"))'=1,$G(XTYPE) S ISUF=1 Q
    30         .I XTYPE=1,($D(^PSDRUG("AQ",QDRUG))) K CMOP D RREL^PSOCMOPB(RXP,YY) K CMOP Q:$G(ISUF)
    31         .I $P(^PSRX(RXP,XTYPE,YY,0),"^",$S($G(XTYPE):18,1:19))]""!($P(^(0),"^",16)) K IFN Q
    32         .;
    33         .F LBL=0:0 S LBL=$O(^PSRX(RXP,"L",LBL)) Q:'LBL  I $P(^PSRX(RXP,"L",LBL,0),"^",2)=$S('XTYPE:(99-YY),1:YY) S LBLP=1
    34         .Q:'$G(LBLP)
    35         .D CHKADDR(RXP)
    36         .;
    37         .; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects / NDC Editing
    38         .I XTYPE,$$MANREL^PSOBPSUT(RXP,YY,$G(PSOPID))="^" K LBLP Q
    39         .;
    40         .S IFN=YY S:$G(^PSDRUG(QDRUG,660.1))]"" QTY=$P(^PSRX(RXP,XTYPE,YY,0),"^",4),^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
    41         .K DA,DR,DIE D NOW^%DTC S DIE="^PSRX("_RXP_","""_XTYPE_""",",DA(1)=RXP
    42         .S DA=YY,DR=$S(XTYPE:17,1:8)_"///"_%_";"_$S(XTYPE:4,1:.05)_"////"_PSRH
    43         .S PSODT=% D ^DIE K DIE,DR,DA
    44         .;
    45         .; - Notifying IB through ECME of the Rx being released
    46         .I XTYPE D IBSEND^PSOBPSUT(RXP,YY)
    47         .;
    48         .K PSODISPP S:$G(XTYPE)="P" PSODISPP=1 D EN^PSOHLSN1(RXP,"ZD") K PSODISPP
    49         .K:XTYPE ^PSRX("ACP",$P($G(^PSRX(RXP,0)),"^",2),$P($G(^PSRX(RXP,1,YY,0)),"^"),YY,RXP)
    50         .I XTYPE,$G(IFN),'$G(ISUF) S PSOCPRX=$P(^PSRX(RXP,0),"^") D CP^PSOCP
    51         .;if appropriate update ^XTMP("PSA", for Drug Acct.
    52         .I $G(PSODA),$G(PSODA(1)),'$D(^PSRX("AR",+PSODT,+RXP,YY)) D
    53         ..S ^XTMP("PSA",+PSOSITE,+QDRUG,DT)=$G(^XTMP("PSA",+PSOSITE,+QDRUG,DT))+$P($G(^PSRX(RXP,XTYPE,YY,0)),"^",4)
    54         .;initialize bingo board variables
    55         .I $G(IFN),$P($G(^PSRX(RXP,XTYPE,IFN,0)),"^",2)["W" S BINGRPR="W",BNGPDV=$P(^PSRX(RXP,XTYPE,IFN,0),"^",9),BINGNAM=$P($G(^PSRX(RXP,0)),"^",2)
    56         W:$G(IFN) !?7,"Prescription Number "_$P(^PSRX(RXP,0),"^")_$S('$G(XTYPE):" Partial Fill",1:" Refill(s)")_" Released" I $G(SPEED) G XMIT
    57         I $G(PSOAFYN)'="Y" W:'$G(IFN) !?7,"No "_$S($G(XTYPE):"Refill(s)",1:"Partial(s)")_" to be Released" ;vfah - VOE
    58 XMIT    I $G(PSODISP)=2.4 D  ;build an send HL7 v2.4 messages to dispense system
    59         . F I=0:0 S SUB=$O(^PSRX(RXP,"A",I)) Q:'I  I $P(^PSRX(RXP,"A",I,0),"^",2)="N" D
    60         .. D NOW^%DTC S PSODTM=% K ^UTILITY($J,"PSOHL")
    61         .. S IDGN=$P(^PSRX(+RXP,0),"^",6),FP=$S(XTYPE=1:"R",1:"P")
    62         .. S ^UTILITY($J,"PSOHL",1)=+RXP_"^"_IDGN_"^"_PSODTM_"^"_+$G(PDUZ)_"^0^^PSO DISP^^^"_FP_"^"_IFN
    63         .. S ZTRTN="INIT^PSORELDT",ZTDESC="EXTERNAL INTERFACE FOR RELEASE DATE/TIME",ZTIO="",ZTDTH=$H,ZTSAVE("^UTILITY($J,""PSOHL"",")="",ZTSAVE("PSOSITE")="",ZTSAVE("RXP")="" D ^%ZTLOAD K ^UTILITY($J,"PSOHL")
    64         K IFN
    65         Q
    66 STAT    S RX0=^PSRX(RXP,0),$P(RX0,"^",15)=+^("STA"),RX2=^PSRX(RXP,2),J=RXP D ^PSOFUNC
    67         W !!?5,$C(7),$C(7),"Rx# "_$P(^PSRX(RXP,0),"^")_" has a status of "_ST_" and is not eligible for",!?5,"release."_$S('$D(^XUSEC("PSORPH",DUZ)):"  Please check with a Pharmacist!",1:"")
    68         K RX0,ST
    69         Q
    70 OERR    I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,?5,"Site Parameters must be defined to use the Release option!",! S VALMBCK="" Q
    71         S VALMBCK="Q",Y=$G(^PS(59,PSOSITE,"IB")),PSOIBSS=$$SERV^IBARX1(+Y) I 'PSOIBSS D IBSSR^PSOUTL I 'PSOIBFL D  S VALMBCK="" G EX
    72         .W $C(7),!!,"The IB SERVICE/SECTION defined in your site parameter file is not valid.",!,"You will not be able to release any medication until this is corrected!",!
    73         W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2),RXP=$P(PSOLST($P(PSLST,",",ORD)),"^",2)
    74         S DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))",DIC("A")="Enter PHARMACIST: ",DIC="^VA(200,",DIC(0)="QEAM" D ^DIC G:"^"[X EX K DIC G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(Y=-1) EX S PSRH=+Y
    75         ;check for Drug Acct background job K8 & K7.1
    76         S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19.2 D ^DIC I Y=-1 K DIC,X,Y G DOIT
    77         I $P($G(Y(0)),U,2)>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT G DOIT
    78         S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19 D ^DIC K DIC,X G:Y=-1 DOIT
    79         K DIQ,PSA S DA=+Y,DIC=19,DIQ="PSA",DR=200,DIQ(0)="IN" D EN^DIQ1
    80         I '$D(PSA(19,DA,200,"I")) K DIC,DA,X,Y,DIQ G DOIT
    81         I PSA(19,DA,200,"I")>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT
    82         K PSA,DIC,DA,X,Y,DIQ
    83         ;
    84 DOIT    S POERR=1 D FULL^VALM1,BC1^PSODISP
    85         I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) N TM,TM1 D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
    86 EX      ;
    87         K OUT,RX2,RXFD,RESK,ISUF,SUPN,%,DIC,IFN,J,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,PSOIBSS,PSOIBFL,PSOIBLP,PSOIBST,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSRH,XX,Y,PSIN,POERR,SUB
    88         K DIR S DIR("A",1)=" ",DIR("A")="Press Return to Continue",DIR(0)="E" D ^DIR K DIRUT,DUOUT,DTOUT,DIR S VALMBCK="R"
    89         S PSORXED=1 D ^PSOBUILD,ACT^PSOORNE2 K PSORXED
    90         Q
    91         ;
    92 CHKADDR(RXP)    ;
    93         N PSOTXT,PSOBADR,PSOTEMP,LBL
    94         S LBL=$O(^PSRX(RXP,"L",99999),-1) I LBL>0 D
    95         .S PSOTXT=$G(^PSRX(RXP,"L",LBL,0)) I PSOTXT'["(BAD ADDRESS)" Q
    96         .S PSOBADR=$$CHKRX^PSOBAI(RXP)
    97         .I '$G(PSOBADR) D SETLBL(LBL,"NO BAD ADDRESS INDICATOR AT RELEASE") Q
    98         .I $P(PSOBADR,"^",2) D SETLBL(LBL,"ACTIVE TEMPORARY ADDRESS AT RELEASE")
    99         Q
    100         ;
    101 SETLBL(LBL,PSOMSG)      ;
    102         N PSOTXT
    103         S PSOTXT=$G(^PSRX(RXP,"L",LBL,0)),$P(PSOTXT,"^",3)=PSOMSG
    104         S LBL=LBL+1,^PSRX(RXP,"L",0)="^52.032DA^"_LBL_"^"_LBL
    105         S ^PSRX(RXP,"L",LBL,0)=PSOTXT
    106         Q
     1PSODISPS ;BIR/SAB-CONTINUATION OF RELEASE FUNCTION ;3/2/93
     2 ;;7.0;OUTPATIENT PHARMACY;**15,13,9,27,67,71,156,118,148,247,200,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 ;External reference ^PS(59.7 supported by DBIA 694
     20 ;External reference to ^PSDRUG("AQ" supported by DBIA 3165
     21 ;External reference ^XTMP("PSA" supported by DBIA 1036
     22 ;External reference $$SERV^IBARX1 supported by DBIA 2245
     23 ;External reference ^PSDRUG( supported by DBIA 221
     24 ;Reference to ^DIC(19.2 supported by DBIA 1064
     25 ;
     26QTY ; Refill Release
     27 S PSOCPN=$P(^PSRX(RXP,0),"^",2),QDRUG=$P(^PSRX(RXP,0),"^",6) K LBLP
     28 F YY=0:0 S YY=$O(^PSRX(RXP,XTYPE,YY)) Q:'YY  D:$P($G(^PSRX(RXP,XTYPE,YY,0)),"^")'<PSIN  K ISUF,LBLP
     29 .S RXFD=$E($P(^PSRX(RXP,XTYPE,YY,0),"^"),1,7),SUPN=$O(^PS(52.5,"B",RXP,0)) I SUPN,$D(^PS(52.5,"C",RXFD,SUPN)),$G(^PS(52.5,SUPN,"P"))'=1,$G(XTYPE) S ISUF=1 Q
     30 .I XTYPE=1,($D(^PSDRUG("AQ",QDRUG))) K CMOP D RREL^PSOCMOPB(RXP,YY) K CMOP Q:$G(ISUF)
     31 .I $P(^PSRX(RXP,XTYPE,YY,0),"^",$S($G(XTYPE):18,1:19))]""!($P(^(0),"^",16)) K IFN Q
     32 .;
     33 .F LBL=0:0 S LBL=$O(^PSRX(RXP,"L",LBL)) Q:'LBL  I $P(^PSRX(RXP,"L",LBL,0),"^",2)=$S('XTYPE:(99-YY),1:YY) S LBLP=1
     34 .Q:'$G(LBLP)
     35 .D CHKADDR(RXP)
     36 .;
     37 .; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects / NDC Editing
     38 .I XTYPE,$$MANREL^PSOBPSUT(RXP,YY,$G(PSOPID))="^" K LBLP Q
     39 .;
     40 .S IFN=YY S:$G(^PSDRUG(QDRUG,660.1))]"" QTY=$P(^PSRX(RXP,XTYPE,YY,0),"^",4),^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
     41 .K DA,DR,DIE D NOW^%DTC S DIE="^PSRX("_RXP_","""_XTYPE_""",",DA(1)=RXP
     42 .S DA=YY,DR=$S(XTYPE:17,1:8)_"///"_%_";"_$S(XTYPE:4,1:.05)_"////"_PSRH
     43 .S PSODT=% D ^DIE K DIE,DR,DA
     44 .;
     45 .; - Notifying IB through ECME of the Rx being released
     46 .I XTYPE D IBSEND^PSOBPSUT(RXP,YY)
     47 .;
     48 .K PSODISPP S:$G(XTYPE)="P" PSODISPP=1 D EN^PSOHLSN1(RXP,"ZD") K PSODISPP
     49 .K:XTYPE ^PSRX("ACP",$P($G(^PSRX(RXP,0)),"^",2),$P($G(^PSRX(RXP,1,YY,0)),"^"),YY,RXP)
     50 .I XTYPE,$G(IFN),'$G(ISUF) S PSOCPRX=$P(^PSRX(RXP,0),"^") D CP^PSOCP
     51 .;if appropriate update ^XTMP("PSA", for Drug Acct.
     52 .I $G(PSODA),$G(PSODA(1)),'$D(^PSRX("AR",+PSODT,+RXP,YY)) D
     53 ..S ^XTMP("PSA",+PSOSITE,+QDRUG,DT)=$G(^XTMP("PSA",+PSOSITE,+QDRUG,DT))+$P($G(^PSRX(RXP,XTYPE,YY,0)),"^",4)
     54 .;initialize bingo board variables
     55 .I $G(IFN),$P($G(^PSRX(RXP,XTYPE,IFN,0)),"^",2)["W" S BINGRPR="W",BNGPDV=$P(^PSRX(RXP,XTYPE,IFN,0),"^",9),BINGNAM=$P($G(^PSRX(RXP,0)),"^",2)
     56 W:$G(IFN) !?7,"Prescription Number "_$P(^PSRX(RXP,0),"^")_$S('$G(XTYPE):" Partial Fill",1:" Refill(s)")_" Released" I $G(SPEED) G XMIT
     57 I $G(PSOAFYN)'="Y" W:'$G(IFN) !?7,"No "_$S($G(XTYPE):"Refill(s)",1:"Partial(s)")_" to be Released" ;vfah - VOE
     58XMIT I $G(PSODISP)=2.4 D  ;build an send HL7 v2.4 messages to dispense system
     59 . F I=0:0 S SUB=$O(^PSRX(RXP,"A",I)) Q:'I  I $P(^PSRX(RXP,"A",I,0),"^",2)="N" D
     60 .. D NOW^%DTC S PSODTM=% K ^UTILITY($J,"PSOHL")
     61 .. S IDGN=$P(^PSRX(+RXP,0),"^",6),FP=$S(XTYPE=1:"R",1:"P")
     62 .. S ^UTILITY($J,"PSOHL",1)=+RXP_"^"_IDGN_"^"_PSODTM_"^"_+$G(PDUZ)_"^0^^PSO DISP^^^"_FP_"^"_IFN
     63 .. S ZTRTN="INIT^PSORELDT",ZTDESC="EXTERNAL INTERFACE FOR RELEASE DATE/TIME",ZTIO="",ZTDTH=$H,ZTSAVE("^UTILITY($J,""PSOHL"",")="",ZTSAVE("PSOSITE")="",ZTSAVE("RXP")="" D ^%ZTLOAD K ^UTILITY($J,"PSOHL")
     64 K IFN
     65 Q
     66STAT S RX0=^PSRX(RXP,0),$P(RX0,"^",15)=+^("STA"),RX2=^PSRX(RXP,2),J=RXP D ^PSOFUNC
     67 W !!?5,$C(7),$C(7),"Rx# "_$P(^PSRX(RXP,0),"^")_" has a status of "_ST_" and is not eligible for",!?5,"release."_$S('$D(^XUSEC("PSORPH",DUZ)):"  Please check with a Pharmacist!",1:"")
     68 K RX0,ST
     69 Q
     70OERR I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,?5,"Site Parameters must be defined to use the Release option!",! S VALMBCK="" Q
     71 S VALMBCK="Q",Y=$G(^PS(59,PSOSITE,"IB")),PSOIBSS=$$SERV^IBARX1(+Y) I 'PSOIBSS D IBSSR^PSOUTL I 'PSOIBFL D  S VALMBCK="" G EX
     72 .W $C(7),!!,"The IB SERVICE/SECTION defined in your site parameter file is not valid.",!,"You will not be able to release any medication until this is corrected!",!
     73 W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2),RXP=$P(PSOLST($P(PSLST,",",ORD)),"^",2)
     74 S DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))",DIC("A")="Enter PHARMACIST: ",DIC="^VA(200,",DIC(0)="QEAM" D ^DIC G:"^"[X EX K DIC G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(Y=-1) EX S PSRH=+Y
     75 ;check for Drug Acct background job K8 & K7.1
     76 S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19.2 D ^DIC I Y=-1 K DIC,X,Y G DOIT
     77 I $P($G(Y(0)),U,2)>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT G DOIT
     78 S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19 D ^DIC K DIC,X G:Y=-1 DOIT
     79 K DIQ,PSA S DA=+Y,DIC=19,DIQ="PSA",DR=200,DIQ(0)="IN" D EN^DIQ1
     80 I '$D(PSA(19,DA,200,"I")) K DIC,DA,X,Y,DIQ G DOIT
     81 I PSA(19,DA,200,"I")>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT
     82 K PSA,DIC,DA,X,Y,DIQ
     83 ;
     84DOIT S POERR=1 D FULL^VALM1,BC1^PSODISP
     85 I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) N TM,TM1 D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
     86EX ;
     87 K OUT,RX2,RXFD,RESK,ISUF,SUPN,%,DIC,IFN,J,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,PSOIBSS,PSOIBFL,PSOIBLP,PSOIBST,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSRH,XX,Y,PSIN,POERR,SUB
     88 K DIR S DIR("A",1)=" ",DIR("A")="Press Return to Continue",DIR(0)="E" D ^DIR K DIRUT,DUOUT,DTOUT,DIR S VALMBCK="R"
     89 S PSORXED=1 D ^PSOBUILD,ACT^PSOORNE2 K PSORXED
     90 Q
     91 ;
     92CHKADDR(RXP) ;
     93 N PSOTXT,PSOBADR,PSOTEMP,LBL
     94 S LBL=$O(^PSRX(RXP,"L",99999),-1) I LBL>0 D
     95 .S PSOTXT=$G(^PSRX(RXP,"L",LBL,0)) I PSOTXT'["(BAD ADDRESS)" Q
     96 .S PSOBADR=$$CHKRX^PSOBAI(RXP)
     97 .I '$G(PSOBADR) D SETLBL(LBL,"NO BAD ADDRESS INDICATOR AT RELEASE") Q
     98 .I $P(PSOBADR,"^",2) D SETLBL(LBL,"ACTIVE TEMPORARY ADDRESS AT RELEASE")
     99 Q
     100 ;
     101SETLBL(LBL,PSOMSG) ;
     102 N PSOTXT
     103 S PSOTXT=$G(^PSRX(RXP,"L",LBL,0)),$P(PSOTXT,"^",3)=PSOMSG
     104 S LBL=LBL+1,^PSRX(RXP,"L",0)="^52.032DA^"_LBL_"^"_LBL
     105 S ^PSRX(RXP,"L",LBL,0)=PSOTXT
     106 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODRDUP.m

    r613 r623  
    1 PSODRDUP        ;BIR/SAB - Dup drug class checker ;11/1/04 3:38pm
    2         ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,39,56,130,132,192,207,222,243,208**;DEC 1997;Build 41
    3         ; Modified from FOIA VISTA,
    4         ; Copyright (C) 2007 WorldVistA
    5         ;
    6         ; This program is free software; you can redistribute it and/or modify
    7         ; it under the terms of the GNU General Public License as published by
    8         ; the Free Software Foundation; either version 2 of the License, or
    9         ; (at your option) any later version.
    10         ;
    11         ; This program is distributed in the hope that it will be useful,
    12         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ; GNU General Public License for more details.
    15         ;
    16         ; You should have received a copy of the GNU General Public License
    17         ; along with this program; if not, write to the Free Software
    18         ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    19         ;
    20         ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
    21         I $G(PSOAFYN)="Y" Q  ;vfam No Dup Drug Check by AutoFinish,Rx - VOE
    22         S $P(PSONULN,"-",79)="-",(STA,DNM)="" K CLS
    23         F  S STA=$O(PSOSD(STA)) Q:STA=""  F  S DNM=$O(PSOSD(STA,DNM)) Q:DNM=""!$G(PSORX("DFLG"))  I $P(PSOSD(STA,DNM),"^")'=$G(PSORENW("OIRXN")) D  Q:$G(PSORX("DFLG"))
    24         .I STA="PENDING" D ^PSODRDU1 Q
    25         .I STA="ZNONVA" D NVA^PSODRDU1 Q
    26         .D:PSODRUG("NAME")=$P(DNM,"^")&('$D(^XUSEC("PSORPH",DUZ)))  Q:$G(PSORX("DFLG"))
    27         ..I $P($G(PSOPAR),"^",16) D DUP Q:$G(PSORX("DFLG"))
    28         ..I $P(PSOPAR,"^",2),'$P($G(PSOPAR),"^",16) D DUP Q:$G(PSORX("DFLG"))
    29         ..I '$P(PSOPAR,"^",2),'$P($G(PSOPAR),"^",16) D DUP Q:$G(PSORX("DFLG"))
    30         .D:PSODRUG("NAME")=$P(DNM,"^")&($D(^XUSEC("PSORPH",DUZ))) DUP Q:$G(PSORX("DFLG"))
    31         .I PSODRUG("VA CLASS")]"",$E(PSODRUG("VA CLASS"),1,4)=$E($P(PSOSD(STA,DNM),"^",5),1,4),PSODRUG("NAME")'=$P(DNM,"^") D CLS
    32         K ^TMP($J,"DD"),^TMP($J,"DC"),^TMP($J,"DI")
    33         D REMOTE^PSOCPDUP
    34 EXIT    D ^PSOBUILD K CAN,DA,DIR,DNM,DUPRX0,ISSD,J,LSTFL,MSG,PHYS,PSOCLC,PSONULN,REA,RFLS,RX0,RX2,RXN,RXREC,ST,Y,ZZ,ACT,PSOCLOZ,PSOLR,PSOLDT,PSOCD,SIG
    35         Q
    36 DUP     S:$P(PSOSD(STA,DNM),"^",2)<10!($P(PSOSD(STA,DNM),"^",2)=16) DUP=1 W !,PSONULN,!,$C(7),"Duplicate Drug "_$P(DNM,"^")_" in Prescription: ",$P(^PSRX(+PSOSD(STA,DNM),0),"^")
    37         S RXREC=+PSOSD(STA,DNM),MSG="Discontinued During "_$S('$G(PSONV):"New Prescription Entry",1:"Verification")_" - Duplicate Drug"
    38 DATA    S DUPRX0=^PSRX(RXREC,0),RFLS=$P(DUPRX0,"^",9),ISSD=$P(^PSRX(RXREC,0),"^",13),RX0=DUPRX0,RX2=^PSRX(RXREC,2),$P(RX0,"^",15)=+$G(^PSRX(RXREC,"STA"))
    39         S RXRECLOC=$G(RXREC)
    40         W !!,$J("Status: ",24) S J=RXREC D STAT^PSOFUNC W ST K RX0,RX2 W ?40,$J("Issued: ",24),$E(ISSD,4,5)_"/"_$E(ISSD,6,7)_"/"_$E(ISSD,2,3)
    41         S DA=RXREC D ^PSOCMOPA I $G(PSOCMOP)]"" D  K CMOP,PSOTRANS,PSOREL
    42         .S PSOTRANS=$E($P(PSOCMOP,"^",2),4,5)_"/"_$E($P(PSOCMOP,"^",2),6,7)_"/"_$E($P(PSOCMOP,"^",2),2,3)
    43         .S PSOREL=$S(CMOP("L")=0:$P($G(^PSRX(DA,2)),"^",13),1:$P(^PSRX(DA,1,CMOP("L"),0),"^",18))
    44         .S PSOREL=$E(PSOREL,4,5)_"/"_$E(PSOREL,6,7)_"/"_$E(PSOREL,2,3)_"@"_$E($P(PSOREL,".",2),1,4)
    45         .W !,$J("CMOP Status: ",24)_$S($P(PSOCMOP,"^")=0!($P(PSOCMOP,"^")=2):"Transmitted to on "_PSOTRANS,$P(PSOCMOP,"^")=1:"Released by CMOP on "_PSOREL,1:"Not Dispensed")
    46         K FSIG,BSIG I $P($G(^PSRX(RXREC,"SIG")),"^",2) D FSIG^PSOUTLA("R",RXREC,54) F PSREV=1:1 Q:'$D(FSIG(PSREV))  S BSIG(PSREV)=FSIG(PSREV)
    47         K FSIG,PSREV I '$P($G(^PSRX(RXREC,"SIG")),"^",2) D EN2^PSOUTLA1(RXREC,54)
    48         W !,$J("SIG: ",24) W $G(BSIG(1))
    49         I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV  W !?24,$G(BSIG(PSREV))
    50         K BSIG,PSREV
    51         W !,$J("QTY: ",24)_$P(DUPRX0,"^",7),?40,$J("# of refills: ",24)_RFLS S PHYS=$S($D(^VA(200,+$P(DUPRX0,"^",4),0)):$P(^(0),"^"),1:"UNKNOWN")
    52         W !,$J("Provider: ",24)_PHYS,?40,$J("Refills remaining: ",24),RFLS-$S($D(^PSRX(RXREC,1,0)):$P(^(0),"^",4),1:0)
    53         S LSTFL=+^PSRX(RXREC,3) W !?40,$J("Last filled on: ",24)_$E(LSTFL,4,5)_"/"_$E(LSTFL,6,7)_"/"_$E(LSTFL,2,3),!?40,$J("Days Supply: ",24)_$P(DUPRX0,"^",8)
    54         W !,PSONULN,! I $P($G(^PS(53,+$P($G(PSORX("PATIENT STATUS")),"^"),0)),"^")["AUTH ABS"!($G(PSORX("PATIENT STATUS"))["AUTH ABS")&'$P(PSOPAR,"^",5) W !,"PATIENT ON AUTHORIZED ABSENCE!" K RXRECLOC Q
    55 ASKCAN  I $P(PSOSD(STA,DNM),"^",2)>10,$P(PSOSD(STA,DNM),"^",2)'=16 K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR,DTOUT,DUOUT,DIRUT,RXRECLOC Q
    56         I '$P(PSOPAR,"^",2),'$P(PSOPAR,"^",16),'$D(^XUSEC("PSORPH",DUZ)),'$G(CLS) S PSORX("DFLG")=1 K RXRECLOC Q
    57         I $P(PSOPAR,"^",2),'$P(PSOPAR,"^",16),'$D(^XUSEC("PSORPH",DUZ)),'$G(CLS) S PSORX("DFLG")=1 K RXRECLOC Q
    58         I $P(PSOSD(STA,DNM),"^",2)=16,$G(DUP) W !!,"Prescription "_$P($G(^PSRX(+$G(RXRECLOC),0)),"^")_" is on Provider Hold, it cannot be discontinued.",! K DUP,RXRECLOC S PSORX("DFLG")=1 Q
    59         D PSOL^PSSLOCK(RXRECLOC) I '$G(PSOMSG) D  K PSOMSG,DIR,DUP,RXRECLOC S DIR("A")="Press Return to continue",DIR(0)="E" D ^DIR K DIR S PSORX("DFLG")=1 Q
    60         .I $P($G(PSOMSG),"^",2)'="" W !!,$P(PSOMSG,"^",2),! Q
    61         .W !!,"Another person is editing Rx "_$P($G(^PSRX(RXRECLOC,0)),"^"),!
    62         K PSOMSG S DIR("A")=$S($P(PSOSD(STA,DNM),"^",2)=12:"Reinstate",1:"Discontinue")_" RX # "_$P(^PSRX(+PSOSD(STA,DNM),0),"^"),DIR(0)="Y",DIR("?")="Enter Y to "_$S($P(PSOSD(STA,DNM),"^",2)=12:"reinstate",1:"discontinue")_" this RX."
    63         D ^DIR K DIR S DA=RXREC S ACT=$S($D(SPCANC):"Reinstated during Rx cancel.",1:$S($P(PSOSD(STA,DNM),"^",2)=12:"Reinstated",1:"Discontinued")_" while "_$S('$G(PSONV):"entering",1:"verifying")_" new RX")
    64         D CMOP^PSOUTL I $G(CMOP("S"))="L" W !,"A CMOP Rx cannot be discontinued during transmission!",! S Y=0 K CMOP
    65         I 'Y W $C(7)," -Prescription was not "_$S($P(PSOSD(STA,DNM),"^",2)=12:"reinstated",1:"discontinued")_"..." D  Q
    66         .S:'$D(PSOCLC) PSOCLC=DUZ S MSG=ACT,REA=$S($P(PSOSD(STA,DNM),"^",2)=12:"R",1:"C") S:$G(DUP) PSORX("DFLG")=1 K DUP D ULRX K RXRECLOC
    67         .I $D(^TMP("PSORXDC",$J,RXREC,0)) K ^TMP("PSORXDC",$J,RXREC,0)
    68         I $P(PSOSD(STA,DNM),"^",2)=16,$G(CLS) W !!,"Prescription "_$P($G(^PSRX(+$G(RXRECLOC),0)),"^")_" is on Provider Hold, it cannot be discontinued.",! D ULRX K CLS,DUP,RXRECLOC S PSORX("DFLG")=1 H 2 Q
    69         S PSOCLC=DUZ,MSG=$S($G(MSG)]"":MSG,1:ACT_" During New RX "_$S('$G(PSONV):"Entry",1:"Verification")_" - Duplicate Rx"),REA=$S($P(PSOSD(STA,DNM),"^",2)=12:"R",1:"C")
    70         W !!,"Duplicate "_$S($G(CLS):"Class",1:"Drug")_" will be discontinued after the acceptance of the new order.",!
    71         S ^TMP("PSORXDC",$J,RXREC,0)="52^"_DA_"^"_MSG_"^"_REA_"^"_ACT_"^"_STA_"^"_DNM,PSONOOR="D"
    72         K RXRECLOC,DUP,CLS,PSONOOR Q
    73 CLS     K DUP
    74         I $E($G(PSODRUG("VA CLASS")),1,2)="HA",$E($P($G(PSOSD(STA,DNM)),"^",5),1,2)="HA" K PSOELSE Q
    75         S CLS=1,MSG="Discontinued During "_$S('$G(PSONV):"New Prescription Entry",1:"Verification")_" - Duplicate Class" W !,PSONULN
    76         W !?5,$C(7),"*** SAME CLASS *** OF DRUG IN RX #"_$P(^PSRX(+PSOSD(STA,DNM),0),"^")_" FOR "_$P(DNM,"^"),!,"CLASS: "_PSODRUG("VA CLASS")
    77         S CAN=$P(PSOSD(STA,DNM),"^",2)'<11!($P(PSOSD(STA,DNM),"^",2)=1) S RXREC=+PSOSD(STA,DNM) I $P($G(PSOPAR),"^",10) D DATA Q
    78         E  W !,PSONULN K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR,DTOUT,DUOUT,DIRUT
    79         K PSOELSE Q
    80 ULRX    ;
    81         I '$G(RXRECLOC) Q
    82         D PSOUL^PSSLOCK(RXRECLOC)
    83         Q
    84         ;
     1PSODRDUP ;BIR/SAB - Dup drug class checker ;11/1/04 3:38pm
     2 ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,39,56,130,132,192,207,222,243,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 ;
     20 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
     21 I $G(PSOAFYN)="Y" Q  ;vfam No Dup Drug Check by AutoFinish,Rx - VOE
     22 S $P(PSONULN,"-",79)="-",(STA,DNM)="" K CLS
     23 F  S STA=$O(PSOSD(STA)) Q:STA=""  F  S DNM=$O(PSOSD(STA,DNM)) Q:DNM=""!$G(PSORX("DFLG"))  I $P(PSOSD(STA,DNM),"^")'=$G(PSORENW("OIRXN")) D  Q:$G(PSORX("DFLG"))
     24 .I STA="PENDING" D ^PSODRDU1 Q
     25 .I STA="ZNONVA" D NVA^PSODRDU1 Q
     26 .D:PSODRUG("NAME")=$P(DNM,"^")&('$D(^XUSEC("PSORPH",DUZ)))  Q:$G(PSORX("DFLG"))
     27 ..I $P($G(PSOPAR),"^",16) D DUP Q:$G(PSORX("DFLG"))
     28 ..I $P(PSOPAR,"^",2),'$P($G(PSOPAR),"^",16) D DUP Q:$G(PSORX("DFLG"))
     29 ..I '$P(PSOPAR,"^",2),'$P($G(PSOPAR),"^",16) D DUP Q:$G(PSORX("DFLG"))
     30 .D:PSODRUG("NAME")=$P(DNM,"^")&($D(^XUSEC("PSORPH",DUZ))) DUP Q:$G(PSORX("DFLG"))
     31 .I PSODRUG("VA CLASS")]"",$E(PSODRUG("VA CLASS"),1,4)=$E($P(PSOSD(STA,DNM),"^",5),1,4),PSODRUG("NAME")'=$P(DNM,"^") D CLS
     32 K ^TMP($J,"DD"),^TMP($J,"DC"),^TMP($J,"DI")
     33 D REMOTE^PSOCPDUP
     34EXIT D ^PSOBUILD K CAN,DA,DIR,DNM,DUPRX0,ISSD,J,LSTFL,MSG,PHYS,PSOCLC,PSONULN,REA,RFLS,RX0,RX2,RXN,RXREC,ST,Y,ZZ,ACT,PSOCLOZ,PSOLR,PSOLDT,PSOCD,SIG
     35 Q
     36DUP S:$P(PSOSD(STA,DNM),"^",2)<10!($P(PSOSD(STA,DNM),"^",2)=16) DUP=1 W !,PSONULN,!,$C(7),"Duplicate Drug "_$P(DNM,"^")_" in Prescription: ",$P(^PSRX(+PSOSD(STA,DNM),0),"^")
     37 S RXREC=+PSOSD(STA,DNM),MSG="Discontinued During "_$S('$G(PSONV):"New Prescription Entry",1:"Verification")_" - Duplicate Drug"
     38DATA S DUPRX0=^PSRX(RXREC,0),RFLS=$P(DUPRX0,"^",9),ISSD=$P(^PSRX(RXREC,0),"^",13),RX0=DUPRX0,RX2=^PSRX(RXREC,2),$P(RX0,"^",15)=+$G(^PSRX(RXREC,"STA"))
     39 S RXRECLOC=$G(RXREC)
     40 W !!,$J("Status: ",24) S J=RXREC D STAT^PSOFUNC W ST K RX0,RX2 W ?40,$J("Issued: ",24),$E(ISSD,4,5)_"/"_$E(ISSD,6,7)_"/"_$E(ISSD,2,3)
     41 S DA=RXREC D ^PSOCMOPA I $G(PSOCMOP)]"" D  K CMOP,PSOTRANS,PSOREL
     42 .S PSOTRANS=$E($P(PSOCMOP,"^",2),4,5)_"/"_$E($P(PSOCMOP,"^",2),6,7)_"/"_$E($P(PSOCMOP,"^",2),2,3)
     43 .S PSOREL=$S(CMOP("L")=0:$P($G(^PSRX(DA,2)),"^",13),1:$P(^PSRX(DA,1,CMOP("L"),0),"^",18))
     44 .S PSOREL=$E(PSOREL,4,5)_"/"_$E(PSOREL,6,7)_"/"_$E(PSOREL,2,3)_"@"_$E($P(PSOREL,".",2),1,4)
     45 .W !,$J("CMOP Status: ",24)_$S($P(PSOCMOP,"^")=0!($P(PSOCMOP,"^")=2):"Transmitted to on "_PSOTRANS,$P(PSOCMOP,"^")=1:"Released by CMOP on "_PSOREL,1:"Not Dispensed")
     46 K FSIG,BSIG I $P($G(^PSRX(RXREC,"SIG")),"^",2) D FSIG^PSOUTLA("R",RXREC,54) F PSREV=1:1 Q:'$D(FSIG(PSREV))  S BSIG(PSREV)=FSIG(PSREV)
     47 K FSIG,PSREV I '$P($G(^PSRX(RXREC,"SIG")),"^",2) D EN2^PSOUTLA1(RXREC,54)
     48 W !,$J("SIG: ",24) W $G(BSIG(1))
     49 I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV  W !?24,$G(BSIG(PSREV))
     50 K BSIG,PSREV
     51 W !,$J("QTY: ",24)_$P(DUPRX0,"^",7),?40,$J("# of refills: ",24)_RFLS S PHYS=$S($D(^VA(200,+$P(DUPRX0,"^",4),0)):$P(^(0),"^"),1:"UNKNOWN")
     52 W !,$J("Provider: ",24)_PHYS,?40,$J("Refills remaining: ",24),RFLS-$S($D(^PSRX(RXREC,1,0)):$P(^(0),"^",4),1:0)
     53 S LSTFL=+^PSRX(RXREC,3) W !?40,$J("Last filled on: ",24)_$E(LSTFL,4,5)_"/"_$E(LSTFL,6,7)_"/"_$E(LSTFL,2,3),!?40,$J("Days Supply: ",24)_$P(DUPRX0,"^",8)
     54 W !,PSONULN,! I $P($G(^PS(53,+$P($G(PSORX("PATIENT STATUS")),"^"),0)),"^")["AUTH ABS"!($G(PSORX("PATIENT STATUS"))["AUTH ABS")&'$P(PSOPAR,"^",5) W !,"PATIENT ON AUTHORIZED ABSENCE!" K RXRECLOC Q
     55ASKCAN I $P(PSOSD(STA,DNM),"^",2)>10,$P(PSOSD(STA,DNM),"^",2)'=16 K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR,DTOUT,DUOUT,DIRUT,RXRECLOC Q
     56 I '$P(PSOPAR,"^",2),'$P(PSOPAR,"^",16),'$D(^XUSEC("PSORPH",DUZ)),'$G(CLS) S PSORX("DFLG")=1 K RXRECLOC Q
     57 I $P(PSOPAR,"^",2),'$P(PSOPAR,"^",16),'$D(^XUSEC("PSORPH",DUZ)),'$G(CLS) S PSORX("DFLG")=1 K RXRECLOC Q
     58 I $P(PSOSD(STA,DNM),"^",2)=16,$G(DUP) W !!,"Prescription "_$P($G(^PSRX(+$G(RXRECLOC),0)),"^")_" is on Provider Hold, it cannot be discontinued.",! K DUP,RXRECLOC S PSORX("DFLG")=1 Q
     59 D PSOL^PSSLOCK(RXRECLOC) I '$G(PSOMSG) D  K PSOMSG,DIR,DUP,RXRECLOC S DIR("A")="Press Return to continue",DIR(0)="E" D ^DIR K DIR S PSORX("DFLG")=1 Q
     60 .I $P($G(PSOMSG),"^",2)'="" W !!,$P(PSOMSG,"^",2),! Q
     61 .W !!,"Another person is editing Rx "_$P($G(^PSRX(RXRECLOC,0)),"^"),!
     62 K PSOMSG S DIR("A")=$S($P(PSOSD(STA,DNM),"^",2)=12:"Reinstate",1:"Discontinue")_" RX # "_$P(^PSRX(+PSOSD(STA,DNM),0),"^"),DIR(0)="Y",DIR("?")="Enter Y to "_$S($P(PSOSD(STA,DNM),"^",2)=12:"reinstate",1:"discontinue")_" this RX."
     63 D ^DIR K DIR S DA=RXREC S ACT=$S($D(SPCANC):"Reinstated during Rx cancel.",1:$S($P(PSOSD(STA,DNM),"^",2)=12:"Reinstated",1:"Discontinued")_" while "_$S('$G(PSONV):"entering",1:"verifying")_" new RX")
     64 D CMOP^PSOUTL I $G(CMOP("S"))="L" W !,"A CMOP Rx cannot be discontinued during transmission!",! S Y=0 K CMOP
     65 I 'Y W $C(7)," -Prescription was not "_$S($P(PSOSD(STA,DNM),"^",2)=12:"reinstated",1:"discontinued")_"..." D  Q
     66 .S:'$D(PSOCLC) PSOCLC=DUZ S MSG=ACT,REA=$S($P(PSOSD(STA,DNM),"^",2)=12:"R",1:"C") S:$G(DUP) PSORX("DFLG")=1 K DUP D ULRX K RXRECLOC
     67 .I $D(^TMP("PSORXDC",$J,RXREC,0)) K ^TMP("PSORXDC",$J,RXREC,0)
     68 I $P(PSOSD(STA,DNM),"^",2)=16,$G(CLS) W !!,"Prescription "_$P($G(^PSRX(+$G(RXRECLOC),0)),"^")_" is on Provider Hold, it cannot be discontinued.",! D ULRX K CLS,DUP,RXRECLOC S PSORX("DFLG")=1 H 2 Q
     69 S PSOCLC=DUZ,MSG=$S($G(MSG)]"":MSG,1:ACT_" During New RX "_$S('$G(PSONV):"Entry",1:"Verification")_" - Duplicate Rx"),REA=$S($P(PSOSD(STA,DNM),"^",2)=12:"R",1:"C")
     70 W !!,"Duplicate "_$S($G(CLS):"Class",1:"Drug")_" will be discontinued after the acceptance of the new order.",!
     71 S ^TMP("PSORXDC",$J,RXREC,0)="52^"_DA_"^"_MSG_"^"_REA_"^"_ACT_"^"_STA_"^"_DNM,PSONOOR="D"
     72 K RXRECLOC,DUP,CLS,PSONOOR Q
     73CLS K DUP
     74 I $E($G(PSODRUG("VA CLASS")),1,2)="HA",$E($P($G(PSOSD(STA,DNM)),"^",5),1,2)="HA" K PSOELSE Q
     75 S CLS=1,MSG="Discontinued During "_$S('$G(PSONV):"New Prescription Entry",1:"Verification")_" - Duplicate Class" W !,PSONULN
     76 W !?5,$C(7),"*** SAME CLASS *** OF DRUG IN RX #"_$P(^PSRX(+PSOSD(STA,DNM),0),"^")_" FOR "_$P(DNM,"^"),!,"CLASS: "_PSODRUG("VA CLASS")
     77 S CAN=$P(PSOSD(STA,DNM),"^",2)'<11!($P(PSOSD(STA,DNM),"^",2)=1) S RXREC=+PSOSD(STA,DNM) I $P($G(PSOPAR),"^",10) D DATA Q
     78 E  W !,PSONULN K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR,DTOUT,DUOUT,DIRUT
     79 K PSOELSE Q
     80ULRX ;
     81 I '$G(RXRECLOC) Q
     82 D PSOUL^PSSLOCK(RXRECLOC)
     83 Q
     84 ;

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODRG.m

    r613 r623  
    1 PSODRG  ;IHS/DSD/JCM-ORDER ENTRY DRUG SELECTION ;03/30/93
    2         ;;7.0;OUTPATIENT PHARMACY;**20,23,36,53,54,46,112,139,207,148,243,268,208**;DEC 1997;Build 41
    3         ; Modified from FOIA VISTA,
    4         ; Copyright (C) 2007 WorldVistA
    5         ;
    6         ; This program is free software; you can redistribute it and/or modify
    7         ; it under the terms of the GNU General Public License as published by
    8         ; the Free Software Foundation; either version 2 of the License, or
    9         ; (at your option) any later version.
    10         ;
    11         ; This program is distributed in the hope that it will be useful,
    12         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ; GNU General Public License for more details.
    15         ;
    16         ; You should have received a copy of the GNU General Public License
    17         ; along with this program; if not, write to the Free Software
    18         ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    19         ;Reference ^PSDRUG supported by DBIA 221
    20         ;Reference ^PS(50.7 supported by DBIA 2223
    21         ;Reference to PSSDIN supported by DBIA 3166
    22         ;Reference to $$NDCFMT^PSSNDCUT supported by IA 4707
    23         ;----------------------------------------------------------
    24 START   ;
    25         S (PSONEW("DFLG"),PSONEW("FIELD"),PSODRG("QFLG"))=0
    26         D @($S(+$G(PSOEDIT)=1&('$D(DA)):"SELECT^PSODRGN",1:"SELECT"))
    27         G:$G(PSORXED("DFLG")) END ; Select Drug
    28         I $G(PSORX("EDIT")),$G(PSOY),$G(PSODRUG("IEN"))=+PSOY D  G:$G(PSORXED("DFLG")) END
    29         . N NDC D NDC(+$G(PSORXED("IRXN")),0,+PSOY,.NDC) I $G(NDC)="^" S PSORXED("DFLG")=1 Q
    30         . I $G(NDC)'="" S (PSODRUG("NDC"),PSORXED("FLD",27))=NDC
    31         ;
    32         I $G(PSORX("EDIT"))]"",'PSONEW("FIELD") D TRADE
    33         G:PSONEW("DFLG")!(PSODRG("QFLG"))!($G(PSORXED("DFLG"))) END
    34         D SET ; Set various drug information
    35         D NFI ; Display dispense drug/orderable item text
    36         D:'$G(PSOEDIT) POST I $G(PSORX("DFLG")) S PSONEW("DFLG")=1 K:'$G(PSORX("EDIT")) PSORX("DFLG") ; Do any post selection action
    37 END     ;D EOJ
    38         Q
    39         ;------------------------------------------------------------
    40         ;
    41 SELECT  ;
    42         K:'$G(PSORXED) CLOZPAT
    43         K DIC,X,Y,PSODRUG("TRADE NAME"),PSODRUG("NDC"),PSODRUG("DAW") S:$G(POERR)&($P($G(OR0),"^",9)) Y=$P(^PSDRUG($P(OR0,"^",9),0),"^")
    44         I $G(PSODRUG("IEN"))]"" S Y=PSODRUG("NAME"),PSONEW("OLD VAL")=PSODRUG("IEN")
    45         W !,"DRUG: "_$S($G(Y)]"":Y_"// ",1:"") R X:$S($D(DTIME):DTIME,1:300) I '$T S DTOUT=1
    46         I X="",$G(Y)]"" S:Y X=Y S:'X X=$G(PSODRUG("IEN")) S:X X="`"_X
    47         G:X="" SELECT
    48         I X?1."?" W !!,"Answer with DRUG NUMBER, or GENERIC NAME, or VA PRODUCT NAME, or",!,"NATIONAL DRUG CLASS, or SYNONYM" G SELECT
    49         I $G(PSORXED),X["^" S PSORXED("DFLG")=1 G SELECTX
    50         I X="^"!(X["^^")!($D(DTOUT)) S PSONEW("DFLG")=1 G SELECTX
    51         I '$G(POERR),X[U,$L(X)>1 S PSODIR("FLD")=PSONEW("FLD") D JUMP^PSODIR1 S:$G(PSODIR("FIELD")) PSONEW("FIELD")=PSODIR("FIELD") K PSODIR S PSODRG("QFLG")=1 G SELECTX
    52         S DIC=50,DIC(0)="EMQZVT",DIC("T")="",D="B^C^VAPN^VAC"
    53         S DIC("S")="I $S('$D(^PSDRUG(+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0),$S($P($G(^PSDRUG(+Y,2)),""^"",3)'[""O"":0,1:1),$D(^PSDRUG(""ASP"",+$G(^(2)),+Y))"
    54         D MIX^DIC1 K DIC,D
    55         I $D(DTOUT) S PSONEW("DFLG")=1 G SELECTX
    56         I $D(DUOUT) K DUOUT G SELECT
    57         I Y<0 G SELECT
    58         S:$G(PSONEW("OLD VAL"))=+Y&('$G(PSOEDIT)) PSODRG("QFLG")=1
    59         K PSOY S PSOY=Y,PSOY(0)=Y(0)
    60         I $P(PSOY(0),"^")="OTHER DRUG"!($P(PSOY(0),"^")="OUTSIDE DRUG") D TRADE
    61 SELECTX K X,Y,DTOUT,DUOUT,PSONEW("OLD VAL")
    62         Q
    63         ;
    64 NDC(RX,RFL,DRG,NDC)     ; Editing NDC for ECME Released Rx's
    65         S NDC=$S($G(NDC)'="":$G(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL))
    66         I $$STATUS^PSOBPSUT(RX,RFL)="" Q
    67         I '$$RXRLDT^PSOBPSUT(RX,RFL) Q
    68         ;
    69         S NDC=$S($G(NDC)'="":$G(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL))
    70         D NDCEDT^PSONDCUT(RX,.RFL,$G(DRG),$G(PSOSITE),.NDC)
    71         Q
    72         ;
    73 TRADE   ;
    74         K DIR,DIC,DA,X,Y
    75         S DIR(0)="52,6.5" S:$G(PSOTRN)]"" DIR("B")=$G(PSOTRN) D ^DIR K DIR,DIC
    76         I X="@" S Y=X K DIRUT
    77         I $D(DIRUT) S:$D(DUOUT)!$D(DTOUT)&('$D(PSORX("EDIT"))) PSONEW("DFLG")=1 G TRADEX
    78         S PSODRUG("TRADE NAME")=Y
    79 TRADEX  I $G(PSORXED("DFLG")),$D(DIRUT) S PSORXED("DFLG")=1
    80         K DIRUT,DTOUT,DUOUT,X,Y,DA,DR,DIE
    81         Q
    82 SET     ;
    83         N STAT S PSODRUG("IEN")=+PSOY,PSODRUG("VA CLASS")=$P(PSOY(0),"^",2)
    84         S PSODRUG("NAME")=$P(PSOY(0),"^")
    85         S:+$G(^PSDRUG(+PSOY,2)) PSODRUG("OI")=+$G(^(2)),PSODRUG("OIN")=$P(^PS(50.7,+$G(^(2)),0),"^")
    86         S PSODRUG("NDF")=$S($G(^PSDRUG(+PSOY,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)
    87         S PSODRUG("MAXDOSE")=$P(PSOY(0),"^",4),PSODRUG("DEA")=$P(PSOY(0),"^",3)
    88         S PSODRUG("CLN")=$S($D(^PSDRUG(+PSOY,"ND")):+$P(^("ND"),"^",6),1:0)
    89         S PSODRUG("SIG")=$P(PSOY(0),"^",5)
    90         I $G(PSODRUG("NDC"))="" S PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSOY,$G(PSOSITE))
    91         S PSODRUG("DAW")=+$$GET1^DIQ(50,+PSOY,81)
    92         S PSODRUG("STKLVL")=$G(^PSDRUG(+PSOY,660.1))
    93         G:$G(^PSDRUG(+PSOY,660))']"" SETX
    94         S PSOX1=$G(^PSDRUG(+PSOY,660))
    95         S PSODRUG("COST")=$P($G(PSOX1),"^",6)
    96         S PSODRUG("UNIT")=$P($G(PSOX1),"^",8)
    97         S PSODRUG("EXPIRATION DATE")=$P($G(PSOX1),"^",9)
    98 SETX    K PSOX1,PSOY
    99         Q
    100 NFI     ;display restriction/guidelines
    101         D EN^PSSDIN(PSODRUG("OI"),PSODRUG("IEN")) S NFI=$$PROMPT^PSSDIN
    102         I NFI]"","ODY"[NFI D TD^PSONFI
    103         K NFI Q
    104 POST    ;order checks
    105         I $G(PSOAFYN)="Y" G POSTX ;vfam - VOE
    106         K PSORX("INTERVENE") N STAT,SIG,PTR,NDF,VAP S PSORX("DFLG")=0
    107         D ^PSOBUILD
    108         D @$S($G(COPY):"^PSOCPDUP",1:"^PSODRDUP") ; Set PSORX("DFLG")=1 if process to stop
    109         Q:$G(PSORX("DFLG"))
    110         W:$G(PSOFIN)']"" !,"Now doing drug interaction and allergy checks.  Please wait...",!
    111         D ^PSODGDGI
    112         I $G(PSORX("INTERVENE"))]"" D FULL^VALM1,^PSORXI S VALMBCK="R"
    113         G:PSORX("DFLG") POSTX
    114         D:$P($G(^PSDRUG(PSODRUG("IEN"),"CLOZ1")),"^")]"" CLOZ G:PSORX("DFLG") POSTX
    115         K PSORX("INTERVENE")
    116         S PSONOAL="" D ALLERGY^PSOORUT2 D:PSONOAL'="" NOALRGY K PSONOAL
    117         G:PSORX("DFLG") POSTX
    118         I $D(PSODRUG("NDF")) S NDF=$P(PSODRUG("NDF"),"A"),VAP=$P(PSODRUG("NDF"),"A",2),PTR=NDF_"."_VAP
    119         I $G(NDF) D CHK^PSODGAL(PSODFN,"DR",PTR) K NDF,VAP,PTR
    120         I $P($G(PSODRUG("NDF")),"A")=0 D CHK1^PSODGAL(PSODFN)
    121         I $D(PSODRUG("VA CLASS")) D CLASS^PSODGAL(PSODFN)
    122 POSTX   ;
    123         K ^TMP($J,"DI"_PSODFN),^TMP($J,"DI")
    124         K PSORX("INTERVENE"),DA
    125         Q
    126         ;
    127 EOJ     ;
    128         K PSODRG
    129         Q
    130         ;
    131 CLOZ    ;
    132         S ANQRTN=$P(^PSDRUG(PSODRUG("IEN"),"CLOZ1"),"^"),ANQX=0
    133         S P(5)=PSODRUG("IEN"),DFN=PSODFN,X=ANQRTN
    134         X ^%ZOSF("TEST") I  D @("^"_ANQRTN) S:$G(ANQX) PSORX("DFLG")=1
    135         K P(5),ANQRTN,ANQX,X
    136         Q
    137         ;
    138 EN(DRG) ;returns lab test identified for clozapine order checking
    139         K LAB I $P($G(^PSDRUG(DRG,"CLOZ1")),"^")'="PSOCLO1" S LAB("NOT")=0 Q
    140         I $P($G(^PSDRUG(DRG,"CLOZ1")),"^")="PSOCLO1" D
    141         .S (CNT,I)=0 F  S I=$O(^PSDRUG(DRG,"CLOZ2",I)) Q:'I  S CNT=$G(CNT)+1
    142         .I CNT'=2 S LAB("BAD TEST")=0 K CNT Q
    143         .K CNT F I=0:0 S I=$O(^PSDRUG(DRG,"CLOZ2",I)) Q:'I  D
    144         ..S LABT=$S($P(^PSDRUG(DRG,"CLOZ2",I,0),"^",4)=1:"WBC",1:"ANC"),LAB(LABT)=$P(^PSDRUG(DRG,"CLOZ2",I,0),"^")_"^"_$P(^(0),"^",3)_"^"_$P(^(0),"^",4)
    145         K LABT,I
    146         Q
    147 NOALRGY ;
    148         W $C(7),!,"There is no allergy assessment on file for this patient."
    149         W !,"You will be prompted to intervene if you continue with this prescription"
    150         K DIR
    151         S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to Continue?: ",DIR("B")="N" D ^DIR
    152         I 'Y S PSORX("DFLG")=1 Q
    153         D ^PSORXI
    154         Q
     1PSODRG ;IHS/DSD/JCM-ORDER ENTRY DRUG SELECTION ;03/30/93
     2 ;;7.0;OUTPATIENT PHARMACY;**20,23,36,53,54,46,112,139,207,148,243,268,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 ;Reference ^PSDRUG supported by DBIA 221
     20 ;Reference ^PS(50.7 supported by DBIA 2223
     21 ;Reference to PSSDIN supported by DBIA 3166
     22 ;Reference to $$NDCFMT^PSSNDCUT supported by IA 4707
     23 ;----------------------------------------------------------
     24START ;
     25 S (PSONEW("DFLG"),PSONEW("FIELD"),PSODRG("QFLG"))=0
     26 D @($S(+$G(PSOEDIT)=1&('$D(DA)):"SELECT^PSODRGN",1:"SELECT"))
     27 G:$G(PSORXED("DFLG")) END ; Select Drug
     28 I $G(PSORX("EDIT")),$G(PSOY),$G(PSODRUG("IEN"))=+PSOY D  G:$G(PSORXED("DFLG")) END
     29 . N NDC D NDC(+$G(PSORXED("IRXN")),0,+PSOY,.NDC) I $G(NDC)="^" S PSORXED("DFLG")=1 Q
     30 . I $G(NDC)'="" S (PSODRUG("NDC"),PSORXED("FLD",27))=NDC
     31 ;
     32 I $G(PSORX("EDIT"))]"",'PSONEW("FIELD") D TRADE
     33 G:PSONEW("DFLG")!(PSODRG("QFLG"))!($G(PSORXED("DFLG"))) END
     34 D SET ; Set various drug information
     35 D NFI ; Display dispense drug/orderable item text
     36 D:'$G(PSOEDIT) POST I $G(PSORX("DFLG")) S PSONEW("DFLG")=1 K:'$G(PSORX("EDIT")) PSORX("DFLG") ; Do any post selection action
     37END ;D EOJ
     38 Q
     39 ;------------------------------------------------------------
     40 ;
     41SELECT ;
     42 K:'$G(PSORXED) CLOZPAT
     43 K DIC,X,Y,PSODRUG("TRADE NAME"),PSODRUG("NDC"),PSODRUG("DAW") S:$G(POERR)&($P($G(OR0),"^",9)) Y=$P(^PSDRUG($P(OR0,"^",9),0),"^")
     44 I $G(PSODRUG("IEN"))]"" S Y=PSODRUG("NAME"),PSONEW("OLD VAL")=PSODRUG("IEN")
     45 W !,"DRUG: "_$S($G(Y)]"":Y_"// ",1:"") R X:$S($D(DTIME):DTIME,1:300) I '$T S DTOUT=1
     46 I X="",$G(Y)]"" S:Y X=Y S:'X X=$G(PSODRUG("IEN")) S:X X="`"_X
     47 G:X="" SELECT
     48 I X?1."?" W !!,"Answer with DRUG NUMBER, or GENERIC NAME, or VA PRODUCT NAME, or",!,"NATIONAL DRUG CLASS, or SYNONYM" G SELECT
     49 I $G(PSORXED),X["^" S PSORXED("DFLG")=1 G SELECTX
     50 I X="^"!(X["^^")!($D(DTOUT)) S PSONEW("DFLG")=1 G SELECTX
     51 I '$G(POERR),X[U,$L(X)>1 S PSODIR("FLD")=PSONEW("FLD") D JUMP^PSODIR1 S:$G(PSODIR("FIELD")) PSONEW("FIELD")=PSODIR("FIELD") K PSODIR S PSODRG("QFLG")=1 G SELECTX
     52 S DIC=50,DIC(0)="EMQZVT",DIC("T")="",D="B^C^VAPN^VAC"
     53 S DIC("S")="I $S('$D(^PSDRUG(+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0),$S($P($G(^PSDRUG(+Y,2)),""^"",3)'[""O"":0,1:1),$D(^PSDRUG(""ASP"",+$G(^(2)),+Y))"
     54 D MIX^DIC1 K DIC,D
     55 I $D(DTOUT) S PSONEW("DFLG")=1 G SELECTX
     56 I $D(DUOUT) K DUOUT G SELECT
     57 I Y<0 G SELECT
     58 S:$G(PSONEW("OLD VAL"))=+Y&('$G(PSOEDIT)) PSODRG("QFLG")=1
     59 K PSOY S PSOY=Y,PSOY(0)=Y(0)
     60 I $P(PSOY(0),"^")="OTHER DRUG"!($P(PSOY(0),"^")="OUTSIDE DRUG") D TRADE
     61SELECTX K X,Y,DTOUT,DUOUT,PSONEW("OLD VAL")
     62 Q
     63 ;
     64NDC(RX,RFL,DRG,NDC) ; Editing NDC for ECME Released Rx's
     65 S NDC=$S($G(NDC)'="":$G(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL))
     66 I $$STATUS^PSOBPSUT(RX,RFL)="" Q
     67 I '$$RXRLDT^PSOBPSUT(RX,RFL) Q
     68 ;
     69 S NDC=$S($G(NDC)'="":$G(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL))
     70 D NDCEDT^PSONDCUT(RX,.RFL,$G(DRG),$G(PSOSITE),.NDC)
     71 Q
     72 ;
     73TRADE ;
     74 K DIR,DIC,DA,X,Y
     75 S DIR(0)="52,6.5" S:$G(PSOTRN)]"" DIR("B")=$G(PSOTRN) D ^DIR K DIR,DIC
     76 I X="@" S Y=X K DIRUT
     77 I $D(DIRUT) S:$D(DUOUT)!$D(DTOUT)&('$D(PSORX("EDIT"))) PSONEW("DFLG")=1 G TRADEX
     78 S PSODRUG("TRADE NAME")=Y
     79TRADEX I $G(PSORXED("DFLG")),$D(DIRUT) S PSORXED("DFLG")=1
     80 K DIRUT,DTOUT,DUOUT,X,Y,DA,DR,DIE
     81 Q
     82SET ;
     83 N STAT S PSODRUG("IEN")=+PSOY,PSODRUG("VA CLASS")=$P(PSOY(0),"^",2)
     84 S PSODRUG("NAME")=$P(PSOY(0),"^")
     85 S:+$G(^PSDRUG(+PSOY,2)) PSODRUG("OI")=+$G(^(2)),PSODRUG("OIN")=$P(^PS(50.7,+$G(^(2)),0),"^")
     86 S PSODRUG("NDF")=$S($G(^PSDRUG(+PSOY,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)
     87 S PSODRUG("MAXDOSE")=$P(PSOY(0),"^",4),PSODRUG("DEA")=$P(PSOY(0),"^",3)
     88 S PSODRUG("CLN")=$S($D(^PSDRUG(+PSOY,"ND")):+$P(^("ND"),"^",6),1:0)
     89 S PSODRUG("SIG")=$P(PSOY(0),"^",5)
     90 I $G(PSODRUG("NDC"))="" S PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSOY,$G(PSOSITE))
     91 S PSODRUG("DAW")=+$$GET1^DIQ(50,+PSOY,81)
     92 S PSODRUG("STKLVL")=$G(^PSDRUG(+PSOY,660.1))
     93 G:$G(^PSDRUG(+PSOY,660))']"" SETX
     94 S PSOX1=$G(^PSDRUG(+PSOY,660))
     95 S PSODRUG("COST")=$P($G(PSOX1),"^",6)
     96 S PSODRUG("UNIT")=$P($G(PSOX1),"^",8)
     97 S PSODRUG("EXPIRATION DATE")=$P($G(PSOX1),"^",9)
     98SETX K PSOX1,PSOY
     99 Q
     100NFI ;display restriction/guidelines
     101 D EN^PSSDIN(PSODRUG("OI"),PSODRUG("IEN")) S NFI=$$PROMPT^PSSDIN
     102 I NFI]"","ODY"[NFI D TD^PSONFI
     103 K NFI Q
     104POST ;order checks
     105 I $G(PSOAFYN)="Y" G POSTX ;vfam - VOE
     106 K PSORX("INTERVENE") N STAT,SIG,PTR,NDF,VAP S PSORX("DFLG")=0
     107 D ^PSOBUILD
     108 D @$S($G(COPY):"^PSOCPDUP",1:"^PSODRDUP") ; Set PSORX("DFLG")=1 if process to stop
     109 Q:$G(PSORX("DFLG"))
     110 W:$G(PSOFIN)']"" !,"Now doing drug interaction and allergy checks.  Please wait...",!
     111 D ^PSODGDGI
     112 I $G(PSORX("INTERVENE"))]"" D FULL^VALM1,^PSORXI S VALMBCK="R"
     113 G:PSORX("DFLG") POSTX
     114 D:$P($G(^PSDRUG(PSODRUG("IEN"),"CLOZ1")),"^")]"" CLOZ G:PSORX("DFLG") POSTX
     115 K PSORX("INTERVENE")
     116 S PSONOAL="" D ALLERGY^PSOORUT2 D:PSONOAL'="" NOALRGY K PSONOAL
     117 G:PSORX("DFLG") POSTX
     118 I $D(PSODRUG("NDF")) S NDF=$P(PSODRUG("NDF"),"A"),VAP=$P(PSODRUG("NDF"),"A",2),PTR=NDF_"."_VAP
     119 I $G(NDF) D CHK^PSODGAL(PSODFN,"DR",PTR) K NDF,VAP,PTR
     120 I $P($G(PSODRUG("NDF")),"A")=0 D CHK1^PSODGAL(PSODFN)
     121 I $D(PSODRUG("VA CLASS")) D CLASS^PSODGAL(PSODFN)
     122POSTX ;
     123 K ^TMP($J,"DI"_PSODFN),^TMP($J,"DI")
     124 K PSORX("INTERVENE"),DA
     125 Q
     126 ;
     127EOJ ;
     128 K PSODRG
     129 Q
     130 ;
     131CLOZ ;
     132 S ANQRTN=$P(^PSDRUG(PSODRUG("IEN"),"CLOZ1"),"^"),ANQX=0
     133 S P(5)=PSODRUG("IEN"),DFN=PSODFN,X=ANQRTN
     134 X ^%ZOSF("TEST") I  D @("^"_ANQRTN) S:$G(ANQX) PSORX("DFLG")=1
     135 K P(5),ANQRTN,ANQX,X
     136 Q
     137 ;
     138EN(DRG) ;returns lab test identified for clozapine order checking
     139 K LAB I $P($G(^PSDRUG(DRG,"CLOZ1")),"^")'="PSOCLO1" S LAB("NOT")=0 Q
     140 I $P($G(^PSDRUG(DRG,"CLOZ1")),"^")="PSOCLO1" D
     141 .S (CNT,I)=0 F  S I=$O(^PSDRUG(DRG,"CLOZ2",I)) Q:'I  S CNT=$G(CNT)+1
     142 .I CNT'=2 S LAB("BAD TEST")=0 K CNT Q
     143 .K CNT F I=0:0 S I=$O(^PSDRUG(DRG,"CLOZ2",I)) Q:'I  D
     144 ..S LABT=$S($P(^PSDRUG(DRG,"CLOZ2",I,0),"^",4)=1:"WBC",1:"ANC"),LAB(LABT)=$P(^PSDRUG(DRG,"CLOZ2",I,0),"^")_"^"_$P(^(0),"^",3)_"^"_$P(^(0),"^",4)
     145 K LABT,I
     146 Q
     147NOALRGY ;
     148 W $C(7),!,"There is no allergy assessment on file for this patient."
     149 W !,"You will be prompted to intervene if you continue with this prescription"
     150 K DIR
     151 S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to Continue?: ",DIR("B")="N" D ^DIR
     152 I 'Y S PSORX("DFLG")=1 Q
     153 D ^PSORXI
     154 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHELP.m

    r613 r623  
    1 PSOHELP ;BHAM ISC/SAB-outpatient utility routine ; 10/17/07 7:41am
    2         ;;7.0;OUTPATIENT PHARMACY;**3,23,29,48,46,117,131,222,268,206**;DEC 1997;Build 39
    3         ;External reference ^PS(51 supported by DBIA 2224
    4         ;External reference ^PSDRUG( supported by DBIA 221
    5         ;External reference ^PS(56 supported by DBIA 2229
    6         ;External reference ^PSNPPIP supported by DBIA 2261
    7         ;
    8 XREF    D XREF^PSOHELP3
    9         Q
    10 SIG     ;checks PI for RXs
    11         K VALMSG
    12         I $E(X)=" " D EN^DDIOL("Leading spaces should not entered in the Patient Instructions! ","","$C(7),!") S VALMSG="There are leading spaces in Patient Instructions!"
    13 SIGONE  K INS1 Q:$L(X)<1  F Z0=1:1:$L(X," ") G:Z0="" EN S Z1=$P(X," ",Z0) D  G:'$D(X) EN
    14         .I $L(Z1)>32 W $C(7),!?5,"MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.",! K X Q
    15         .D:$D(X)&($G(Z1)]"")  S INS1=$G(INS1)_" "_Z1
    16         ..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y!($P($G(^PS(51,+Y,0)),"^",4)>1)  S Z1=$P(^PS(51,Y,0),"^",2)
    17         ..I $G(^PS(51,+Y,9))]"" S Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9)
    18 EN      K Z1,Z0
    19         Q
    20 SSIG    ;other lang. mods
    21         K VALMSG
    22         I $E(X)=" " D EN^DDIOL("Leading spaces should not entered in the Patient Instructions! ","","$C(7),!") S VALMSG="There are leading spaces in Patient Instructions!"
    23         K SINS1 Q:$L(X)<1  F Z0=1:1:$L(X," ") G:Z0="" EX S Z1=$P(X," ",Z0) D  G:'$D(X) EX
    24         .I $L(Z1)>32 W $C(7),!?5,"MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.",! K X Q
    25         .D:$D(X)&($G(Z1)]"")  S SINS1=$G(SINS1)_" "_Z1
    26         ..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y  S Z1=$P(^PS(51,Y,0),"^",2)
    27         ..I $G(^PS(51,+Y,4))]"" S Z1=^PS(51,+Y,4) ;,Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9)
    28 EX      K Z1,Z0
    29         Q
    30 QTY     ;Check quantity dispensed against inventory
    31         Q:'$G(PSODRUG("IEN"))
    32         S Z0=$S($G(PSODRUG("IEN"))]"":PSODRUG("IEN"),$G(PSXYES):$P(^PSRX(ZRX,0),"^",6),$D(^PSRX(DA,0)):+$P(^(0),"^",6),1:0)
    33         I $D(^PSDRUG("AQ",Z0)),(+X'=X) K X,Z0 Q
    34         S Z1=$S($D(^PSDRUG(Z0,660.1)):^(660.1),1:0)+(+X) D:X>Z1 EN^DDIOL("  Greater Than Current Inventory!","","$C(7)") K Z1
    35         S ZX=X,ZZ0=$G(D0),D0=Z0
    36         S Y(18,2)=$S($D(^PSDRUG(D0,660)):^(660),1:""),Y(18,1)=$S($D(^(660.1)):^(660.1),1:"")
    37         S X=$P(Y(18,1),"^",1),X=$S($P(Y(18,2),"^",5):X/$P(Y(18,2),"^",5),1:"*******")
    38         S X=$J(X,0,2)
    39         D:X<$S($D(^PSDRUG(Z0,660)):+^(660),1:1) EN^DDIOL("  Below Reorder Level.","","$C(7)") S X=ZX,D0=$G(ZZ0) K ZZ0,Z0,ZX
    40         Q
    41 HELP    ;qty help
    42         G:$G(PSOFDR) HLP
    43         S Z0=$S($G(PSODRUG("IEN"))]"":PSODRUG("IEN"),$G(PSXYES):$P(^PSRX(ZRX,0),"^",6),$D(^PSRX(DA,0)):$P(^PSRX(DA,0),"^",6),1:0)
    44 HLP     S Z0=+$G(PSODRUG("IEN"))  I $D(^PSDRUG("AQ",Z0)) D EN^DDIOL("This is a CMOP drug. The quantity may not contain alpha characters (i.e.; ML)","","!!") D EN^DDIOL("or more than two fractional decimal places (i.e.; .01).","","!") D  K Z0 Q
    45         .D EN^DDIOL("Enter a number between 0 and 99999999 inclusive. The total entry cannot","","!") D EN^DDIOL("exceed 11 characters.","","!")
    46         D EN^DDIOL("Enter a whole number between 0 and 99999999 inclusive.  Alpha characters are","","!!")
    47         D EN^DDIOL("not allowed, and the entry cannot exceed 11 characters, or contain more than","","!") D EN^DDIOL("two fractional decimal places (i.e.; .01).","","!")
    48         K Z0
    49         Q
    50 ADD     ;add/edited local drug/drug interactions
    51         W ! S DIC("A")="Select Drug Interaction: ",DIC(0)="AEMQL",DLAYGO=56
    52         S (DIC,DIE)="^PS(56,",DIC("S")="I '$P(^(0),""^"",5)" D ^DIC G:"^"[X QU G:Y<0 ADD S DA=+Y,DR="[PSO INTERACT]" L +^PS(56,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !,"Entry is being edited by another user. Try Later!",! G ADD
    53         D ^DIE L:$G(DA) -^PS(56,DA) K DA G ADD
    54 QU      L -^PS(56,DA) K X,DIC,DIE,DA
    55         Q
    56 CRI     ;change drug interaction severity to critical from significant
    57         W ! S DIC("A")="Select Drug Interaction: ",DIC(0)="AEQM",(DIC,DIE)="^PS(56,",DIC("S")="I $P(^(0),""^"",4)=2" D ^DIC G:"^"[X QU G:Y<0 CRI S DA=+Y,DR=3
    58         L +^PS(56,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !,"Entry is being edited by another user. Try Later!",! G CRI
    59         D ^DIE L -^PS(56,DA) K DA G CRI
    60         G QU
    61         Q
    62 MAX     S:$G(EXH) P(7)=$P(^PSRX(DA,0),"^",8),P(5)=$P(^(0),"^",6),P(2)=+$P(^(0),"^",3) S:P(2) PTST=$G(^PS(53,P(2),0)),PTDY=$P($G(^(0)),"^",3),PTRF=$P($G(^(0)),"^",4)
    63         S PSODEA=$P(^PSDRUG(P(5),0),"^",3),CS=0
    64         I $D(CLOZPAT) S MAX=$S(CLOZPAT=2&($P(^PSRX(DA,0),"^",8)=14):1,CLOZPAT=2&($P(^PSRX(DA,0),"^",8)=7):3,CLOZPAT=1&($P(^PSRX(DA,0),"^",8)=7):1,1:0),MIN=0 Q
    65         I PSODEA["A"&(PSODEA'["B")!(PSODEA["F")!(PSODEA[1)!(PSODEA[2) D EN^DDIOL("No refills allowed on "_$S(PSODEA["A":"this narcotic drug.",1:"this drug."),"","!") D EN^DDIOL(" ","","!") S $P(^PSRX(DA,0),"^",9)=0 K X,Y,PSODEA,CS,PTST Q
    66         F DEA=1:1 Q:$E(PSODEA,DEA)=""  I $E(+PSODEA,DEA)>1,$E(+PSODEA,DEA)<6 S CS=1
    67         S PSOELSE=CS I PSOELSE D
    68         .S PSOX1=$S(PTRF>5:5,1:PTRF),PSOT=$S(PSOX1=5:5,1:PSOX1)
    69         .S PSOT=$S('PSOT:0,P(7)=90:1,1:PSOT),PSDY1=$S(P(7)<60:5,P(7)'<60&(P(7)'>89):2,P(7)=90:1,1:0) S MAX=$S(PSOT'>PSDY1:PSOT,1:PSDY1)
    70         I 'PSOELSE D
    71         .S PSOX1=PTRF,PSOT=$S(PSOX1=11:11,1:PSOX1),PSOT=$S('PSOT:0,P(7)=90:3,1:PSOT)
    72         .S PSDY1=$S(P(7)<60:11,P(7)'<60&(P(7)'>89):5,P(7)=90:3,1:0) S MAX=$S(PSOT'>PSDY1:PSOT,1:PSDY1)
    73         K PSODEA,PSOELSE,PSOT,PSOX1,PSDY,PSDY1,DEA,CS
    74         I $D(X) S MIN=0 I $D(DA) F REF=0:0 S REF=$O(^PSRX(DA,1,REF)) Q:'REF  I $D(^(REF,0)) S MIN=MIN+1
    75         I $G(EXH) D EN^DDIOL("Enter a number Between "_MIN_" AND "_MAX_".","","!?10") K P(2),P(5),P(7),MAX,MAX1,MIN,REF
    76         Q
    77         ;
    78 REF     S PSRF=X,P(7)=$P(^PSRX(DA,0),"^",8),P(5)=$P(^(0),"^",6),P(2)=+$P(^(0),"^",3) S:P(2) PTST=$G(^PS(53,P(2),0)) S PTDY=$P(^(0),"^",3),PTRF=$P(^(0),"^",4)
    79         D MAX Q:'$D(X)  I (+X'=X)!(X<0)!(X>MAX)!(X?.E1"."1N.N) D EN^DDIOL(" ** MAX REFILLS ALLOWED ARE "_MAX_" ** ","","$C(7)") K X
    80         I $D(X),X<MIN D EN^DDIOL(" ** PATIENT HAS ALREADY RECEIVED "_MIN_" REFILLS ** ","","$C(7)") K X
    81         D DAYS^PSOUTLA
    82         K PTDY,PTRF,MAX,DAYS,PSDAYS,PSODEA,PSOX,PSOX1,PSDY,PSDY1,DEA,CS,PTST,PSRF,MIN,REF,P(2),P(7),P(5),MAX1
    83         Q
    84 PAT     ;patient field screen in file 52
    85         N DIC,DIE S DFN=X D INP^VADPT,DEM^VADPT
    86         I $P(VADM(6),"^") D EN^DDIOL("PATIENT DIED "_$P(VADM(6),"^",2),"","$C(7),!?10") D EN^DDIOL(" ","","!") K X,DFN Q
    87         I $P(VAIN(4),"^") D EN^DDIOL("PATIENT IS AN INPATIENT ON WARD "_$P(VAIN(4),"^",2)_" !!","","$C(7),!?10") K DIR D DIR K VA,VADN,VAIN Q
    88         E  S X=DFN K DFN,DIRUT,DTOUT,DUOUT
    89         Q
    90 DIR     S DIR(0)="Y",DIR("B")="YES",DIR("A")="DO YOU WISH TO CONTINUE" D ^DIR K DIR
    91         K:'Y X S:Y X=DFN K DFN,DIRUT,DTOUT,DUOUT,VA,VADM,VAIN
    92         Q
    93 BG      ;prevents editing of display groups with patients from name to ticket
    94         S $P(^PS(59.3,DA,0),"^",2)=PDP W !,$C(7),"The display cannot be changed from NAME to TICKET when patients are",!,"already in the Display Group.  All patients must be purged and re-entered.",!,"Ticket numbers must be issued !!",! K Y,PDP
    95         Q
    96 CLNAP   ;quits action profile
    97         Q
    98 PRMI    ;prints medication instruction sheets.  select drug.
    99         S X="PSNPPIP" X ^%ZOSF("TEST") I '$T S VALMBCK="",VALMSG="Medication Instruction Sheets Not Installed!" Q
    100         I $G(PSODFN) N PSNDFN S PSNDFN=PSODFN
    101         W !! K PSNPPI("MESSAGE") D FULL^VALM1,^PSNPPIP S VALMBCK="R"
    102         I $G(PSNPPI("MESSAGE"))]"" D
    103         .K DIR W PSNPPI("MESSAGE"),! S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DIRUT,PSNPPI("MESSGAE")
    104         Q
    105 PRMID   ;prints medication instruction sheets.  pass in drug.
    106         I $T(ENOP^PSNPPIP)']"" S VALMBCK="",VALMSG="Medication Instruction Sheets Not Installed!" Q
    107         K PSNPPI("MESSAGE") D FULL^VALM1
    108         W !! D ENOP^PSNPPIP($P(RX0,"^",6),$G(^PSRX(RXN,"TN")),$P(RX0,"^"),PSODFN)
    109         S VALMBCK="R" I $G(PSNPPI("MESSAGE"))]"" D
    110         .K DIR W PSNPPI("MESSAGE"),! S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DIRUT,PSNPPI("MESSGAE")
    111         Q
     1PSOHELP ;BHAM ISC/SAB-outpatient utility routine ; 2/17/93 18:00:36
     2 ;;7.0;OUTPATIENT PHARMACY;**3,23,29,48,46,117,131,222,268**;DEC 1997;Build 9
     3 ;External reference ^PS(51 supported by DBIA 2224
     4 ;External reference ^PSDRUG( supported by DBIA 221
     5 ;External reference ^PS(56 supported by DBIA 2229
     6 ;External reference ^PSNPPIP supported by DBIA 2261
     7 ;
     8XREF D XREF^PSOHELP3
     9 Q
     10SIG ;checks PI for RXs
     11 K VALMSG
     12 I $E(X)=" " D EN^DDIOL("Leading spaces should not entered in the Patient Instructions! ","","$C(7),!") S VALMSG="There are leading spaces in Patient Instructions!"
     13SIGONE K INS1 Q:$L(X)<1  F Z0=1:1:$L(X," ") G:Z0="" EN S Z1=$P(X," ",Z0) D  G:'$D(X) EN
     14 .I $L(Z1)>32 W $C(7),!?5,"MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.",! K X Q
     15 .D:$D(X)&($G(Z1)]"")  S INS1=$G(INS1)_" "_Z1
     16 ..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y!($P($G(^PS(51,+Y,0)),"^",4)>1)  S Z1=$P(^PS(51,Y,0),"^",2)
     17 ..I $G(^PS(51,+Y,9))]"" S Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9)
     18EN K Z1,Z0
     19 Q
     20SSIG ;other lang. mods
     21 K VALMSG
     22 I $E(X)=" " D EN^DDIOL("Leading spaces should not entered in the Patient Instructions! ","","$C(7),!") S VALMSG="There are leading spaces in Patient Instructions!"
     23 K SINS1 Q:$L(X)<1  F Z0=1:1:$L(X," ") G:Z0="" EX S Z1=$P(X," ",Z0) D  G:'$D(X) EX
     24 .I $L(Z1)>32 W $C(7),!?5,"MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.",! K X Q
     25 .D:$D(X)&($G(Z1)]"")  S SINS1=$G(SINS1)_" "_Z1
     26 ..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y  S Z1=$P(^PS(51,Y,0),"^",2)
     27 ..I $G(^PS(51,+Y,4))]"" S Z1=^PS(51,+Y,4) ;,Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9)
     28EX K Z1,Z0
     29 Q
     30QTY ;Check quantity dispensed against inventory
     31 Q:'$G(PSODRUG("IEN"))
     32 S Z0=$S($G(PSODRUG("IEN"))]"":PSODRUG("IEN"),$G(PSXYES):$P(^PSRX(ZRX,0),"^",6),$D(^PSRX(DA,0)):+$P(^(0),"^",6),1:0)
     33 I $D(^PSDRUG("AQ",Z0)),(+X'=X) K X,Z0 Q
     34 S Z1=$S($D(^PSDRUG(Z0,660.1)):^(660.1),1:0)+(+X) D:X>Z1 EN^DDIOL("  Greater Than Current Inventory!","","$C(7)") K Z1
     35 S ZX=X,ZZ0=$G(D0),D0=Z0
     36 S Y(18,2)=$S($D(^PSDRUG(D0,660)):^(660),1:""),Y(18,1)=$S($D(^(660.1)):^(660.1),1:"")
     37 S X=$P(Y(18,1),"^",1),X=$S($P(Y(18,2),"^",5):X/$P(Y(18,2),"^",5),1:"*******")
     38 S X=$J(X,0,2)
     39 D:X<$S($D(^PSDRUG(Z0,660)):+^(660),1:1) EN^DDIOL("  Below Reorder Level.","","$C(7)") S X=ZX,D0=$G(ZZ0) K ZZ0,Z0,ZX
     40 Q
     41HELP ;qty help
     42 G:$G(PSOFDR) HLP
     43 S Z0=$S($G(PSODRUG("IEN"))]"":PSODRUG("IEN"),$G(PSXYES):$P(^PSRX(ZRX,0),"^",6),$D(^PSRX(DA,0)):$P(^PSRX(DA,0),"^",6),1:0)
     44HLP S Z0=+$G(PSODRUG("IEN"))  I $D(^PSDRUG("AQ",Z0)) D EN^DDIOL("This is a CMOP drug. The quantity may not contain alpha characters (i.e.; ML)","","!!") D EN^DDIOL("or more than two fractional decimal places (i.e.; .01).","","!") D  K Z0 Q
     45 .D EN^DDIOL("Enter a number between 0 and 99999999 inclusive. The total entry cannot","","!") D EN^DDIOL("exceed 11 characters.","","!")
     46 D EN^DDIOL("Enter a whole number between 0 and 99999999 inclusive.  Alpha characters are","","!!")
     47 D EN^DDIOL("not allowed, and the entry cannot exceed 11 characters, or contain more than","","!") D EN^DDIOL("two fractional decimal places (i.e.; .01).","","!")
     48 K Z0
     49 Q
     50ADD ;add/edited local drug/drug interactions
     51 W ! S DIC("A")="Select Drug Interaction: ",DIC(0)="AEMQL",DLAYGO=56
     52 S (DIC,DIE)="^PS(56,",DIC("S")="I '$P(^(0),""^"",5)" D ^DIC G:"^"[X QU G:Y<0 ADD S DA=+Y,DR="[PSO INTERACT]" L +^PS(56,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !,"Entry is being edited by another user. Try Later!",! G ADD
     53 D ^DIE L:$G(DA) -^PS(56,DA) K DA G ADD
     54QU L -^PS(56,DA) K X,DIC,DIE,DA
     55 Q
     56CRI ;change drug interaction severity to critical from significant
     57 W ! S DIC("A")="Select Drug Interaction: ",DIC(0)="AEQM",(DIC,DIE)="^PS(56,",DIC("S")="I $P(^(0),""^"",4)=2" D ^DIC G:"^"[X QU G:Y<0 CRI S DA=+Y,DR=3
     58 L +^PS(56,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !,"Entry is being edited by another user. Try Later!",! G CRI
     59 D ^DIE L -^PS(56,DA) K DA G CRI
     60 G QU
     61 Q
     62MAX S:$G(EXH) P(7)=$P(^PSRX(DA,0),"^",8),P(5)=$P(^(0),"^",6),P(2)=+$P(^(0),"^",3) S:P(2) PTST=$G(^PS(53,P(2),0)),PTDY=$P($G(^(0)),"^",3),PTRF=$P($G(^(0)),"^",4)
     63 S PSODEA=$P(^PSDRUG(P(5),0),"^",3),CS=0
     64 I $D(CLOZPAT) S MAX=$S(CLOZPAT=2&($P(^PSRX(DA,0),"^",8)=14):1,CLOZPAT=2&($P(^PSRX(DA,0),"^",8)=7):3,CLOZPAT=1&($P(^PSRX(DA,0),"^",8)=7):1,1:0),MIN=0 Q
     65 I PSODEA["A"&(PSODEA'["B")!(PSODEA["F") D EN^DDIOL("No refills allowed on "_$S(PSODEA["F":"this drug.",1:"Narcotics .."),"","!") D EN^DDIOL(" ","","!") S $P(^PSRX(DA,0),"^",9)=0 K X,Y,PSODEA,CS,PTST Q
     66 F DEA=1:1 Q:$E(PSODEA,DEA)=""  I $E(+PSODEA,DEA)>1,$E(+PSODEA,DEA)<6 S CS=1
     67 S PSOELSE=CS I PSOELSE D
     68 .S PSOX1=$S(PTRF>5:5,1:PTRF),PSOT=$S(PSOX1=5:5,1:PSOX1)
     69 .S PSOT=$S('PSOT:0,P(7)=90:1,1:PSOT),PSDY1=$S(P(7)<60:5,P(7)'<60&(P(7)'>89):2,P(7)=90:1,1:0) S MAX=$S(PSOT'>PSDY1:PSOT,1:PSDY1)
     70 I 'PSOELSE D
     71 .S PSOX1=PTRF,PSOT=$S(PSOX1=11:11,1:PSOX1),PSOT=$S('PSOT:0,P(7)=90:3,1:PSOT)
     72 .S PSDY1=$S(P(7)<60:11,P(7)'<60&(P(7)'>89):5,P(7)=90:3,1:0) S MAX=$S(PSOT'>PSDY1:PSOT,1:PSDY1)
     73 K PSODEA,PSOELSE,PSOT,PSOX1,PSDY,PSDY1,DEA,CS
     74 I $D(X) S MIN=0 I $D(DA) F REF=0:0 S REF=$O(^PSRX(DA,1,REF)) Q:'REF  I $D(^(REF,0)) S MIN=MIN+1
     75 I $G(EXH) D EN^DDIOL("Enter a number Between "_MIN_" AND "_MAX_".","","!?10") K P(2),P(5),P(7),MAX,MAX1,MIN,REF
     76 Q
     77 ;
     78REF S PSRF=X,P(7)=$P(^PSRX(DA,0),"^",8),P(5)=$P(^(0),"^",6),P(2)=+$P(^(0),"^",3) S:P(2) PTST=$G(^PS(53,P(2),0)) S PTDY=$P(^(0),"^",3),PTRF=$P(^(0),"^",4)
     79 D MAX Q:'$D(X)  I (+X'=X)!(X<0)!(X>MAX)!(X?.E1"."1N.N) D EN^DDIOL(" ** MAX REFILLS ALLOWED ARE "_MAX_" ** ","","$C(7)") K X
     80 I $D(X),X<MIN D EN^DDIOL(" ** PATIENT HAS ALREADY RECEIVED "_MIN_" REFILLS ** ","","$C(7)") K X
     81 D DAYS^PSOUTLA
     82 K PTDY,PTRF,MAX,DAYS,PSDAYS,PSODEA,PSOX,PSOX1,PSDY,PSDY1,DEA,CS,PTST,PSRF,MIN,REF,P(2),P(7),P(5),MAX1
     83 Q
     84PAT ;patient field screen in file 52
     85 N DIC,DIE S DFN=X D INP^VADPT,DEM^VADPT
     86 I $P(VADM(6),"^") D EN^DDIOL("PATIENT DIED "_$P(VADM(6),"^",2),"","$C(7),!?10") D EN^DDIOL(" ","","!") K X,DFN Q
     87 I $P(VAIN(4),"^") D EN^DDIOL("PATIENT IS AN INPATIENT ON WARD "_$P(VAIN(4),"^",2)_" !!","","$C(7),!?10") K DIR D DIR K VA,VADN,VAIN Q
     88 E  S X=DFN K DFN,DIRUT,DTOUT,DUOUT
     89 Q
     90DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="DO YOU WISH TO CONTINUE" D ^DIR K DIR
     91 K:'Y X S:Y X=DFN K DFN,DIRUT,DTOUT,DUOUT,VA,VADM,VAIN
     92 Q
     93BG ;prevents editing of display groups with patients from name to ticket
     94 S $P(^PS(59.3,DA,0),"^",2)=PDP W !,$C(7),"The display cannot be changed from NAME to TICKET when patients are",!,"already in the Display Group.  All patients must be purged and re-entered.",!,"Ticket numbers must be issued !!",! K Y,PDP
     95 Q
     96CLNAP ;quits action profile
     97 Q
     98PRMI ;prints medication instruction sheets.  select drug.
     99 S X="PSNPPIP" X ^%ZOSF("TEST") I '$T S VALMBCK="",VALMSG="Medication Instruction Sheets Not Installed!" Q
     100 I $G(PSODFN) N PSNDFN S PSNDFN=PSODFN
     101 W !! K PSNPPI("MESSAGE") D FULL^VALM1,^PSNPPIP S VALMBCK="R"
     102 I $G(PSNPPI("MESSAGE"))]"" D
     103 .K DIR W PSNPPI("MESSAGE"),! S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DIRUT,PSNPPI("MESSGAE")
     104 Q
     105PRMID ;prints medication instruction sheets.  pass in drug.
     106 I $T(ENOP^PSNPPIP)']"" S VALMBCK="",VALMSG="Medication Instruction Sheets Not Installed!" Q
     107 K PSNPPI("MESSAGE") D FULL^VALM1
     108 W !! D ENOP^PSNPPIP($P(RX0,"^",6),$G(^PSRX(RXN,"TN")),$P(RX0,"^"),PSODFN)
     109 S VALMBCK="R" I $G(PSNPPI("MESSAGE"))]"" D
     110 .K DIR W PSNPPI("MESSAGE"),! S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DIRUT,PSNPPI("MESSGAE")
     111 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHELP3.m

    r613 r623  
    1 PSOHELP3        ;BHAM ISC/SAB - outpatient utility routine #4 ;2/17/93 18:00:36
    2         ;;7.0;OUTPATIENT PHARMACY;**20,291**;DEC 1997;Build 2
    3 XREF    ;code to create 'APD' xref on Drug Interaction file (#56)
    4         ;I '$D(ZTSK),'$D(PSMSG) D WAIT^DICD W "Building 'APD' X-Ref."
    5         ;The following code accessing files 56 and 50.416 is no longer executed
    6         S ID1=$P(^PS(56,DA,0),"^",2),ID2=$P(^(0),"^",3),TOT=0
    7         F I1=0:0 S I1=$O(^PS(50.416,ID1,1,I1)) Q:'I1  S R2=$P(^(I1,0),"^") F I2=0:0 S I2=$O(^PS(50.416,ID2,1,I2)) Q:'I2  S D2=$P(^(I2,0),"^") W:+$G(PSMSG) "." D SEC
    8         F I1=0:0 S I1=$O(^PS(50.416,"APS",ID1,I1)) Q:'I1  F I3=0:0 S I3=$O(^PS(50.416,I1,1,I3)) Q:'I3  S R2=$P(^(I3,0),"^") F I5=0:0 S I5=$O(^PS(50.416,"APS",ID2,I5)) Q:'I5  F I6=0:0 S I6=$O(^PS(50.416,I5,1,I6)) Q:'I6  S D2=$P(^(I6,0),"^") D SEC
    9         F I1=0:0 S I1=$O(^PS(50.416,ID1,1,I1)) Q:'I1  S R2=$P(^(I1,0),"^") F I5=0:0 S I5=$O(^PS(50.416,"APS",ID2,I5)) Q:'I5  F I6=0:0 S I6=$O(^PS(50.416,I5,1,I6)) Q:'I6  S D2=$P(^(I6,0),"^") D SEC
    10         F I2=0:0 S I2=$O(^PS(50.416,ID2,1,I2)) Q:'I2  S D2=$P(^(I2,0),"^") F I1=0:0 S I1=$O(^PS(50.416,"APS",ID1,I1)) Q:'I1  F I3=0:0 S I3=$O(^PS(50.416,I1,1,I3)) Q:'I3  S R2=$P(^(I3,0),"^") D SEC
    11         S $P(^PS(56,DA,0),"^",6)=TOT
    12 EX      K TOT,I5,I6,D2,I4,I3,PRI,I1,I2,R2,PS1,PS2,ID2,ID1
    13         Q
    14 SEC     I +$G(DEL) K ^PS(56,"APD",R2,D2,DA),^PS(56,"APD",D2,R2,DA) Q
    15         S ^PS(56,"APD",R2,D2,DA)="",^PS(56,"APD",D2,R2,DA)="",TOT=TOT+2
    16         Q
    17 DRUG    ;selects drug and updates Rx file with cost (pso*7*20)
    18         W !!,"This option will update the drug cost on all fills in the PRESCRIPTION"
    19         W !,"file (#52) based on the selected date range and the current cost in the"
    20         W !,"DRUG file (#50).",!
    21         K X,Y,DA,DIC S DIC(0)="AQEM",DIC=50 D ^DIC I $G(DUOUT) K DIC,Y,X,DA Q
    22         I Y<0 G OUT
    23         S (DRG,DA)=+Y K DIC,DR,DIQ S DIC=50,DR=16,DIQ="PSODRG",DIQ(0)="I"
    24         D EN^DIQ1 S COST=PSODRG(50,DA,16,"I") K PSODRG,DIC,DA,DR,DIQ,DIR
    25         W ! S DIR("A")="Do you want to exclude Refills and Partials",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR I $G(DIRUT) K COST,X,DRG,Y Q
    26         S REF=$S(Y:0,1:1)
    27         S X1=DT,X2=-485 D C^%DTC S (DEF,Y)=X X ^DD("DD")
    28         W !!,"You can only go back One Year plus 120 days."
    29         S %DT(0)=DEF,%DT="AQEX",%DT("A")="Enter starting fill date: ",%DT("B")=Y D ^%DT K %DT("B"),DEF I Y<0!($D(DTOUT)) K REF,COST,DRG,X,Y Q
    30         S (FBCK,%DT(0))=Y,%DT("A")="Enter ending fill date: " D ^%DT
    31         K %DT I Y<0!($D(DTOUT)) K FBCK,REF,COST,DRG,X,Y Q
    32         S FAHD=Y
    33         S PSOFUTR=0 I FAHD>(DT-1) S PSOFUTR=1 D
    34         .W !!,"Since you selected an end fill date of today or in the future, this option"
    35         .W !,"will update the cost for all existing and suspended fills that have a"
    36         .W !,"fill date in the future.",!
    37         K DIR,X,Y S DIR(0)="Y",DIR("A")="Do you want to Queue to run at a specific Time",DIR("B")="Yes" D ^DIR K DIR I $D(DIRUT) G OUT
    38         I Y S PSOQ=1 K ZTDTH D  G OUT
    39         .S ZTRTN="EN^PSOHELP3",ZTIO="",ZTDESC="Outpatient Pharmacy Rx Cost Update"
    40         .F G="REF","COST","DRG","FBCK","FAHD","PSOQ","PSOFUTR" S:$D(@G) ZTSAVE(G)=""
    41         .D ^%ZTLOAD I $D(ZTSK) W !!,"Rxs Cost Update Queued",! K ZTSK
    42 EN      W:'$G(PSOQ) !,"Updating cost. Please wait... "
    43         S FDT=FBCK-1 F  S FDT=$O(^PSRX("ADL",FDT)) Q:'FDT  D  Q:FDT>FAHD
    44         .I '$G(PSOFUTR) I FDT>FAHD Q
    45         .S RXN=0 F  S RXN=$O(^PSRX("ADL",FDT,DRG,RXN)) Q:'RXN  D  W:'$G(PSOQ) "."
    46         ..I $P($G(^PSRX(RXN,0)),"^",6)=DRG,$P($G(^(2)),"^",2)=FDT S $P(^PSRX(RXN,0),"^",17)=COST
    47         I 'REF G OUT
    48         D REFILL,PARTIAL
    49 OUT     K G,COST,I,X,Y,REF,RXN,FDT,FAHD,FBCK,DRG,PSOQ,DIRUT,PSOFUTR I $D(ZTQUEUED) S ZTREQ="@"
    50         Q
    51 POST    ;post install entry point.  builds new "ADL" xref for file 52 pso*7*20
    52         S ZTRTN="EN1^PSOHELP3",ZTIO="",ZTDESC="Outpatient Pharmacy Rx XREF Update"
    53         S ZTDTH=$H D ^%ZTLOAD I $D(ZTSK) D BMES^XPDUTL(" Post Install Background Job Queued.") K ZTSK
    54         Q
    55 EN1     K ^PSRX("ADL") S X1=DT,X2=-485 D C^%DTC S DEF=X-1 W !,"DEF: "_DEF
    56         F  S DEF=$O(^PSRX("AD",DEF)) Q:'DEF  F IFN=0:0 S IFN=$O(^PSRX("AD",DEF,IFN)) Q:'IFN  S FTY="" F  S FTY=$O(^PSRX("AD",DEF,IFN,FTY)) Q:FTY=""  I FTY=0 D
    57         .I $P($G(^PSRX(IFN,2)),"^",2),$P($G(^(0)),"^",6) S ^PSRX("ADL",$P($G(^PSRX(IFN,2)),"^",2),$P($G(^(0)),"^",6),IFN)=""
    58         K X,Y,DEF,FTY,IFN S ZTREQ="@"
    59         Q
    60 REFILL  ;
    61         N FILL,FDT,RXN
    62         S FDT=FBCK-1 F  S FDT=$O(^PSRX("AD",FDT)) Q:'FDT  D  Q:FDT>FAHD
    63         .I '$G(PSOFUTR),FDT>FAHD Q
    64         .S RXN="" F  S RXN=$O(^PSRX("AD",FDT,RXN)) Q:'RXN  D
    65         ..I $P($G(^PSRX(RXN,0)),"^",6)'=DRG Q
    66         ..S FILL=0 F  S FILL=$O(^PSRX("AD",FDT,RXN,FILL)) Q:'FILL  I $D(^PSRX(RXN,1,FILL,0)) S $P(^(0),"^",11)=COST
    67         Q
    68 PARTIAL ;
    69          N FILL,FDT,RXN
    70          S FDT=FBCK-1 F  S FDT=$O(^PSRX("ADP",FDT)) Q:'FDT  D  Q:FDT>FAHD
    71         .I '$G(PSOFUTR),FDT>FAHD Q
    72         .S RXN="" F  S RXN=$O(^PSRX("ADP",FDT,RXN)) Q:'RXN  D
    73         ..I $P($G(^PSRX(RXN,0)),"^",6)'=DRG Q
    74         ..S FILL=0 F  S FILL=$O(^PSRX("ADP",FDT,RXN,FILL)) Q:'FILL  I $D(^PSRX(RXN,"P",FILL,0)) S $P(^(0),"^",11)=COST
    75         Q
     1PSOHELP3 ;BHAM ISC/SAB - outpatient utility routine #4 ;2/17/93 18:00:36
     2 ;;7.0;OUTPATIENT PHARMACY;**20**;DEC 1997
     3XREF ;code to create 'APD' xref on Drug Interaction file (#56)
     4 ;I '$D(ZTSK),'$D(PSMSG) D WAIT^DICD W "Building 'APD' X-Ref."
     5 ;The following code accessing files 56 and 50.416 is no longer executed
     6 S ID1=$P(^PS(56,DA,0),"^",2),ID2=$P(^(0),"^",3),TOT=0
     7 F I1=0:0 S I1=$O(^PS(50.416,ID1,1,I1)) Q:'I1  S R2=$P(^(I1,0),"^") F I2=0:0 S I2=$O(^PS(50.416,ID2,1,I2)) Q:'I2  S D2=$P(^(I2,0),"^") W:+$G(PSMSG) "." D SEC
     8 F I1=0:0 S I1=$O(^PS(50.416,"APS",ID1,I1)) Q:'I1  F I3=0:0 S I3=$O(^PS(50.416,I1,1,I3)) Q:'I3  S R2=$P(^(I3,0),"^") F I5=0:0 S I5=$O(^PS(50.416,"APS",ID2,I5)) Q:'I5  F I6=0:0 S I6=$O(^PS(50.416,I5,1,I6)) Q:'I6  S D2=$P(^(I6,0),"^") D SEC
     9 F I1=0:0 S I1=$O(^PS(50.416,ID1,1,I1)) Q:'I1  S R2=$P(^(I1,0),"^") F I5=0:0 S I5=$O(^PS(50.416,"APS",ID2,I5)) Q:'I5  F I6=0:0 S I6=$O(^PS(50.416,I5,1,I6)) Q:'I6  S D2=$P(^(I6,0),"^") D SEC
     10 F I2=0:0 S I2=$O(^PS(50.416,ID2,1,I2)) Q:'I2  S D2=$P(^(I2,0),"^") F I1=0:0 S I1=$O(^PS(50.416,"APS",ID1,I1)) Q:'I1  F I3=0:0 S I3=$O(^PS(50.416,I1,1,I3)) Q:'I3  S R2=$P(^(I3,0),"^") D SEC
     11 S $P(^PS(56,DA,0),"^",6)=TOT
     12EX K TOT,I5,I6,D2,I4,I3,PRI,I1,I2,R2,PS1,PS2,ID2,ID1
     13 Q
     14SEC I +$G(DEL) K ^PS(56,"APD",R2,D2,DA),^PS(56,"APD",D2,R2,DA) Q
     15 S ^PS(56,"APD",R2,D2,DA)="",^PS(56,"APD",D2,R2,DA)="",TOT=TOT+2
     16 Q
     17DRUG ;selects drug and updates Rx file with cost (pso*7*20)
     18 K X,Y,DA,DIC S DIC(0)="AQEM",DIC=50 D ^DIC I $G(DUOUT) K DIC,Y,X,DA Q
     19 I Y<0 G OUT
     20 S (DRG,DA)=+Y K DIC,DR,DIQ S DIC=50,DR=16,DIQ="PSODRG",DIQ(0)="I"
     21 D EN^DIQ1 S COST=PSODRG(50,DA,16,"I") K PSODRG,DIC,DA,DR,DIQ,DIR
     22 W ! S DIR("A")="Do you want to update cost on Refills and Partials too",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR I $G(DIRUT) K COST,X,DRG,Y Q
     23 S REF=$S(Y:Y,1:0),X1=DT,X2=-485 D C^%DTC S (DEF,Y)=X X ^DD("DD")
     24 W !!,"You can only go back One Year plus 120 days."
     25 S %DT(0)=DEF,%DT="AQEX",%DT("A")="How far BACK do you want to go: ",%DT("B")=Y D ^%DT K %DT("B"),DEF I Y<0!($D(DTOUT)) K REF,COST,DRG,X,Y Q
     26 S (FBCK,%DT(0))=Y,%DT("A")="How far AHEAD do you want to go: " D ^%DT
     27 K %DT I Y<0!($D(DTOUT)) K FBCK,REF,COST,DRG,X,Y Q
     28 S FAHD=Y K DIR,X,Y S DIR(0)="Y",DIR("A")="Do you want to Queue to run at a specific Time",DIR("B")="Yes" D ^DIR K DIR I $D(DIRUT) G OUT
     29 I Y S PSOQ=1 K ZTDTH D  G OUT
     30 .S ZTRTN="EN^PSOHELP3",ZTIO="",ZTDESC="Outpatient Pharmacy Rx Cost Update"
     31 .F G="REF","COST","DRG","FBCK","FAHD","PSOQ" S:$D(@G) ZTSAVE(G)=""
     32 .D ^%ZTLOAD I $D(ZTSK) W !,"Rxs Cost Update Queued" K ZTSK
     33EN W:'$G(PSOQ) ! S FDT=FBCK-1 F  S FDT=$O(^PSRX("ADL",FDT)) Q:'FDT!(FDT>FAHD)  F RXN=0:0 S RXN=$O(^PSRX("ADL",FDT,DRG,RXN)) Q:'RXN  D  W:'$G(PSOQ) "."
     34 .I $P($G(^PSRX(RXN,0)),"^",6)=DRG,$P($G(^(2)),"^",2)=FDT S $P(^PSRX(RXN,0),"^",17)=COST
     35 .Q:'REF
     36 .F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I  S $P(^PSRX(RXN,1,I,0),"^",11)=COST
     37 .F I=0:0 S I=$O(^PSRX(RXN,"P",I)) Q:'I  S $P(^PSRX(RXN,"P",I,0),"^",11)=COST
     38OUT K G,COST,I,X,Y,REF,RXN,FDT,FAHD,FBCK,DRG,PSOQ,DIRUT I $D(ZTQUEUED) S ZTREQ="@"
     39 Q
     40POST ;post install entry point.  builds new "ADL" xref for file 52 pso*7*20
     41 S ZTRTN="EN1^PSOHELP3",ZTIO="",ZTDESC="Outpatient Pharmacy Rx XREF Update"
     42 S ZTDTH=$H D ^%ZTLOAD I $D(ZTSK) D BMES^XPDUTL(" Post Install Background Job Queued.") K ZTSK
     43 Q
     44EN1 K ^PSRX("ADL") S X1=DT,X2=-485 D C^%DTC S DEF=X-1 W !,"DEF: "_DEF
     45 F  S DEF=$O(^PSRX("AD",DEF)) Q:'DEF  F IFN=0:0 S IFN=$O(^PSRX("AD",DEF,IFN)) Q:'IFN  S FTY="" F  S FTY=$O(^PSRX("AD",DEF,IFN,FTY)) Q:FTY=""  I FTY=0 D
     46 .I $P($G(^PSRX(IFN,2)),"^",2),$P($G(^(0)),"^",6) S ^PSRX("ADL",$P($G(^PSRX(IFN,2)),"^",2),$P($G(^(0)),"^",6),IFN)=""
     47 K X,Y,DEF,FTY,IFN S ZTREQ="@"
     48 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLD.m

    r613 r623  
    1 PSOHLD  ;BIR/SAB - hold unhold functionality ;07/15/96
    2         ;;7.0;OUTPATIENT PHARMACY;**1,16,21,24,27,32,55,82,114,130,166,148,268,281**;DEC 1997;Build 41
    3         ;External reference to ^DD(52-DBIA 999,  VA(200-DBIA 224, NA^ORX1-DBIA 2186,
    4         ; L, UL, PSOL, and PSOUL^PSSLOCK-DBIA 2789, ^%DTC-DBIA 10000, ^DIE-DBIA 10018, ^DIR-DBIA 10026,
    5         ; ^DIK-DBIA 10013, ^VALM1-DBIA 10016, ^XUSEC(-DBIA 10076
    6 UHLD    I '$D(PSOPAR) D ^PSOLSET G:'$D(PSOPAR) EX
    7         I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q
    8         I $G(PSONACT) W $C(7),$C(7) S VALMSG="No Pharmacy Orderable Item !",VALMBCK="" Q
    9         S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
    10         ;W !! S DIC("A")="Unhold Prescription #: ",(DIE,DIC)="^PSRX(",DIC(0)="AEMQZ",DIC("S")="I $G(^PSRX(+Y,""H""))]"""",$P(^(""STA""),""^"")'=16" D ^DIC G:"^"[$E(X) EX G:Y<0 UHLD S (DA,PPL)=+Y,DFN=$P(Y(0),"^",2)
    11         K PSOPLCK D PSOL^PSSLOCK(DA) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D ULP Q
    12         S Y(0)=^PSRX(DA,0),STA=+$G(^("STA"))
    13         I STA=16 S VALMSG="Placed on HOLD by Provider!" K Y,STA D PSOUL^PSSLOCK(DA) D ULP S VALMBCK="" Q
    14         I STA'=3!('$D(^XUSEC("PSORPH",DUZ))) S VALMSG="Invalid Action Selection!",VALMBCK="" K Y,STA D PSOUL^PSSLOCK(DA) D ULP Q
    15         D FULL^VALM1 K DIR,DTOUT,DUOUT,DIRUT D NOOR I $D(DIRUT) D ULP G EX
    16         I DT>$P(^PSRX(DA,2),"^",6) D  D ULP G EX
    17         .S VALMSG="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11
    18         .S ^PSRX(DA,"H")="",COMM="Medication Expired on "_$E($P(^(2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM,"") K COMM
    19 EN      S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S RXF=I,RSDT=$P(^(0),"^")
    20         I RXF D  I $D(Y) D ULP G EX
    21         .S (PSDA,DA(1))=DA,DA=RXF,DIE="^PSRX("_DA(1)_",1,"
    22         .S RLDT=$P(^PSRX(DA(1),1,DA,0),"^",18)
    23         .S DR=$S('RLDT:".01R;2;",1:"")_"3COMMENTS"
    24         .S PSOUNHLD=1 D ^DIE K PSOUNHLD
    25         .S ZD(PSDA)=$P(^PSRX(DA(1),1,DA,0),"^")
    26         .Q:$D(Y)  S PSORX("FILL DATE")=$P(^PSRX(DA(1),1,DA,0),"^"),DA=PSDA K DA(1)
    27         ;
    28         S ACT=1,DIE="^PSRX(",FDT=$S($P(^PSRX(DA,2),"^",2):$P(^PSRX(DA,2),"^",2),1:DT)
    29         S RLDT=$P(^PSRX(DA,2),"^",13),DR="",RLDTP1=$P(RLDT,".",1)
    30         I 'RXF&'RLDT S DR="22//^S X=FDT;11;Q;"
    31         I RLDT&($P(^PSRX(DA,2),"^",2)="") S DR="22//^S X=RLDTP1;11;Q;"
    32         S DR=DR_"100///0;101///^S X=$S(RXF:$G(ZD(PSDA)),1:$P(^PSRX(PSDA,2),""^"",2))"
    33         ;
    34         D ^DIE K FDT I $D(Y) S VALMBCK="R" D ULP G EX
    35         S COMM="Medication Removed from Hold by Pharmacy" D EN^PSOHLSN1(DA,"OE","",COMM,PSONOOR) K COMM,PSONOOR
    36         S PSORX("FILL DATE")=$S('RXF:$P(^PSRX(DA,2),"^",2),1:ZD(PSDA)) K ^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA) S ^PSRX(DA,"H")="" D ACT^PSOHLDA S (NEW1,NEW11)="^^"
    37         S (RXF,RXFL(DA))=0 F JJ=0:0 S JJ=$O(^PSRX(DA,1,JJ)) Q:'JJ  S (RXFL(DA),RXF)=JJ
    38         I $G(PSXSYS) D UNHOLD^PSOCMOPA I $G(XFLAG) D ULP G EX
    39         I $G(DA) D RELC I $G(PSOHRL) D ULP G EX
    40         I PSORX("FILL DATE")>DT,$P(PSOPAR,"^",6) D S^PSORXL,EX,ULP Q
    41         S PCOMH(DA)="Medication Removed from Hold by Pharmacy"
    42         I $G(DA) S RXRH(DA)=DA
    43         I $P($G(^PSRX(DA,2)),"^",15)'="" S $P(^PSRX(DA,2),"^",14)=1,RXRP(DA)=1,$P(RXRP(DA),"^",2)=$P($G(^PSRX(DA,0)),"^",18) ; MARK PRESCRIPTION AND LABEL AS BEING REPRINTED WHEN UNHOLDING A RETURNED TO SOTCK PRESCRIPTION
    44         ;
    45         ; - Submitting Rx to ECME
    46         N ACTION
    47         I $$SUBMIT^PSOBPSUT(DA,+$G(RXFL(DA))) D  I ACTION="Q"!(ACTION="^") D ULP G EX
    48         . N RX,RFL S RX=DA,RFL=+$G(RXFL(DA))
    49         . N DA S ACTION=""
    50         . D ECMESND^PSOBPSU1(RX,RFL,,$S(RFL:"RF",1:"OF"))
    51         . I $$FIND^PSOREJUT(RX,RFL) D
    52         . . S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","Q")
    53         ;
    54         I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=DA_"," D ULP G EX
    55         F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
    56         I $L(PSORX("PSOL",PSOX2))+$L(DA)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_DA_","
    57         E  S PSORX("PSOL",PSOX2+1)=DA_","
    58         ;
    59         D ULP
    60 EX      D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) D ^PSOBUILD
    61         K PSOHRL,PSOMSG,PSOPLCK,ST,PSL,PSNP,IR,NOW,DR,NEW1,NEW11,RTN,DA,PPL,RXN,RX0,RXS,DIK,RXP,FLD,ACT,DIE,DIC,DIR,DIE,X,Y,DIRUT,DUOUT,SUSPT,C,D0,LFD,I,PSDA,RFDATE,DI,DQ,%,RFN,XFLAG
    62         K HRX,PSHLD,PSOLIST,PSORX("FILL DATE"),STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ Q
    63         ;
    64 HLD     ;
    65         I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q
    66         I $G(PSONACT) W $C(7),$C(7) S VALMSG="No Pharmacy Orderable Item !",VALMBCK="" Q
    67         I '$D(^XUSEC("PSORPH",DUZ)) S VALMSG="Invalid Action Selection!",VALMBCK="" Q
    68         S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient."),VALMBCK="" K PSOPLCK Q
    69         K PSOPLCK D PSOL^PSSLOCK(DA) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D ULP Q
    70         S Y(0)=^PSRX(DA,0),STA=+$G(^("STA")) I DT>$P(^PSRX(DA,2),"^",6) D  D ULP G D1
    71         .S VALMSG="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3),VALMBCK="R"
    72         .I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 D
    73         ..S COMM="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM) K COMM
    74         S ST=$P("ERROR^ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^DONE^EXPIRED^DISCONTINUED^DELETED^DISCONTINUED^DISCONTINUED (EDIT)^PROVIDER HOLD^","^",STA+2)
    75         I STA,STA'>4!(STA>11) D  D ULP G D1
    76         .S VALMSG="Rx: "_$P(Y(0),"^")_" is currently in a status of "_ST,VALMBCK="R" K ST,Y Q
    77         D FULL^VALM1 D NOOR I $D(DIRUT) D ULP G D1
    78         D HLD^PSOCMOPA I $G(XFLAG) K XFLAG D ULP G D1
    79         K DIR S DIR("A")=$P(^DD(52,99,0),"^"),DIR(0)="52,99" D ^DIR S FLD(99)=Y I $D(DUOUT)!($D(DIRUT)) K DIRUT,DUOUT,DIR D ULP G D1
    80         I $G(FLD(99))=99 K DIR S DIR("A")=$P(^DD(52,99.1,0),"^"),DIR(0)="52,99.1" D ^DIR S FLD(99.1)=Y G AR
    81         E  K DIR S DIR(0)="FO^10:100",DIR("A")="HOLD COMMENTS" D ^DIR S FLD(99.1)=Y
    82 AR      I $D(DUOUT)!($D(DTOUT)) K DIRUT,DUOUT,DIR S VALMBCK="R" D ULP G D1
    83         F PI=1:1 Q:$P(PPL,",",PI)=""  S DA=$P(PPL,",",PI) D H S DA=PSDA K PSDA D:$D(PSORX("PSOL")) RMP^PSOHLDA
    84         K PI D ^PSOBUILD
    85         D ULP
    86 D1      D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) K PSOMSG,PSOPLCK,RFN,DIR,RSDT,FLD,DA,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT
    87         Q
    88         ;
    89 H       ; - Rx HOLD update
    90         D HOLD^PSOHLDA
    91         Q
    92         ;
    93 FLD     N DA K DIR S DIR("A")=$P(^DD(52,99,0),"^"),DIR(0)="52,99" D ^DIR Q:$D(DUOUT)!($D(DIRUT))  S FLD(99)=Y
    94         S COMM=Y(0)
    95         I $G(FLD(99))=99 K DIR S DIR("A")=$P(^DD(52,99.1,0),"^"),DIR(0)="52,99.1" D ^DIR Q:$D(DUOUT)!($D(DIRUT))  S (FLD(99.1),COMM)=Y Q
    96         E  S FLD(99.1)=""
    97         Q
    98 NOOR    ;ask nature of order
    99         K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]""  D  Q
    100         .S PSONOOR=$$NA^ORX1("W",0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:""))
    101         .I +PSONOOR S PSONOOR=$P(PSONOOR,"^",3) Q
    102         .S DIRUT=1 K PSONOOR
    103         S DIR("A")="Nature of Order: ",DIR("B")="WRITTEN"
    104         S DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$S(+$G(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"")
    105 NOORX   D ^DIR K DIR,DTOUT,DTOUT Q:$D(DIRUT)  S PSONOOR=Y
    106         Q
    107 ULP     ;
    108         D UL^PSSLOCK(+$G(PSODFN))
    109         Q
    110 RELC    ;
    111         S (PSOHRL,PSOHTX)=0  F PSOHT=0:0 S PSOHT=$O(^PSRX(DA,1,PSOHT)) Q:'PSOHT  S:$D(^PSRX(DA,1,PSOHT,0)) PSOHTX=PSOHT
    112         I $G(PSOHTX) S PSOHRL=$S($P($G(^PSRX(DA,1,PSOHTX,0)),"^",18):1,1:0)
    113         I '$G(PSOHTX) S PSOHRL=$S($P($G(^PSRX(DA,2)),"^",13):1,1:0)
    114         K PSOHTX,PSOHT
    115         Q
     1PSOHLD ;BIR/SAB - hold unhold functionality ;07/15/96
     2 ;;7.0;OUTPATIENT PHARMACY;**1,16,21,24,27,32,55,82,114,130,166,148,268**;DEC 1997;Build 9
     3 ;External reference to ^DD(52-DBIA 999,  VA(200-DBIA 224, NA^ORX1-DBIA 2186,
     4 ; L, UL, PSOL, and PSOUL^PSSLOCK-DBIA 2789, ^%DTC-DBIA 10000, ^DIE-DBIA 10018, ^DIR-DBIA 10026,
     5 ; ^DIK-DBIA 10013, ^VALM1-DBIA 10016, ^XUSEC(-DBIA 10076
     6UHLD I '$D(PSOPAR) D ^PSOLSET G:'$D(PSOPAR) EX
     7 I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q
     8 I $G(PSONACT) W $C(7),$C(7) S VALMSG="No Pharmacy Orderable Item !",VALMBCK="" Q
     9 S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
     10 ;W !! S DIC("A")="Unhold Prescription #: ",(DIE,DIC)="^PSRX(",DIC(0)="AEMQZ",DIC("S")="I $G(^PSRX(+Y,""H""))]"""",$P(^(""STA""),""^"")'=16" D ^DIC G:"^"[$E(X) EX G:Y<0 UHLD S (DA,PPL)=+Y,DFN=$P(Y(0),"^",2)
     11 K PSOPLCK D PSOL^PSSLOCK(DA) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D ULP Q
     12 S Y(0)=^PSRX(DA,0),STA=+$G(^("STA"))
     13 I STA=16 S VALMSG="Placed on HOLD by Provider!" K Y,STA D PSOUL^PSSLOCK(DA) D ULP S VALMBCK="" Q
     14 I STA'=3!('$D(^XUSEC("PSORPH",DUZ))) S VALMSG="Invalid Action Selection!",VALMBCK="" K Y,STA D PSOUL^PSSLOCK(DA) D ULP Q
     15 D FULL^VALM1 K DIR,DTOUT,DUOUT,DIRUT D NOOR I $D(DIRUT) D ULP G EX
     16 I DT>$P(^PSRX(DA,2),"^",6) D  D ULP G EX
     17 .S VALMSG="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11
     18 .S ^PSRX(DA,"H")="",COMM="Medication Expired on "_$E($P(^(2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM,"") K COMM
     19EN S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S RXF=I,RSDT=$P(^(0),"^")
     20 I RXF D  I $D(Y) D ULP G EX
     21 .S (PSDA,DA(1))=DA,DA=RXF,DIE="^PSRX("_DA(1)_",1,"
     22 .S RLDT=$P(^PSRX(DA(1),1,DA,0),"^",18)
     23 .S DR=$S('RLDT:".01R;2;",1:"")_"3COMMENTS"
     24 .S PSOUNHLD=1 D ^DIE K PSOUNHLD
     25 .S ZD(PSDA)=$P(^PSRX(DA(1),1,DA,0),"^")
     26 .Q:$D(Y)  S PSORX("FILL DATE")=$P(^PSRX(DA(1),1,DA,0),"^"),DA=PSDA K DA(1)
     27 ;
     28 S ACT=1,DIE="^PSRX(",FDT=$S($P(^PSRX(DA,2),"^",2):$P(^PSRX(DA,2),"^",2),1:DT)
     29 S RLDT=$P(^PSRX(DA,2),"^",13),DR="",RLDTP1=$P(RLDT,".",1)
     30 I 'RXF&'RLDT S DR="22//^S X=FDT;11;Q;"
     31 I RLDT&($P(^PSRX(DA,2),"^",2)="") S DR="22//^S X=RLDTP1;11;Q;"
     32 S DR=DR_"100///0;101///^S X=$S(RXF:$G(ZD(PSDA)),1:$P(^PSRX(PSDA,2),""^"",2))"
     33 ;
     34 D ^DIE K FDT I $D(Y) S VALMBCK="R" D ULP G EX
     35 S COMM="Medication Removed from Hold by Pharmacy" D EN^PSOHLSN1(DA,"OE","",COMM,PSONOOR) K COMM,PSONOOR
     36 S PSORX("FILL DATE")=$S('RXF:$P(^PSRX(DA,2),"^",2),1:ZD(PSDA)) K ^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA) S ^PSRX(DA,"H")="" D ACT^PSOHLDA S (NEW1,NEW11)="^^"
     37 S (RXF,RXFL(DA))=0 F JJ=0:0 S JJ=$O(^PSRX(DA,1,JJ)) Q:'JJ  S (RXFL(DA),RXF)=JJ
     38 I $G(PSXSYS) D UNHOLD^PSOCMOPA I $G(XFLAG) D ULP G EX
     39 I $G(DA) D RELC I $G(PSOHRL) D ULP G EX
     40 I PSORX("FILL DATE")>DT,$P(PSOPAR,"^",6) D S^PSORXL,EX,ULP Q
     41 S PCOMH(DA)="Medication Removed from Hold by Pharmacy"
     42 I $G(DA) S RXRH(DA)=DA
     43 I $P($G(^PSRX(DA,2)),"^",15)'="" S $P(^PSRX(DA,2),"^",14)=1,RXRP(DA)=1,$P(RXRP(DA),"^",2)=$P($G(^PSRX(DA,0)),"^",18) ; MARK PRESCRIPTION AND LABEL AS BEING REPRINTED WHEN UNHOLDING A RETURNED TO SOTCK PRESCRIPTION
     44 ;
     45 ; - Submitting Rx to ECME
     46 N ACTION
     47 I $$SUBMIT^PSOBPSUT(DA,+$G(RXFL(DA))) D  I ACTION="Q"!(ACTION="^") D ULP G EX
     48 . N RX,RFL S RX=DA,RFL=+$G(RXFL(DA))
     49 . N DA S ACTION=""
     50 . D ECMESND^PSOBPSU1(RX,RFL,,$S(RFL:"RF",1:"OF"))
     51 . I $$FIND^PSOREJUT(RX,RFL) D
     52 . . S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","I")
     53 ;
     54 I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=DA_"," D ULP G EX
     55 F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
     56 I $L(PSORX("PSOL",PSOX2))+$L(DA)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_DA_","
     57 E  S PSORX("PSOL",PSOX2+1)=DA_","
     58 ;
     59 D ULP
     60EX D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) D ^PSOBUILD
     61 K PSOHRL,PSOMSG,PSOPLCK,ST,PSL,PSNP,IR,NOW,DR,NEW1,NEW11,RTN,DA,PPL,RXN,RX0,RXS,DIK,RXP,FLD,ACT,DIE,DIC,DIR,DIE,X,Y,DIRUT,DUOUT,SUSPT,C,D0,LFD,I,PSDA,RFDATE,DI,DQ,%,RFN,XFLAG
     62 K HRX,PSHLD,PSOLIST,PSORX("FILL DATE"),STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ Q
     63 ;
     64HLD ;
     65 I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q
     66 I $G(PSONACT) W $C(7),$C(7) S VALMSG="No Pharmacy Orderable Item !",VALMBCK="" Q
     67 I '$D(^XUSEC("PSORPH",DUZ)) S VALMSG="Invalid Action Selection!",VALMBCK="" Q
     68 S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient."),VALMBCK="" K PSOPLCK Q
     69 K PSOPLCK D PSOL^PSSLOCK(DA) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D ULP Q
     70 S Y(0)=^PSRX(DA,0),STA=+$G(^("STA")) I DT>$P(^PSRX(DA,2),"^",6) D  D ULP G D1
     71 .S VALMSG="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3),VALMBCK="R"
     72 .I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 D
     73 ..S COMM="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM) K COMM
     74 S ST=$P("ERROR^ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^DONE^EXPIRED^DISCONTINUED^DELETED^DISCONTINUED^DISCONTINUED (EDIT)^PROVIDER HOLD^","^",STA+2)
     75 I STA,STA'>4!(STA>11) D  D ULP G D1
     76 .S VALMSG="Rx: "_$P(Y(0),"^")_" is currently in a status of "_ST,VALMBCK="R" K ST,Y Q
     77 D FULL^VALM1 D NOOR I $D(DIRUT) D ULP G D1
     78 D HLD^PSOCMOPA I $G(XFLAG) K XFLAG D ULP G D1
     79 K DIR S DIR("A")=$P(^DD(52,99,0),"^"),DIR(0)="52,99" D ^DIR S FLD(99)=Y I $D(DUOUT)!($D(DIRUT)) K DIRUT,DUOUT,DIR D ULP G D1
     80 I $G(FLD(99))=99 K DIR S DIR("A")=$P(^DD(52,99.1,0),"^"),DIR(0)="52,99.1" D ^DIR S FLD(99.1)=Y G AR
     81 E  K DIR S DIR(0)="FO^10:100",DIR("A")="HOLD COMMENTS" D ^DIR S FLD(99.1)=Y
     82AR I $D(DUOUT)!($D(DTOUT)) K DIRUT,DUOUT,DIR S VALMBCK="R" D ULP G D1
     83 F PI=1:1 Q:$P(PPL,",",PI)=""  S DA=$P(PPL,",",PI) D H S DA=PSDA K PSDA D:$D(PSORX("PSOL")) RMP^PSOHLDA
     84 K PI D ^PSOBUILD
     85 D ULP
     86D1 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) K PSOMSG,PSOPLCK,RFN,DIR,RSDT,FLD,DA,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT
     87 Q
     88 ;
     89H ; - Rx HOLD update
     90 D HOLD^PSOHLDA
     91 Q
     92 ;
     93FLD N DA K DIR S DIR("A")=$P(^DD(52,99,0),"^"),DIR(0)="52,99" D ^DIR Q:$D(DUOUT)!($D(DIRUT))  S FLD(99)=Y
     94 S COMM=Y(0)
     95 I $G(FLD(99))=99 K DIR S DIR("A")=$P(^DD(52,99.1,0),"^"),DIR(0)="52,99.1" D ^DIR Q:$D(DUOUT)!($D(DIRUT))  S (FLD(99.1),COMM)=Y Q
     96 E  S FLD(99.1)=""
     97 Q
     98NOOR ;ask nature of order
     99 K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]""  D  Q
     100 .S PSONOOR=$$NA^ORX1("W",0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:""))
     101 .I +PSONOOR S PSONOOR=$P(PSONOOR,"^",3) Q
     102 .S DIRUT=1 K PSONOOR
     103 S DIR("A")="Nature of Order: ",DIR("B")="WRITTEN"
     104 S DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$S(+$G(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"")
     105NOORX D ^DIR K DIR,DTOUT,DTOUT Q:$D(DIRUT)  S PSONOOR=Y
     106 Q
     107ULP ;
     108 D UL^PSSLOCK(+$G(PSODFN))
     109 Q
     110RELC ;
     111 S (PSOHRL,PSOHTX)=0  F PSOHT=0:0 S PSOHT=$O(^PSRX(DA,1,PSOHT)) Q:'PSOHT  S:$D(^PSRX(DA,1,PSOHT,0)) PSOHTX=PSOHT
     112 I $G(PSOHTX) S PSOHRL=$S($P($G(^PSRX(DA,1,PSOHTX,0)),"^",18):1,1:0)
     113 I '$G(PSOHTX) S PSOHRL=$S($P($G(^PSRX(DA,2)),"^",13):1,1:0)
     114 K PSOHTX,PSOHT
     115 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLDA.m

    r613 r623  
    1 PSOHLDA ;BIR/MFR - HOLD/UNHOLD functionality (cont.) ;07/15/96
    2         ;;7.0;OUTPATIENT PHARMACY;**148,225**;DEC 1997;Build 29
    3         ;
    4 HOLD    ;hold function
    5         I $P($G(^PSRX(DA,"STA")),"^")=3 Q
    6         S RSDT=$S($P(^PSRX(DA,2),"^",13):$P(^PSRX(DA,3),"^"),1:"@"),(PSUS,ACT,RXF,RFN,I)=0 F  S I=$O(^PSRX(DA,1,I)) Q:'I  D
    7         .S RXF=I,RFN=RFN+1 S:RFN=1 RSDT=$S('$P(^PSRX(DA,1,I,0),"^",18):$P(^PSRX(DA,2),"^",2),1:$P(^PSRX(DA,1,I,0),"^"))
    8         .I RFN>1,'$P(^PSRX(DA,1,I,0),"^",18) S RSDT=$P(^PSRX(DA,1,RXF-1,0),"^") Q
    9         .S:RFN>1 RSDT=$P(^PSRX(DA,1,RXF,0),"^")
    10         I RXF D
    11         .S (PSDA,DA(1))=DA,DA=RXF,DIE="^PSRX("_DA(1)_",1,",DR="4" D ^DIE
    12         .S $P(^PSRX(DA(1),1,DA,0),"^",3)=$S($G(FLD(99.1))]"":$E(FLD(99.1),1,60),1:"")
    13         .S DA=PSDA K DA(1)
    14         S DIE="^PSRX(",DR=$S('RXF&('$P(^PSRX(DA,2),"^",13)):"22///@;",1:"")_"99///"_FLD(99)_";99.1///^S X=FLD(99.1);99.2///"_DT_";100///3;101///"_RSDT D ^DIE Q:$D(Y)
    15         S:$G(PSOHD) VALMSG="RX# "_$P(^PSRX(DA,0),"^")_" has been placed in a hold status."
    16         K RXRS(DA)
    17         I +$G(PSDA) S DA=$O(^PS(52.5,"B",PSDA,0)) I DA S:$P($G(^PS(52.5,DA,"P")),"^")=0 PSUS=1 S DIK="^PS(52.5," D ^DIK K DA,DIK
    18         S:+$G(PSDA) DA=PSDA D ACT
    19         S PSOHNX=+$P($G(^PSRX(+$G(DA),"H")),"^") D
    20         .I $G(PSOHNX),$P($G(^PSRX(DA,"H")),"^",2)'="" S COMM=$P($G(^("H")),"^",2) Q
    21         .S COMM="Medication placed on Hold "_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)
    22         D EN^PSOHLSN1(DA,"OH","",COMM,PSONOOR) K COMM,PSOHNX
    23         ;
    24         ; - Closes any OPEN/UNRESOLVED REJECTs and Reverses ECME Claim
    25         D REVERSE^PSOBPSU1(DA,+$G(RXF),"HLD",2)
    26         Q
    27         ;
    28 ACT     ;adds activity info for rx removed or placed on hold
    29         D NOW^%DTC S NOW=%
    30         S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA  S IR=FDA
    31         S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
    32         S ^PSRX(DA,"A",IR,0)=NOW_"^"_$S(ACT:"U",1:"H")_"^"_DUZ_"^"_$S(RXF>5:RXF+1,1:RXF)_"^"_"RX "_$S('ACT:"placed in a",1:"removed from")_" HOLD status "_$S(+$G(PSUS):"and removed from SUSPENSE ",1:"")_"("_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)_")"
    33         K PSUS,RXF,I,FDA,DIC,DIE,DR,Y,X,%,%I,%H,RSDT
    34         Q
    35         ;
    36 RMP     ;remove Rx if found in array PSORX("PSOL")
    37         Q:'$G(DA)
    38         N I,J,K,PSOX2,PSOX3,PSOX9 S I=0
    39         F  S I=$O(PSORX("PSOL",I)) Q:'I  S PSOX2=PSORX("PSOL",I) D:PSOX2[(DA_",")
    40         .S PSOX9="",K=0 F J=1:1 S PSOX3=$P(PSOX2,",",J) Q:'PSOX3  D
    41         ..I PSOX3=DA,$P($G(^PSRX(DA,"STA")),"^")=3 S K=1 Q
    42         ..S PSOX9=PSOX9_$S('PSOX9:"",1:",")_PSOX3
    43         .I K S:PSOX9]"" PSORX("PSOL",I)=PSOX9_"," K:PSOX9="" PSORX("PSOL",I) D:$D(BBRX(I)) RMB
    44         Q
    45 RMB     ;remove Rx if found in array BBRX()
    46         S PSOX2=BBRX(I) D:PSOX2[(DA_",")
    47         .S PSOX9="" F J=1:1 S PSOX3=$P(PSOX2,",",J) Q:'PSOX3  S:PSOX3'=DA PSOX9=PSOX9_$S('PSOX9:"",1:",")_PSOX3
    48         .S:PSOX9]"" BBRX(I)=PSOX9_"," K:PSOX9="" BBRX(I)
    49         Q
     1PSOHLDA ;BIR/MFR - HOLD/UNHOLD functionality (cont.) ;07/15/96
     2 ;;7.0;OUTPATIENT PHARMACY;**148**;DEC 1997
     3 ;
     4HOLD ;hold function
     5 I $P($G(^PSRX(DA,"STA")),"^")=3 Q
     6 S RSDT=$S($P(^PSRX(DA,2),"^",13):$P(^PSRX(DA,3),"^"),1:"@"),(PSUS,ACT,RXF,RFN,I)=0 F  S I=$O(^PSRX(DA,1,I)) Q:'I  D
     7 .S RXF=I,RFN=RFN+1 S:RFN=1 RSDT=$S('$P(^PSRX(DA,1,I,0),"^",18):$P(^PSRX(DA,2),"^",2),1:$P(^PSRX(DA,1,I,0),"^"))
     8 .I RFN>1,'$P(^PSRX(DA,1,I,0),"^",18) S RSDT=$P(^PSRX(DA,1,RXF-1,0),"^") Q
     9 .S:RFN>1 RSDT=$P(^PSRX(DA,1,RXF,0),"^")
     10 I RXF D
     11 .S (PSDA,DA(1))=DA,DA=RXF,DIE="^PSRX("_DA(1)_",1,",DR="4" D ^DIE
     12 .S $P(^PSRX(DA(1),1,DA,0),"^",3)=$S($G(FLD(99.1))]"":$E(FLD(99.1),1,60),1:"")
     13 .S DA=PSDA K DA(1)
     14 S DIE="^PSRX(",DR=$S('RXF&('$P(^PSRX(DA,2),"^",13)):"22///@;",1:"")_"99///"_FLD(99)_";99.1///^S X=FLD(99.1);99.2///"_DT_";100///3;101///"_RSDT D ^DIE Q:$D(Y)
     15 S:$G(PSOHD) VALMSG="RX# "_$P(^PSRX(DA,0),"^")_" has been placed in a hold status."
     16 K RXRS(DA)
     17 I +$G(PSDA) S DA=$O(^PS(52.5,"B",PSDA,0)) I DA S:$P($G(^PS(52.5,DA,"P")),"^")=0 PSUS=1 S DIK="^PS(52.5," D ^DIK K DA,DIK
     18 S:+$G(PSDA) DA=PSDA D ACT
     19 S PSOHNX=+$P($G(^PSRX(+$G(DA),"H")),"^") D
     20 .I $G(PSOHNX),$G(PSOHNX)'=99 S COMM=$P($P($P(^DD(52,99,0),"^",3),";",PSOHNX),":",2) Q
     21 .I $G(PSOHNX)=99,$P($G(^PSRX(DA,"H")),"^",2)'="" S COMM=$P($G(^("H")),"^",2) Q
     22 .S COMM="Medication placed on Hold "_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)
     23 D EN^PSOHLSN1(DA,"OH","",COMM,PSONOOR) K COMM,PSOHNX
     24 ;
     25 ; - Closes any OPEN/UNRESOLVED REJECTs and Reverses ECME Claim
     26 D REVERSE^PSOBPSU1(DA,+$G(RXF),"HLD",2)
     27 Q
     28 ;
     29ACT ;adds activity info for rx removed or placed on hold
     30 D NOW^%DTC S NOW=%
     31 S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA  S IR=FDA
     32 S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
     33 S ^PSRX(DA,"A",IR,0)=NOW_"^"_$S(ACT:"U",1:"H")_"^"_DUZ_"^"_$S(RXF>5:RXF+1,1:RXF)_"^"_"RX "_$S('ACT:"placed in a",1:"removed from")_" HOLD status "_$S(+$G(PSUS):"and removed from SUSPENSE ",1:"")_"("_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)_")"
     34 K PSUS,RXF,I,FDA,DIC,DIE,DR,Y,X,%,%I,%H,RSDT
     35 Q
     36 ;
     37RMP ;remove Rx if found in array PSORX("PSOL")
     38 Q:'$G(DA)
     39 N I,J,K,PSOX2,PSOX3,PSOX9 S I=0
     40 F  S I=$O(PSORX("PSOL",I)) Q:'I  S PSOX2=PSORX("PSOL",I) D:PSOX2[(DA_",")
     41 .S PSOX9="",K=0 F J=1:1 S PSOX3=$P(PSOX2,",",J) Q:'PSOX3  D
     42 ..I PSOX3=DA,$P($G(^PSRX(DA,"STA")),"^")=3 S K=1 Q
     43 ..S PSOX9=PSOX9_$S('PSOX9:"",1:",")_PSOX3
     44 .I K S:PSOX9]"" PSORX("PSOL",I)=PSOX9_"," K:PSOX9="" PSORX("PSOL",I) D:$D(BBRX(I)) RMB
     45 Q
     46RMB ;remove Rx if found in array BBRX()
     47 S PSOX2=BBRX(I) D:PSOX2[(DA_",")
     48 .S PSOX9="" F J=1:1 S PSOX3=$P(PSOX2,",",J) Q:'PSOX3  S:PSOX3'=DA PSOX9=PSOX9_$S('PSOX9:"",1:",")_PSOX3
     49 .S:PSOX9]"" BBRX(I)=PSOX9_"," K:PSOX9="" BBRX(I)
     50 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLDS4.m

    r613 r623  
    1 PSOHLDS4        ;BIR/PWC-Build HL7 Segments for Automated Interface ; 2/13/08 3:21pm
    2         ;;7.0;OUTPATIENT PHARMACY;**156,255,279**;DEC 1997;Build 9
    3         ;HLFNC       supp. by DBIA 10106
    4         ;DIC(5       supp. by DBIA 10056
    5         ;EN^PSNPPIO  supp. by DBIA 3794
    6         ;This routine is called from PSOHLDS1
    7         ;
    8         ;*255 moved tag NTEPMI from PSOHLDS2
    9         Q
    10 IAM(PSI)        ;allergy list segment
    11         Q:'$D(DFN)!$D(PAS3)
    12         N IAM,IDX,SEV,SEV1,DAT,X,TYP,TYP1,VER,VER1
    13         S IAM="",CNT=0,GMRA="0^0^111" D EN1^GMRADPT
    14         I $G(GMRAL)="" G ZALQT
    15         F AIEN=0:0 S AIEN=$O(GMRAL(AIEN)) Q:'AIEN  D
    16         .K ADTL D EN1^GMRAOR2(AIEN,"ADTL") S CNT=CNT+1
    17         .S TYP1=$P(GMRAL(AIEN),"^",7)
    18         .S TYP=$S(TYP1="D":"DRUG",TYP1="F":"FOOD",TYP1="O":"OTHER",TYP1="DF":"DRUG/FOOD",TYP1="DO":"DRUG/OTHER",TYP1="DFO":"DRUG/FOOD/OTHER",1:"""""")
    19         .S VER=$S($P(GMRAL(AIEN),"^",4)=1:"VERIFIED",1:"NON-VERIFIED")
    20         .S VER1=$S($P(GMRAL(AIEN),"^",4)=1:"C",1:"U")  ;confirmed or unconfirmed
    21         .S $P(IAM,"|",2)=TYP1_CS_TYP_CS_"LGMR120.8"
    22         .S $P(IAM,"|",3)=AIEN_CS_$P(GMRAL(AIEN),"^",2)_CS_"LGMR120.8"
    23         .S IDX=$O(ADTL("O","")),X="" S:IDX'="" X=$G(ADTL("O",IDX))
    24         .S DAT=$P(X,"^"),DAT=$S(DAT'="":$$HLDATE^HLFNC(DAT,"DT"),1:"")
    25         .S SEV=$P(X,"^",2) S:SEV="" SEV="""""",DAT=""
    26         .S SEV1=$S(SEV="MILD":"MI",SEV="MODERATE":"MO",SEV="SEVERE":"SV",1:"U")
    27         .S $P(IAM,"|",4)=SEV1
    28         .S $P(IAM,"|",5)=$P($P(GMRAL(AIEN),"^",8),";")
    29         .S $P(IAM,"|",13)=DAT
    30         .S $P(IAM,"|",17)=VER1
    31         .S ^TMP("PSO",$J,PSI)="IAM|"_IAM,PSI=PSI+1
    32         .F  S IDX=$O(ADTL("O",IDX)) Q:IDX=""  D   ;repeat for all reactions
    33         ..S X=$G(ADTL("O",IDX)),DAT=$P(X,"^"),SEV=$P(X,"^",2) I SEV="" Q
    34         ..S DAT=$S(DAT'="":$$HLDATE^HLFNC(DAT,"DT"),1:"")
    35         ..S $P(IAM,FS,4)=SEV,$P(IAM,FS,13)=DAT
    36         ..S ^TMP("PSO",$J,PSI)="IAM|"_IAM,PSI=PSI+1
    37         S PAS3=1
    38         ;
    39 ZALQT   K GMRAL,ADTL,AIEN,CNT,CNT,GMRA,TYP,TYP1,SEV,SEV1,VER,VER1
    40         Q
    41         ;
    42 ORC(PSI)        ;common order segment
    43         Q:'$D(DFN)
    44         N ORC S ORC=""
    45         S $P(ORC,"|",1)="NW"
    46         S $P(ORC,"|",2)=IRXN_CS_"OP7.0"
    47         S $P(ORC,"|",9)=ISDT
    48         S $P(ORC,"|",10)=EBY_CS_EBY1
    49         S $P(ORC,"|",12)=PVDR_CS_PVDR1
    50         S $P(ORC,"|",13)=$G(PSOLAP)
    51         S $P(ORC,"|",15)=EFDT
    52         S $P(ORC,"|",16)=$S($G(RXPR(IRXN)):"PARTIAL",$G(RXFL(IRXN)):"REFILL",$G(RXRP(IRXN)):"REPRINT",1:"NEW")
    53         S $P(ORC,"|",17)=CLN_CS_CLN1_CS_"99PSC"
    54         S $P(ORC,"|",19)=$S(CSINER'="":CSINER_CS_CSINER1,1:"")
    55         S $P(ORC,"|",21)=$P(SITE,"^",1)_CS_CS_$P(SITE,"^",6)
    56         S PSZIP=$P(SITE,"^",5),PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
    57         S $P(ORC,"|",22)=$P(SITE,"^",2)_CS_CS_$P(SITE,"^",7)_CS_$S($D(^DIC(5,+$P(SITE,"^",8),0)):$P(^(0),"^",2),1:"UKN")_CS_PSOHZIP
    58         S $P(ORC,"|",23)="("_$P(SITE,"^",3)_")"_$P(SITE,"^",4)
    59         S ^TMP("PSO",$J,PSI)="ORC|"_ORC,PSI=PSI+1
    60         Q
    61         ;
    62 NTEPMI(PSI)     ;build NTE segment for PMI sheets                   ;*255
    63         Q:'$D(DFN)  N A,I,PREVLN,CURRLN,PMI,PSNMSG,PSDRUG
    64         S PSDRUG=+$P(^PSRX(IRXN,0),"^",6),PMI=$$EN^PSNPPIO(PSDRUG,.PSNMSG)
    65         Q:'$D(^TMP($J,"PSNPMI"))
    66         ;PSO*7*279 Add missing PMI ID(7) to NTE Segment
    67         S ^TMP("PSO",$J,PSI)="NTE"_FS_7_FS_FS_^TMP($J,"PSNPMI",0)
    68         K A S CNT1=1,CNT=0
    69         F A="W","U","H","S","M","P","I","O","N","D","R" S CNT=CNT+1,A(CNT)=A
    70         F I=1:1:11 I $D(^TMP($J,"PSNPMI",A(I))) D
    71         .S CNT=$P(^TMP($J,"PSNPMI",A(I),0),"^",3)
    72         .S (PREVLN,CURRLN)=""
    73         .F J=1:1:CNT D
    74         .. S ^TMP("PSO",$J,PSI,CNT1)=^TMP($J,"PSNPMI",A(I),J,0)
    75         .. ;PSO*198 check if " " should be inserted
    76         .. S CURRLN=^TMP("PSO",$J,PSI,CNT1)
    77         .. S:CNT1>1 PREVLN=$S(CNT>1:^TMP("PSO",$J,PSI,CNT1-1),1:"")
    78         .. I CNT1>1,$$SPACE^PSOHLDS3(PREVLN,CURRLN) D
    79         ... S ^TMP("PSO",$J,PSI,CNT1)=" "_^TMP("PSO",$J,PSI,CNT1)
    80         .. I J=1 S $P(^TMP("PSO",$J,PSI,CNT1),":",1)="\H\"_$P(^TMP("PSO",$J,PSI,CNT1),":",1)_"\N\"
    81         .. S CNT1=CNT1+1
    82         S ^TMP("PSO",$J,PSI,CNT1-1)=^TMP("PSO",$J,PSI,CNT1-1)_FS_"Patient Medication Instructions"
    83         S PSI=PSI+1 K A,I,J,CNT,CNT1,^TMP($J,"PSNPMI")
    84         Q
     1PSOHLDS4 ;BIR/PWC-Build HL7 Segments for Automated Interface ;11/13/06 1:13pm
     2 ;;7.0;OUTPATIENT PHARMACY;**156,255**;DEC 1997;Build 9
     3 ;HLFNC       supp. by DBIA 10106
     4 ;DIC(5       supp. by DBIA 10056
     5 ;EN^PSNPPIO  supp. by DBIA 3794
     6 ;This routine is called from PSOHLDS1
     7 ;
     8 ;*255 moved tag NTEPMI from PSOHLDS2
     9 Q
     10IAM(PSI) ;allergy list segment
     11 Q:'$D(DFN)!$D(PAS3)
     12 N IAM,IDX,SEV,SEV1,DAT,X,TYP,TYP1,VER,VER1
     13 S IAM="",CNT=0,GMRA="0^0^111" D EN1^GMRADPT
     14 I $G(GMRAL)="" G ZALQT
     15 F AIEN=0:0 S AIEN=$O(GMRAL(AIEN)) Q:'AIEN  D
     16 .K ADTL D EN1^GMRAOR2(AIEN,"ADTL") S CNT=CNT+1
     17 .S TYP1=$P(GMRAL(AIEN),"^",7)
     18 .S TYP=$S(TYP1="D":"DRUG",TYP1="F":"FOOD",TYP1="O":"OTHER",TYP1="DF":"DRUG/FOOD",TYP1="DO":"DRUG/OTHER",TYP1="DFO":"DRUG/FOOD/OTHER",1:"""""")
     19 .S VER=$S($P(GMRAL(AIEN),"^",4)=1:"VERIFIED",1:"NON-VERIFIED")
     20 .S VER1=$S($P(GMRAL(AIEN),"^",4)=1:"C",1:"U")  ;confirmed or unconfirmed
     21 .S $P(IAM,"|",2)=TYP1_CS_TYP_CS_"LGMR120.8"
     22 .S $P(IAM,"|",3)=AIEN_CS_$P(GMRAL(AIEN),"^",2)_CS_"LGMR120.8"
     23 .S IDX=$O(ADTL("O","")),X="" S:IDX'="" X=$G(ADTL("O",IDX))
     24 .S DAT=$P(X,"^"),DAT=$S(DAT'="":$$HLDATE^HLFNC(DAT,"DT"),1:"")
     25 .S SEV=$P(X,"^",2) S:SEV="" SEV="""""",DAT=""
     26 .S SEV1=$S(SEV="MILD":"MI",SEV="MODERATE":"MO",SEV="SEVERE":"SV",1:"U")
     27 .S $P(IAM,"|",4)=SEV1
     28 .S $P(IAM,"|",5)=$P($P(GMRAL(AIEN),"^",8),";")
     29 .S $P(IAM,"|",13)=DAT
     30 .S $P(IAM,"|",17)=VER1
     31 .S ^TMP("PSO",$J,PSI)="IAM|"_IAM,PSI=PSI+1
     32 .F  S IDX=$O(ADTL("O",IDX)) Q:IDX=""  D   ;repeat for all reactions
     33 ..S X=$G(ADTL("O",IDX)),DAT=$P(X,"^"),SEV=$P(X,"^",2) I SEV="" Q
     34 ..S DAT=$S(DAT'="":$$HLDATE^HLFNC(DAT,"DT"),1:"")
     35 ..S $P(IAM,FS,4)=SEV,$P(IAM,FS,13)=DAT
     36 ..S ^TMP("PSO",$J,PSI)="IAM|"_IAM,PSI=PSI+1
     37 S PAS3=1
     38 ;
     39ZALQT K GMRAL,ADTL,AIEN,CNT,CNT,GMRA,TYP,TYP1,SEV,SEV1,VER,VER1
     40 Q
     41 ;
     42ORC(PSI) ;common order segment
     43 Q:'$D(DFN)
     44 N ORC S ORC=""
     45 S $P(ORC,"|",1)="NW"
     46 S $P(ORC,"|",2)=IRXN_CS_"OP7.0"
     47 S $P(ORC,"|",9)=ISDT
     48 S $P(ORC,"|",10)=EBY_CS_EBY1
     49 S $P(ORC,"|",12)=PVDR_CS_PVDR1
     50 S $P(ORC,"|",13)=$G(PSOLAP)
     51 S $P(ORC,"|",15)=EFDT
     52 S $P(ORC,"|",16)=$S($G(RXPR(IRXN)):"PARTIAL",$G(RXFL(IRXN)):"REFILL",$G(RXRP(IRXN)):"REPRINT",1:"NEW")
     53 S $P(ORC,"|",17)=CLN_CS_CLN1_CS_"99PSC"
     54 S $P(ORC,"|",19)=$S(CSINER'="":CSINER_CS_CSINER1,1:"")
     55 S $P(ORC,"|",21)=$P(SITE,"^",1)_CS_CS_$P(SITE,"^",6)
     56 S PSZIP=$P(SITE,"^",5),PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
     57 S $P(ORC,"|",22)=$P(SITE,"^",2)_CS_CS_$P(SITE,"^",7)_CS_$S($D(^DIC(5,+$P(SITE,"^",8),0)):$P(^(0),"^",2),1:"UKN")_CS_PSOHZIP
     58 S $P(ORC,"|",23)="("_$P(SITE,"^",3)_")"_$P(SITE,"^",4)
     59 S ^TMP("PSO",$J,PSI)="ORC|"_ORC,PSI=PSI+1
     60 Q
     61 ;
     62NTEPMI(PSI) ;build NTE segment for PMI sheets                   ;*255
     63 Q:'$D(DFN)  N A,I,PREVLN,CURRLN,PMI,PSNMSG,PSDRUG
     64 S PSDRUG=+$P(^PSRX(IRXN,0),"^",6),PMI=$$EN^PSNPPIO(PSDRUG,.PSNMSG)
     65 Q:'$D(^TMP($J,"PSNPMI"))
     66 S ^TMP("PSO",$J,PSI)="NTE"_FS_^TMP($J,"PSNPMI",0)_FS
     67 K A S CNT1=1,CNT=0
     68 F A="W","U","H","S","M","P","I","O","N","D","R" S CNT=CNT+1,A(CNT)=A
     69 F I=1:1:11 I $D(^TMP($J,"PSNPMI",A(I))) D
     70 .S CNT=$P(^TMP($J,"PSNPMI",A(I),0),"^",3)
     71 .S (PREVLN,CURRLN)=""
     72 .F J=1:1:CNT D
     73 .. S ^TMP("PSO",$J,PSI,CNT1)=^TMP($J,"PSNPMI",A(I),J,0)
     74 .. ;PSO*198 check if " " should be inserted
     75 .. S CURRLN=^TMP("PSO",$J,PSI,CNT1)
     76 .. S:CNT1>1 PREVLN=$S(CNT>1:^TMP("PSO",$J,PSI,CNT1-1),1:"")
     77 .. I CNT1>1,$$SPACE^PSOHLDS3(PREVLN,CURRLN) D
     78 ... S ^TMP("PSO",$J,PSI,CNT1)=" "_^TMP("PSO",$J,PSI,CNT1)
     79 .. I J=1 S $P(^TMP("PSO",$J,PSI,CNT1),":",1)="\H\"_$P(^TMP("PSO",$J,PSI,CNT1),":",1)_"\N\"
     80 .. S CNT1=CNT1+1
     81 S ^TMP("PSO",$J,PSI,CNT1-1)=^TMP("PSO",$J,PSI,CNT1-1)_FS_"Patient Medication Instructions"
     82 S PSI=PSI+1 K A,I,J,CNT,CNT1,^TMP($J,"PSNPMI")
     83 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLEXP.m

    r613 r623  
    1 PSOHLEXP        ;BIR/RTR-Auto expire prescriptions ; 10/10/07 11:16am
    2         ;;7.0;OUTPATIENT PHARMACY;**10,22,36,73,148,257**;DEC 1997;Build 19
    3         ;
    4         ;External reference to ^PS(59.7 supported by DBIA 694
    5         ;External reference to STATUS^ORQOR2 is supported by DBIA 3458
    6         ;External references to LOCK1^ORX2 and UNLK1^ORX2 are supported by DBIA 867
    7 EN      N PSOEXRX,PSOEXCOM,PSOEXSTS,SUSD,PSOEXSTA,ZZDT,ZZEDT,IFN,NODE,RF,PIFN,PSUSD,PRFDT,PDA,PSDTEST,ORN,CPRSDC
    8         I '$G(DT) S DT=$$DT^XLFDT
    9         S X1=DT,X2=-1 D C^%DTC S ZZEDT=X
    10         S ZZDT=$P($G(^PS(59.7,1,49.99)),"^",8) I +ZZDT=0 S X1=DT,X2=-2 D C^%DTC S ZZDT=X
    11         F  S ZZDT=$O(^PSRX("AG",ZZDT)) Q:ZZDT>ZZEDT  Q:ZZDT=""  D EN1
    12         Q
    13 EN1     F PSOEXRX=0:0 S PSOEXRX=$O(^PSRX("AG",ZZDT,PSOEXRX)) Q:'PSOEXRX  D:$D(^PSRX(PSOEXRX,0))
    14         .N CPRSDC,CPRSSTA
    15         .S CPRSDC=",1,7,12,13,"
    16         .S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2),CPRSSTA=""
    17         .I ORN S CPRSSTA=+$$STATUS^ORQOR2(ORN) I CPRSSTA=0 S ORN=""
    18         .Q:$P($G(^PSRX(PSOEXRX,2)),"^",6)'=ZZDT
    19         .K CMOP S DA=PSOEXRX I DA D ^PSOCMOPA  ;*257 ;SET UP CMOP() ARRAY
    20         .S DA=$O(^PS(52.5,"B",PSOEXRX,0))
    21         .I DA S SUSD=$P($G(^PS(52.5,DA,0)),"^",2) I SUSD,$P($G(^(0)),"^",3) S DIK="^PS(52.5," D ^DIK K DIK
    22         .I $D(^PS(52.4,PSOEXRX,0)) S DIK="^PS(52.4,",DA=PSOEXRX D ^DIK K DIK
    23         .I $G(^PSRX(PSOEXRX,"H"))]"" K:$P(^PSRX(PSOEXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOEXRX,"H"),"^"),PSOEXRX) S ^PSRX(PSOEXRX,"H")=""
    24         .S PSOEXSTA=$P($G(^PSRX(PSOEXRX,"STA")),"^")
    25         .I PSOEXSTA=13 D  Q
    26         ..I 'ORN D EN^PSOHDR("PRES",PSOEXRX)
    27         .I PSOEXSTA=12!(PSOEXSTA=14)!(PSOEXSTA=15) I ORN,CPRSDC'[(","_CPRSSTA_",") D
    28         ..D EN^PSOHLSN1(PSOEXRX,"OD","","","A")
    29         ..I ORN S CPRSSTA=+$$STATUS^ORQOR2(ORN)
    30         .I PSOEXSTA=11 I ORN,CPRSDC'[(","_CPRSSTA_",") D
    31         ..S $P(^PSRX(PSOEXRX,0),"^",19)=1
    32         ..D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired")
    33         .I PSOEXSTA>9&(PSOEXSTA'=16) Q
    34         .S $P(^PSRX(PSOEXRX,"STA"),"^")=11
    35         .D REVERSE^PSOBPSU1(PSOEXRX,0,"DE",5,"RX EXPIRED")
    36         .S (PIFN,PSUSD,PRFDT)=0 F  S PIFN=$O(^PSRX(PSOEXRX,1,PIFN)) Q:'PIFN  S PSUSD=PIFN,PRFDT=+$P($G(^PSRX(PSOEXRX,1,PIFN,0)),"^")
    37         .S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2)
    38         .I $G(PSUSD) I '$P($G(^PSRX(PSOEXRX,1,PSUSD,0)),"^",18) S PSDTEST=0 D  I 'PSDTEST K ^PSRX(PSOEXRX,1,PSUSD),^PSRX("AD",PRFDT,PSOEXRX,PSUSD),^PSRX(PSOEXRX,1,"B",PRFDT,PSUSD) D NSET
    39         ..D REVERSE^PSOBPSU1(PSOEXRX,PSUSD,"DE",5,"RX EXPIRED")
    40         ..F PDA=0:0 S PDA=$O(^PSRX(PSOEXRX,"L",PDA)) Q:'PDA  I $P($G(^PSRX(PSOEXRX,"L",PDA,0)),"^",2)=PSUSD S PSDTEST=1
    41         ..I $G(CMOP(CMOP("L")))="",".L.X."[("."_$G(CMOP("S"))_".") S PSDTEST=1
    42         ..N PSOORL
    43         ..S PSOORL=$$LOCK1^ORX2(ORN) S:'PSOORL PSDTEST=1 I PSOORL D UNLK1^ORX2(ORN)
    44         ..N PDA0
    45         ..;S PDAQ=0
    46         ..F PDA=0:0 S PDA=$O(^PSRX(PSOEXRX,4,PDA)) Q:'PDA  D
    47         ...S PDA0=$G(^PSRX(PSOEXRX,4,PDA,0))
    48         ...I $P(PDA0,"^",3)=PSUSD S PSDTEST=1   ;*257
    49         ..;Q:'PDAQ
    50         ..;S PSDTEST=1
    51         .I 'ORN D EN^PSOHDR("PRES",PSOEXRX) Q
    52         .I CPRSDC[(","_CPRSSTA_",") D EN^PSOHDR("PRES",PSOEXRX) Q
    53         .S $P(^PSRX(PSOEXRX,0),"^",19)=1
    54         .S PSOEXCOM="Prescription past expiration date" D EN^PSOHLSN1(PSOEXRX,"SC","ZE",PSOEXCOM)
    55         S DIE=59.7,DA=1,DR="49.95///"_ZZDT D ^DIE K DIE,DA,DR
    56         Q
    57 NSET    ;
    58         N PSONM,PSONMX
    59         S PSONM="" F PSONMX=0:0 S PSONMX=$O(^PSRX(PSOEXRX,1,PSONMX)) Q:'PSONMX  S PSONM=PSONMX
    60         S ^PSRX(PSOEXRX,1,0)="^52.1DA^"_$G(PSONM)_"^"_$G(PSONM)
    61         Q
    62 SETUP   ;
    63         K %DT,DIC,DTOUT S DIC(0)="XZM",DIC="^DIC(19.2,",X="PSO EXPIRE PRESCRIPTIONS" D ^DIC
    64         I +Y>0 D EDIT^XUTMOPT("PSO EXPIRE PRESCRIPTIONS") K DIC,Y,X Q
    65         D RESCH^XUTMOPT("PSO EXPIRE PRESCRIPTIONS","","","24H","L"),EDIT^XUTMOPT("PSO EXPIRE PRESCRIPTIONS") K DIC,Y,X
    66 OUT     Q
     1PSOHLEXP ;BIR/RTR-Auto expire prescriptions ;10/10/96
     2 ;;7.0;OUTPATIENT PHARMACY;**10,22,36,73,148**;DEC 1997
     3 ;External reference to STATUS^ORQOR2 is supported by DBIA 3458
     4 ;
     5EN N PSOEXRX,PSOEXCOM,PSOEXSTS,SUSD,PSOEXSTA,ZZDT,IFN,NODE,RF,PIFN,PSUSD,PRFDT,PDA,PSDTEST,ORN
     6 I '$G(DT) S DT=$$DT^XLFDT
     7 S X1=DT,X2=-1 D C^%DTC S ZZDT=X
     8 F PSOEXRX=0:0 S PSOEXRX=$O(^PSRX("AG",ZZDT,PSOEXRX)) Q:'PSOEXRX  D:$D(^PSRX(PSOEXRX,0))
     9 .Q:$P($G(^PSRX(PSOEXRX,2)),"^",6)'=ZZDT
     10 .S DA=$O(^PS(52.5,"B",PSOEXRX,0))
     11 .I DA S SUSD=$P($G(^PS(52.5,DA,0)),"^",2) I SUSD,$P($G(^(0)),"^",3) S DIK="^PS(52.5," D ^DIK K DIK
     12 .I $D(^PS(52.4,PSOEXRX,0)) S DIK="^PS(52.4,",DA=PSOEXRX D ^DIK K DIK
     13 .I $G(^PSRX(PSOEXRX,"H"))]"" K:$P(^PSRX(PSOEXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOEXRX,"H"),"^"),PSOEXRX) S ^PSRX(PSOEXRX,"H")=""
     14 .S PSOEXSTA=$P($G(^PSRX(PSOEXRX,"STA")),"^")
     15 .Q:PSOEXSTA=13!(PSOEXSTA="")
     16 .I '$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) D EN^PSOHLSN1(PSOEXRX,"ZC","") I $P($G(^PSRX(PSOEXRX,"OR1")),"^",2) D
     17 ..I PSOEXSTA=12!(PSOEXSTA=14)!(PSOEXSTA=15) D EN^PSOHLSN1(PSOEXRX,"OD","","","A")
     18 .I PSOEXSTA=11 S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) I ORN,+$$STATUS^ORQOR2(ORN)=6 D
     19 ..S $P(^PSRX(PSOEXRX,0),"^",19)=1
     20 ..D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired")
     21 .Q:PSOEXSTA>9
     22 .S $P(^PSRX(PSOEXRX,"STA"),"^")=11
     23 .I '$G(PSUSD) D REVERSE^PSOBPSU1(PSOEXRX,0,"DE",5,"RX EXPIRED")
     24 .S (PIFN,PSUSD,PRFDT)=0 F  S PIFN=$O(^PSRX(PSOEXRX,1,PIFN)) Q:'PIFN  S PSUSD=PIFN,PRFDT=+$P($G(^PSRX(PSOEXRX,1,PIFN,0)),"^")
     25 .I $G(PSUSD) I '$P($G(^PSRX(PSOEXRX,1,PSUSD,0)),"^",18) S PSDTEST=0 D  I 'PSDTEST K ^PSRX(PSOEXRX,1,PSUSD),^PSRX("AD",PRFDT,PSOEXRX,PSUSD),^PSRX(PSOEXRX,1,"B",PRFDT,PSUSD) D NSET
     26 ..D REVERSE^PSOBPSU1(PSOEXRX,PSUSD,"DE",5,"RX EXPIRED")
     27 ..F PDA=0:0 S PDA=$O(^PSRX(PSOEXRX,"L",PDA)) Q:'PDA  I $P($G(^PSRX(PSOEXRX,"L",PDA,0)),"^",2)=PSUSD S PSDTEST=1
     28 ..S DA=PSOEXRX K CMOP D ^PSOCMOPA I $G(CMOP(CMOP("L")))="",$G(CMOP("S"))'="L" Q
     29 ..S PSDTEST=1
     30 .Q:'$P($G(^PSRX(PSOEXRX,"OR1")),"^",2)
     31 .S $P(^PSRX(PSOEXRX,0),"^",19)=1
     32 .S PSOEXCOM="Prescription past expiration date" D EN^PSOHLSN1(PSOEXRX,"SC","ZE",PSOEXCOM)
     33 Q
     34NSET ;
     35 N PSONM,PSONMX
     36 S PSONM="" F PSONMX=0:0 S PSONMX=$O(^PSRX(PSOEXRX,1,PSONMX)) Q:'PSONMX  S PSONM=PSONMX
     37 S ^PSRX(PSOEXRX,1,0)="^52.1DA^"_$G(PSONM)_"^"_$G(PSONM)
     38 Q
     39SETUP ;
     40 K %DT,DIC,DTOUT S DIC(0)="XZM",DIC="^DIC(19.2,",X="PSO EXPIRE PRESCRIPTIONS" D ^DIC
     41 I +Y>0 D EDIT^XUTMOPT("PSO EXPIRE PRESCRIPTIONS") K DIC,Y,X Q
     42 D RESCH^XUTMOPT("PSO EXPIRE PRESCRIPTIONS","","","24H","L"),EDIT^XUTMOPT("PSO EXPIRE PRESCRIPTIONS") K DIC,Y,X
     43OUT Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE1.m

    r613 r623  
    1 PSOHLNE1        ;BIR/RTR-Parsing out segments from OERR ;01/20/95
    2         ;;7.0;OUTPATIENT PHARMACY;**1,9,46,71,98,111,117,131,157,181,143,235,239,225**;DEC 1997;Build 29
    3         ;External reference to EN^ORERR supported by DBIA 2187
    4         ;External reference to PS(50.607 supported by DBIA 2221
    5         ;External reference to OR(100 supported by DBIA 2219
    6         ;External reference to PSDRUG( supported by DBIA 221
    7         ;External reference VADPT supported by DBIA 10061
    8         ;
    9 EN      ;ORC segment
    10         N Q1,Q2,Q3,Q4,Q5,Q6,Q7,PSOPOSSD
    11         K PSOLQ1I,PSOLQ1II,PSOLQ1IX
    12         I '$O(MSG(ZZ,0)) D
    13         .S PSOOC="NW",PLACER=+$P(PSOSEG,"|",2),PLACERXX=+$P($P(PSOSEG,"|",2),";",2),ENTERED=$P(PSOSEG,"|",10),PROV=$P(PSOSEG,"|",12)
    14         .S X=$P(PSOSEG,"|",15) S EFFECT=$$HL7TFM^XLFDT(X) K X
    15         .D NOW^%DTC S PSOLOG=% K %
    16         .;S RSN=$P(PSOSEG,"|",16)
    17         .S ORCSEG=$P(PSOSEG,"|",7),QCOUNT=1 Q:$G(ORCSEG)'["~"
    18         .F JJ=1:1:$L(ORCSEG) S:$E(ORCSEG,JJ)="~" QCOUNT=QCOUNT+1
    19         I '$O(MSG(ZZ,0)) D  Q
    20         .F JJJ=1:1:QCOUNT S QQQ=$P(ORCSEG,"~",JJJ) D:QQQ'=""
    21         ..S PSOPOSSD=$S($P($P(QQQ,"^"),"&"):1,1:0) ;PSOPOSSD=1 if possible dose
    22         ..S Q1I(JJJ)=$S(PSOPOSSD:$P(QQQ,"^"),1:$P(QQQ,"^",8)),PSOLQ1IX(JJJ)=$P($P(QQQ,"^"),"&",5) S PSOLQ1I(JJJ)=$P(QQQ,"^",8),PSOLQ1II(JJJ)=PSOPOSSD ;ORC piece 1 if Possible Dosage, ORC piece 8 if Local Possible Dosage
    23         ..S Q1(JJJ)=$P(QQQ,"^",2) ;schedule
    24         ..S Q2(JJJ)=$P(QQQ,"^",3) ;duration
    25         ..S Q3(JJJ)=$P(QQQ,"^",4) I Q3(JJJ) S X=Q3(JJJ) S Q3(JJJ)=$$HL7TFM^XLFDT(X) K X ;start date
    26         ..S Q4(JJJ)=$P(QQQ,"^",5) ;end date
    27         ..S:$G(PRIOR)="" PRIOR=$P(QQQ,"^",6)
    28         ..S Q6(JJJ)=$P(QQQ,"^",9) ;conjunction
    29         ..S Q7(JJJ)=$P(QQQ,"^",10) ;sequencing
    30         ..S QTARRAY(JJJ)=Q1(JJJ)_"^"_Q2(JJJ)_"^"_Q3(JJJ)_"^"_Q4(JJJ)_"^^"_Q6(JJJ)_"^"_Q7(JJJ)
    31         ..S QTARRAY2(JJJ)=$S(PSOPOSSD:$P(Q1I(JJJ),"&"),1:Q1I(JJJ))_"^"_$S(PSOPOSSD:$P(Q1I(JJJ),"&",3),1:"")
    32         ..I PSOPOSSD S $P(QTARRAY(JJJ),"^",5)=$P(Q1I(JJJ),"&",4)
    33         ..I PSOPOSSD S PSOUNN=$P(Q1I(JJJ),"&",2) I PSOUNN'="" S PSOUNN=$O(^PS(50.607,"B",PSOUNN,0)) S $P(QTARRAY(JJJ),"^",9)=$G(PSOUNN)
    34         ..K PSOUNN
    35         ;For multiple ORC subscripts
    36         S (POVAR,POVAR1)="",(NNCK,NNN,NNNN)=0,PSOIII=1,MSG(ZZ,0)=$E(MSG(ZZ),5,$L(MSG(ZZ)))
    37         S AAA="" F  S AAA=$O(MSG(ZZ,AAA)) Q:AAA=""  S NNN=0 F OOO=1:1:$L(MSG(ZZ,AAA)) S NNN=NNN+1 D  D:$G(POVAR1)="~"&(NNNN=6) PARSE D:$G(POVAR1)="|" PARSE
    38         .I $E(MSG(ZZ,AAA),OOO)="|" S NNNN=NNNN+1
    39         .S POVAR1=$E(MSG(ZZ,AAA),OOO)
    40         .S POLIM=POVAR
    41         .S POVAR=$S(POVAR="":POVAR1,1:POVAR_POVAR1)
    42         .;I NNNN=6 I $G(POVAR1)="~"!($G(POVAR1)="|")
    43 END     ;16 OF ORC?
    44         ;I $G(POVAR)'="" I NNNN=14!(NNNN=15) S EFFECT=$G(POVAR)
    45         S QCOUNT=0 F JJJ=0:0 S JJJ=$O(QTVAR(JJJ)) Q:'JJJ  I $L($G(QTVAR(JJJ))) S QCOUNT=QCOUNT+1 D
    46         .S PSOPOSSD=$S($P($P(QTVAR(JJJ),"^"),"&"):1,1:0) ;PSOPOSSD =1 if possible dose
    47         .S Q1I(JJJ)=$S(PSOPOSSD:$P(QTVAR(JJJ),"^"),1:$P(QTVAR(JJJ),"^",8)),PSOLQ1IX(JJJ)=$P($P(QTVAR(JJJ),"^"),"&",5) S PSOLQ1I(JJJ)=$P(QTVAR(JJJ),"^",8),PSOLQ1II(JJJ)=PSOPOSSD ;piece 1 if possible dose, piece 8 if not
    48         .S Q1(JJJ)=$P(QTVAR(JJJ),"^",2)
    49         .S Q2(JJJ)=$P(QTVAR(JJJ),"^",3)
    50         .;S Q2(JJJ)=$S($E($P(QTVAR(JJJ),"^",3)):"D"_$P(QTVAR(JJJ),"^",3),$E($P(QTVAR(JJJ),"^",3))=0:"D"_$P(QTVAR(JJJ),"^",3),1:$P(QTVAR(JJJ),"^",3))
    51         .S Q3(JJJ)=$P(QTVAR(JJJ),"^",4) I Q3(JJJ) S X=Q3(JJJ) S Q3(JJJ)=$$HL7TFM^XLFDT(X) K X
    52         .S Q4(JJJ)=$P(QTVAR(JJJ),"^",5)
    53         .S:$G(PRIOR)="" PRIOR=$P(QTVAR(JJJ),"^",6)
    54         .S Q6(JJJ)=$P(QTVAR(JJJ),"^",9)
    55         .S Q7(JJJ)=$P(QTVAR(JJJ),"^",10)
    56         .S QTARRAY(JJJ)=Q1(JJJ)_"^"_Q2(JJJ)_"^"_Q3(JJJ)_"^"_Q4(JJJ)_"^^"_Q6(JJJ)_"^"_Q7(JJJ)
    57         .S QTARRAY2(JJJ)=$S(PSOPOSSD:$P(Q1I(JJJ),"&"),1:Q1I(JJJ))_"^"_$S(PSOPOSSD:$P(Q1I(JJJ),"&",3),1:"")
    58         .I PSOPOSSD S $P(QTARRAY(JJJ),"^",5)=$P(Q1I(JJJ),"&",4)
    59         .I PSOPOSSD S PSOUNN=$P(Q1I(JJJ),"&",2) I PSOUNN'="" S PSOUNN=$O(^PS(50.607,"B",PSOUNN,0)) S $P(QTARRAY(JJJ),"^",9)=$G(PSOUNN)
    60         .K PSOUNN
    61         I $G(EFFECT) S X=EFFECT S EFFECT=$$HL7TFM^XLFDT(X) K X
    62         D NOW^%DTC S PSOLOG=% S:'$G(EFFECT) EFFECT=% K %
    63         K MSG(ZZ,0)
    64         Q
    65 PARSE   I NNNN=1 S PSOOC="NW" G SET
    66         I NNNN=2 S PLACER=+$G(POLIM),PLACERXX=+$P($G(POLIM),";",2) G SET
    67         I NNNN=3!(NNNN=4)!(NNNN=5) G SET
    68         I NNNN=6,$G(POVAR1)="~" S NNCK=NNCK+1,QTVAR(NNCK)=$G(POLIM) G SET
    69         I NNNN=7 S NNCK=NNCK+1 S QTVAR(NNCK)=$G(POLIM) G SET
    70         I NNNN=8!(NNNN=9) G SET
    71         I NNNN=10 S ENTERED=$G(POLIM) G SET
    72         I NNNN=11 G SET
    73         I NNNN=12 S PROV=$G(POLIM) G SET
    74         I NNNN=13!(NNNN=14) G SET
    75         I NNNN=15 S EFFECT=$G(POLIM)
    76 SET     S (POVAR,POLIM)="" Q
    77         ;
    78 EXP     ;
    79         ;Q:'$G(OR("PLACE"))
    80         Q:'$G(PSOFILNM)
    81         S PSOMSORR=1
    82         N PSOSSMES S PSOSSMES="CPRSUP"
    83         I $G(PSOFILNM),$G(PSOFILNM)["S" S LL=+$G(PSOFILNM) I $D(^PS(52.41,LL,0)),$P($G(^(0)),"^",3)'="RF" G EXPEN
    84         S LL=$G(PSOFILNM) I 'LL!('$D(^PSRX(+$G(LL),0))) S COMM="Order was not located by Pharmacy" D EN^ORERR(COMM,.MSG) D  G EXPQ
    85         .F EER=0:0 S EER=$O(MSG(EER)) Q:'EER  S:$P(MSG(EER),"|")="PV1" PSERRPV1=MSG(EER) S:$P(MSG(EER),"|")="PID" PSERRPID=MSG(EER) S:$P(MSG(EER),"|")="ORC"&($G(PSERRORC)="") PSERRORC=MSG(EER)
    86         .N MSG,PSOHINST D INIT^PSOHLSN S MSG(2)=$G(PSERRPID),MSG(3)=$G(PSERRPV1),MSG(4)="ORC|DE|"_$G(OR("PLACE"))_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PSERRORC),"|",4)'="":$P(PSERRORC,"|",4),1:"") S:$G(COMM)'="" MSG(5)="NTE|16||"_COMM
    87         .D SEND^PSOHLSN
    88         Q:'$D(^PSRX(LL,0))
    89         I +$P($G(^PSRX(LL,2)),"^",6)<DT D
    90         .;Reset PSOSSMES if status changes, so HDR gets updated in PSOHLSN1
    91         .I +$P($G(^PSRX(LL,"STA")),"^")<12!($P($G(^("STA")),"^")=16) S $P(^PSRX(LL,"STA"),"^")=11 D ECAN^PSOUTL(LL) S PSOSSMES="CPRSVDEF"
    92         S GG=+$P($G(^PSRX(LL,"STA")),"^")
    93         ;S AA=$S(GG=3:"OH",GG=12:"OD",GG=13:"OC",GG=14:"OD",GG=15:"OD",GG=16:"OH",1:"SC"),AAA=$S(GG=0:"CM",GG=1:"IP",GG=4:"IP",GG=5:"ZS",GG=11:"ZE",1:"")
    94         S AA="SC",AAA=$S(GG=0:"CM",GG=2:"CM",GG=1:"IP",GG=4:"IP",GG=5:"ZS",GG=3:"HD",GG=16:"HD",GG=11:"ZE",1:"DC")
    95         D EN^PSOHLSN1(LL,AA,AAA,"")
    96         K PSOSSMES
    97 EXPQ    K LL,GG,AA,AAA,PSOMSORR Q
    98 EXPEN   ;SS on Pending orders
    99         S AA=$P($G(^PS(52.41,LL,0)),"^",3)
    100         S AAA=$S(AA="DC"!(AA="DE"):"DC",AA="HD":"HD",1:"IP")
    101         D EN^PSOHLSN(OR("PLACE"),"SC",AAA)
    102         G EXPQ
    103         ;
    104 OID     ;Check for 1 to 1 match from Dispense Drug to Orderable Item
    105         N PSOCDD,PSOCDDI,PSOCDDIZ
    106         Q:'$G(PSORDITE)
    107         K PSOCDDIZ
    108         S (PSOCDD,PSOCDDI)=0
    109         F  S PSOCDD=$O(^PSDRUG("ASP",PSORDITE,PSOCDD)) Q:'PSOCDD  I $S('$P($G(^PSDRUG(PSOCDD,"I")),"^"):1,DT'>$P($G(^("I")),"^"):1,1:0),$P($G(^PSDRUG(PSOCDD,2)),"^",3)["O" S PSOCDDI=PSOCDDI+1,PSOCDDIZ=PSOCDD
    110         I PSOCDDI'=1 Q
    111         S PSOQWX=$G(PSOCDDIZ)
    112         Q
    113 CP      ;ZSC segment (replaced by ZCL segment)
    114         S SERV=$S($P(PSOSEG,"|")=1:"SC",$P(PSOSEG,"|")=0:"NSC",1:$P(PSOSEG,"|"))
    115         S PSOIBY=$P(PSOSEG,"|",2)_"^"_$P(PSOSEG,"|",3)_"^"_$P(PSOSEG,"|",4)_"^"_$P(PSOSEG,"|",5)_"^"_$P(PSOSEG,"|",6)_"^"_$P(PSOSEG,"|",7)_"^"_$P(PSOSEG,"|",8)
    116         Q
    117         ;
    118 ZCL     ;ZCL segment - SC/EI related to ICDs
    119         N SEQ,SEQ2,SEQ3 S SEQ3=$P(PSOSEG,"|",2),SEQ2=$P(PSOSEG,"|",1)
    120         S:'$D(PSOICD(SEQ2)) PSOICD(SEQ2)=""
    121         S $P(PSOICD(SEQ2),"^",(SEQ3+1))=$P(PSOSEG,"|",3)  ;set sc/ei for ICD node
    122         D SCP^PSORN52D K PSOSCA
    123         S:'$D(PSOIBY) PSOIBY=""
    124         I PSOSCP<50 D  ;set IBQ node variables if <50% SC
    125         . Q:$P(PSOIBY,U,$S(SEQ3=1:2,SEQ3=2:3,SEQ3=4:4,SEQ3=5:1,SEQ3=6:5,SEQ3=7:6,SEQ3=8:7,1:""))>0
    126         . S:SEQ3=1 $P(PSOIBY,U,2)=$P(PSOSEG,"|",3) ;AO
    127         . S:SEQ3=2 $P(PSOIBY,U,3)=$P(PSOSEG,"|",3) ;IR
    128         . S:SEQ3=3 SERV=$S($P(PSOSEG,"|",3)=1:"SC",$P(PSOSEG,"|",3)=0:"NSC",1:$P(PSOSEG,"|",3))           ;SC
    129         . S:SEQ3=4 $P(PSOIBY,U,4)=$P(PSOSEG,"|",3) ;EC
    130         . S:SEQ3=5 $P(PSOIBY,U,1)=$P(PSOSEG,"|",3) ;MST
    131         . S:SEQ3=6 $P(PSOIBY,U,5)=$P(PSOSEG,"|",3) ;HNC
    132         . S:SEQ3=7 $P(PSOIBY,U,6)=$P(PSOSEG,"|",3) ;CV
    133         . S:SEQ3=8 $P(PSOIBY,U,7)=$P(PSOSEG,"|",3) ;SHAD
    134         Q
    135 MISX    ;Mismatch patient on CPRS New Order
    136         S RCOMM="Patient mismatch on New Order from CPRS." D EN^ORERR(RCOMM,.MSG) S NWFLAG=1 D RERROR^PSOHLSN D KL^PSOHLSIH
    137         Q
    138 MISRN   ;Mismatch on CPRS renewal
    139         N PSOCINV
    140         I $G(PDFN)'=$P($G(^PSRX(+$G(PREV),0)),"^",2) D  S PSOMO=1 Q
    141         .S RCOMM="Patient mismatch on CPRS Renewal." D EN^ORERR(RCOMM,.MSG) S PSOXRP=1 D RERROR^PSOHLSN D KL^PSOHLSIH
    142         S PSOCINV=+$P($G(^OR(100,+$G(PLACER),3)),"^",5)
    143         I PSOCINV'=$P($G(^PSRX(+$G(PREV),"OR1")),"^",2) D  S PSOMO=1 Q
    144         .S RCOMM="Order mismatch on CPRS Renewal." D EN^ORERR(RCOMM,.MSG) S PSOCVI=1 D RERROR^PSOHLSN D KL^PSOHLSIH
    145         Q
    146 ZRX     ;Process ZRX segment
    147         I $P(PSOSEG,"|",3)="R" S PSOOC="RNW",PSRNFLAG=1
    148         S PREV=$S(+$P(PSOSEG,"|"):+$P(PSOSEG,"|"),1:"")
    149         I $P(PSOSEG,"|")["P"!($P(PSOSEG,"|")["S") S PFLAG=1
    150         S NATURE=$P(PSOSEG,"|",2)
    151         S PSORSO=$P(PSOSEG,"|",3)
    152         S ROUTING=$P(PSOSEG,"|",4)
    153         I ROUTING="" S ROUTING="M"
    154         I $P(PSOSEG,"|",7) S DSIG=1
    155         Q
    156 CHCS    ;Replace CHCS number with CPRS number in .01 field
    157         N PSOHTMP
    158         I $G(PDFN),PDFN'=+$P($G(^PS(52.41,+$G(PSOCHFFL),0)),"^",2) S COMM="Patient does not match" D EN^ORERR(COMM,.MSG) K PSOPLC,PSOFFL,PSOSND Q
    159         I '$D(^PS(52.41,+$G(PSOCHFFL),0)) S COMM="Order was not located by Pharmacy" D EN^ORERR(COMM,.MSG) K PSOPLC,PSOFFL,PSOSND Q
    160         S PSOHTMP=$P($G(^PS(52.41,+$G(PSOCHFFL),0)),"^")
    161         I PSOHTMP'="" K ^PS(52.41,"B",PSOHTMP,+$G(PSOCHFFL))
    162         S $P(^PS(52.41,+$G(PSOCHFFL),0),"^")=PSOPLC,^PS(52.41,"B",PSOPLC,+$G(PSOCHFFL))=""
    163         S $P(^PS(52.41,+$G(PSOCHFFL),"EXT"),"^",2)=1
    164         Q
    165 CNT     ;
    166         S TAC=0 F TACA=0:0 S TACA=$O(^PSRX(PREV,"A",TACA)) Q:'TACA  S TAC=TACA
    167         S PAC=0 F PACA=0:0 S PACA=$O(^PSRX(PREV,1,PACA)) Q:'PACA  S PAC=PACA
    168         D NOW^%DTC S TAC=TAC+1,^PSRX(PREV,"A",0)="^52.3DA^"_TAC_"^"_TAC,^PSRX(PREV,"A",TAC,0)=%_"^"_"C"_"^"_$S(+$G(PROV):$G(PROV),1:+$G(ENTERED))_"^"_PAC_"^"_"Discontinued due to CPRS edit"
    169         K TAC,PAC,TACA,PACA
    170         Q
    171 NTE     ;
    172         S WPCT=1,WORDP=$S($P(MSG(LL),"|",2):$P(MSG(LL),"|",2),1:$P(MSG(LL),"|",3)) S:$P(MSG(LL),"|",4)'="" WPARRAY(WORDP,WPCT)=$P(MSG(LL),"|",4) S:$P(MSG(LL),"|",4)'="" WPCT=WPCT+1 F LLL=0:0 S LLL=$O(MSG(LL,LLL)) Q:'LLL  D
    173         .I $G(MSG(LL,LLL))'="" S WPARRAY(WORDP,WPCT)=$G(MSG(LL,LLL)),WPCT=WPCT+1
    174         Q
     1PSOHLNE1 ;BIR/RTR-Parsing out segments from OERR ;01/20/95
     2 ;;7.0;OUTPATIENT PHARMACY;**1,9,46,71,98,111,117,131,157,181,143,235,239**;DEC 1997
     3 ;External reference to EN^ORERR supported by DBIA 2187
     4 ;External reference to PS(50.607 supported by DBIA 2221
     5 ;External reference to OR(100 supported by DBIA 2219
     6 ;External reference to PSDRUG( supported by DBIA 221
     7 ;External reference VADPT supported by DBIA 10061
     8 ;
     9EN ;ORC segment
     10 N Q1,Q2,Q3,Q4,Q5,Q6,Q7,PSOPOSSD
     11 K PSOLQ1I,PSOLQ1II,PSOLQ1IX
     12 I '$O(MSG(ZZ,0)) D
     13 .S PSOOC="NW",PLACER=+$P(PSOSEG,"|",2),PLACERXX=+$P($P(PSOSEG,"|",2),";",2),ENTERED=$P(PSOSEG,"|",10),PROV=$P(PSOSEG,"|",12)
     14 .S X=$P(PSOSEG,"|",15) S EFFECT=$$HL7TFM^XLFDT(X) K X
     15 .D NOW^%DTC S PSOLOG=% K %
     16 .;S RSN=$P(PSOSEG,"|",16)
     17 .S ORCSEG=$P(PSOSEG,"|",7),QCOUNT=1 Q:$G(ORCSEG)'["~"
     18 .F JJ=1:1:$L(ORCSEG) S:$E(ORCSEG,JJ)="~" QCOUNT=QCOUNT+1
     19 I '$O(MSG(ZZ,0)) D  Q
     20 .F JJJ=1:1:QCOUNT S QQQ=$P(ORCSEG,"~",JJJ) D:QQQ'=""
     21 ..S PSOPOSSD=$S($P($P(QQQ,"^"),"&"):1,1:0) ;PSOPOSSD=1 if possible dose
     22 ..S Q1I(JJJ)=$S(PSOPOSSD:$P(QQQ,"^"),1:$P(QQQ,"^",8)),PSOLQ1IX(JJJ)=$P($P(QQQ,"^"),"&",5) S PSOLQ1I(JJJ)=$P(QQQ,"^",8),PSOLQ1II(JJJ)=PSOPOSSD ;ORC piece 1 if Possible Dosage, ORC piece 8 if Local Possible Dosage
     23 ..S Q1(JJJ)=$P(QQQ,"^",2) ;schedule
     24 ..S Q2(JJJ)=$P(QQQ,"^",3) ;duration
     25 ..S Q3(JJJ)=$P(QQQ,"^",4) I Q3(JJJ) S X=Q3(JJJ) S Q3(JJJ)=$$HL7TFM^XLFDT(X) K X ;start date
     26 ..S Q4(JJJ)=$P(QQQ,"^",5) ;end date
     27 ..S:$G(PRIOR)="" PRIOR=$P(QQQ,"^",6)
     28 ..S Q6(JJJ)=$P(QQQ,"^",9) ;conjunction
     29 ..S Q7(JJJ)=$P(QQQ,"^",10) ;sequencing
     30 ..S QTARRAY(JJJ)=Q1(JJJ)_"^"_Q2(JJJ)_"^"_Q3(JJJ)_"^"_Q4(JJJ)_"^^"_Q6(JJJ)_"^"_Q7(JJJ)
     31 ..S QTARRAY2(JJJ)=$S(PSOPOSSD:$P(Q1I(JJJ),"&"),1:Q1I(JJJ))_"^"_$S(PSOPOSSD:$P(Q1I(JJJ),"&",3),1:"")
     32 ..I PSOPOSSD S $P(QTARRAY(JJJ),"^",5)=$P(Q1I(JJJ),"&",4)
     33 ..I PSOPOSSD S PSOUNN=$P(Q1I(JJJ),"&",2) I PSOUNN'="" S PSOUNN=$O(^PS(50.607,"B",PSOUNN,0)) S $P(QTARRAY(JJJ),"^",9)=$G(PSOUNN)
     34 ..K PSOUNN
     35 ;For multiple ORC subscripts
     36 S (POVAR,POVAR1)="",(NNCK,NNN,NNNN)=0,PSOIII=1,MSG(ZZ,0)=$E(MSG(ZZ),5,$L(MSG(ZZ)))
     37 S AAA="" F  S AAA=$O(MSG(ZZ,AAA)) Q:AAA=""  S NNN=0 F OOO=1:1:$L(MSG(ZZ,AAA)) S NNN=NNN+1 D  D:$G(POVAR1)="~"&(NNNN=6) PARSE D:$G(POVAR1)="|" PARSE
     38 .I $E(MSG(ZZ,AAA),OOO)="|" S NNNN=NNNN+1
     39 .S POVAR1=$E(MSG(ZZ,AAA),OOO)
     40 .S POLIM=POVAR
     41 .S POVAR=$S(POVAR="":POVAR1,1:POVAR_POVAR1)
     42 .;I NNNN=6 I $G(POVAR1)="~"!($G(POVAR1)="|")
     43END ;16 OF ORC?
     44 ;I $G(POVAR)'="" I NNNN=14!(NNNN=15) S EFFECT=$G(POVAR)
     45 S QCOUNT=0 F JJJ=0:0 S JJJ=$O(QTVAR(JJJ)) Q:'JJJ  I $L($G(QTVAR(JJJ))) S QCOUNT=QCOUNT+1 D
     46 .S PSOPOSSD=$S($P($P(QTVAR(JJJ),"^"),"&"):1,1:0) ;PSOPOSSD =1 if possible dose
     47 .S Q1I(JJJ)=$S(PSOPOSSD:$P(QTVAR(JJJ),"^"),1:$P(QTVAR(JJJ),"^",8)),PSOLQ1IX(JJJ)=$P($P(QTVAR(JJJ),"^"),"&",5) S PSOLQ1I(JJJ)=$P(QTVAR(JJJ),"^",8),PSOLQ1II(JJJ)=PSOPOSSD ;piece 1 if possible dose, piece 8 if not
     48 .S Q1(JJJ)=$P(QTVAR(JJJ),"^",2)
     49 .S Q2(JJJ)=$P(QTVAR(JJJ),"^",3)
     50 .;S Q2(JJJ)=$S($E($P(QTVAR(JJJ),"^",3)):"D"_$P(QTVAR(JJJ),"^",3),$E($P(QTVAR(JJJ),"^",3))=0:"D"_$P(QTVAR(JJJ),"^",3),1:$P(QTVAR(JJJ),"^",3))
     51 .S Q3(JJJ)=$P(QTVAR(JJJ),"^",4) I Q3(JJJ) S X=Q3(JJJ) S Q3(JJJ)=$$HL7TFM^XLFDT(X) K X
     52 .S Q4(JJJ)=$P(QTVAR(JJJ),"^",5)
     53 .S:$G(PRIOR)="" PRIOR=$P(QTVAR(JJJ),"^",6)
     54 .S Q6(JJJ)=$P(QTVAR(JJJ),"^",9)
     55 .S Q7(JJJ)=$P(QTVAR(JJJ),"^",10)
     56 .S QTARRAY(JJJ)=Q1(JJJ)_"^"_Q2(JJJ)_"^"_Q3(JJJ)_"^"_Q4(JJJ)_"^^"_Q6(JJJ)_"^"_Q7(JJJ)
     57 .S QTARRAY2(JJJ)=$S(PSOPOSSD:$P(Q1I(JJJ),"&"),1:Q1I(JJJ))_"^"_$S(PSOPOSSD:$P(Q1I(JJJ),"&",3),1:"")
     58 .I PSOPOSSD S $P(QTARRAY(JJJ),"^",5)=$P(Q1I(JJJ),"&",4)
     59 .I PSOPOSSD S PSOUNN=$P(Q1I(JJJ),"&",2) I PSOUNN'="" S PSOUNN=$O(^PS(50.607,"B",PSOUNN,0)) S $P(QTARRAY(JJJ),"^",9)=$G(PSOUNN)
     60 .K PSOUNN
     61 I $G(EFFECT) S X=EFFECT S EFFECT=$$HL7TFM^XLFDT(X) K X
     62 D NOW^%DTC S PSOLOG=% S:'$G(EFFECT) EFFECT=% K %
     63 K MSG(ZZ,0)
     64 Q
     65PARSE I NNNN=1 S PSOOC="NW" G SET
     66 I NNNN=2 S PLACER=+$G(POLIM),PLACERXX=+$P($G(POLIM),";",2) G SET
     67 I NNNN=3!(NNNN=4)!(NNNN=5) G SET
     68 I NNNN=6,$G(POVAR1)="~" S NNCK=NNCK+1,QTVAR(NNCK)=$G(POLIM) G SET
     69 I NNNN=7 S NNCK=NNCK+1 S QTVAR(NNCK)=$G(POLIM) G SET
     70 I NNNN=8!(NNNN=9) G SET
     71 I NNNN=10 S ENTERED=$G(POLIM) G SET
     72 I NNNN=11 G SET
     73 I NNNN=12 S PROV=$G(POLIM) G SET
     74 I NNNN=13!(NNNN=14) G SET
     75 I NNNN=15 S EFFECT=$G(POLIM)
     76SET S (POVAR,POLIM)="" Q
     77 ;
     78EXP ;
     79 ;Q:'$G(OR("PLACE"))
     80 Q:'$G(PSOFILNM)
     81 S PSOMSORR=1
     82 N PSOSSMES S PSOSSMES="CPRSUP"
     83 I $G(PSOFILNM),$G(PSOFILNM)["S" S LL=+$G(PSOFILNM) I $D(^PS(52.41,LL,0)),$P($G(^(0)),"^",3)'="RF" G EXPEN
     84 S LL=$G(PSOFILNM) I 'LL!('$D(^PSRX(+$G(LL),0))) S COMM="Order was not located by Pharmacy" D EN^ORERR(COMM,.MSG) D  G EXPQ
     85 .F EER=0:0 S EER=$O(MSG(EER)) Q:'EER  S:$P(MSG(EER),"|")="PV1" PSERRPV1=MSG(EER) S:$P(MSG(EER),"|")="PID" PSERRPID=MSG(EER) S:$P(MSG(EER),"|")="ORC"&($G(PSERRORC)="") PSERRORC=MSG(EER)
     86 .N MSG,PSOHINST D INIT^PSOHLSN S MSG(2)=$G(PSERRPID),MSG(3)=$G(PSERRPV1),MSG(4)="ORC|DE|"_$G(OR("PLACE"))_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PSERRORC),"|",4)'="":$P(PSERRORC,"|",4),1:"") S:$G(COMM)'="" MSG(5)="NTE|16||"_COMM
     87 .D SEND^PSOHLSN
     88 Q:'$D(^PSRX(LL,0))
     89 I +$P($G(^PSRX(LL,2)),"^",6)<DT D
     90 .;Reset PSOSSMES if status changes, so HDR gets updated in PSOHLSN1
     91 .I +$P($G(^PSRX(LL,"STA")),"^")<12!($P($G(^("STA")),"^")=16) S $P(^PSRX(LL,"STA"),"^")=11 D ECAN^PSOUTL(LL) S PSOSSMES="CPRSVDEF"
     92 S GG=+$P($G(^PSRX(LL,"STA")),"^")
     93 ;S AA=$S(GG=3:"OH",GG=12:"OD",GG=13:"OC",GG=14:"OD",GG=15:"OD",GG=16:"OH",1:"SC"),AAA=$S(GG=0:"CM",GG=1:"IP",GG=4:"IP",GG=5:"ZS",GG=11:"ZE",1:"")
     94 S AA="SC",AAA=$S(GG=0:"CM",GG=2:"CM",GG=1:"IP",GG=4:"IP",GG=5:"ZS",GG=3:"HD",GG=16:"HD",GG=11:"ZE",1:"DC")
     95 D EN^PSOHLSN1(LL,AA,AAA,"")
     96 K PSOSSMES
     97EXPQ K LL,GG,AA,AAA,PSOMSORR Q
     98EXPEN ;SS on Pending orders
     99 S AA=$P($G(^PS(52.41,LL,0)),"^",3)
     100 S AAA=$S(AA="DC"!(AA="DE"):"DC",AA="HD":"HD",1:"IP")
     101 D EN^PSOHLSN(OR("PLACE"),"SC",AAA)
     102 G EXPQ
     103 ;
     104OID ;Check for 1 to 1 match from Dispense Drug to Orderable Item
     105 N PSOCDD,PSOCDDI,PSOCDDIZ
     106 Q:'$G(PSORDITE)
     107 K PSOCDDIZ
     108 S (PSOCDD,PSOCDDI)=0
     109 F  S PSOCDD=$O(^PSDRUG("ASP",PSORDITE,PSOCDD)) Q:'PSOCDD  I $S('$P($G(^PSDRUG(PSOCDD,"I")),"^"):1,DT'>$P($G(^("I")),"^"):1,1:0),$P($G(^PSDRUG(PSOCDD,2)),"^",3)["O" S PSOCDDI=PSOCDDI+1,PSOCDDIZ=PSOCDD
     110 I PSOCDDI'=1 Q
     111 S PSOQWX=$G(PSOCDDIZ)
     112 Q
     113CP ;ZSC segment (replaced by ZCL segment)
     114 S SERV=$S($P(PSOSEG,"|")=1:"SC",$P(PSOSEG,"|")=0:"NSC",1:$P(PSOSEG,"|"))
     115 S PSOIBY=$P(PSOSEG,"|",2)_"^"_$P(PSOSEG,"|",3)_"^"_$P(PSOSEG,"|",4)_"^"_$P(PSOSEG,"|",5)_"^"_$P(PSOSEG,"|",6)_"^"_$P(PSOSEG,"|",7)
     116 Q
     117 ;
     118ZCL ;ZCL segment - SC/EI related to ICDs
     119 N SEQ,SEQ2,SEQ3 S SEQ3=$P(PSOSEG,"|",2),SEQ2=$P(PSOSEG,"|",1)
     120 S:'$D(PSOICD(SEQ2)) PSOICD(SEQ2)=""
     121 S $P(PSOICD(SEQ2),"^",(SEQ3+1))=$P(PSOSEG,"|",3)  ;set sc/ei for ICD node
     122 D SCP^PSORN52D K PSOSCA
     123 S:'$D(PSOIBY) PSOIBY=""
     124 I PSOSCP<50 D  ;set IBQ node variables if <50% SC
     125 . Q:$P(PSOIBY,U,$S(SEQ3=1:2,SEQ3=2:3,SEQ3=4:4,SEQ3=5:1,SEQ3=6:5,SEQ3=7:6,1:""))>0
     126 . S:SEQ3=1 $P(PSOIBY,U,2)=$P(PSOSEG,"|",3) ;AO
     127 . S:SEQ3=2 $P(PSOIBY,U,3)=$P(PSOSEG,"|",3) ;IR
     128 . S:SEQ3=3 SERV=$S($P(PSOSEG,"|",3)=1:"SC",$P(PSOSEG,"|",3)=0:"NSC",1:$P(PSOSEG,"|",3))           ;SC
     129 . S:SEQ3=4 $P(PSOIBY,U,4)=$P(PSOSEG,"|",3) ;EC
     130 . S:SEQ3=5 $P(PSOIBY,U,1)=$P(PSOSEG,"|",3) ;MST
     131 . S:SEQ3=6 $P(PSOIBY,U,5)=$P(PSOSEG,"|",3) ;HNC
     132 . S:SEQ3=7 $P(PSOIBY,U,6)=$P(PSOSEG,"|",3) ;CV
     133 ;E  D
     134 ;. S PSOIBY="^^^^^^",SERV=""
     135 Q
     136MISX ;Mismatch patient on CPRS New Order
     137 S RCOMM="Patient mismatch on New Order from CPRS." D EN^ORERR(RCOMM,.MSG) S NWFLAG=1 D RERROR^PSOHLSN D KL^PSOHLSIH
     138 Q
     139MISRN ;Mismatch on CPRS renewal
     140 N PSOCINV
     141 I $G(PDFN)'=$P($G(^PSRX(+$G(PREV),0)),"^",2) D  S PSOMO=1 Q
     142 .S RCOMM="Patient mismatch on CPRS Renewal." D EN^ORERR(RCOMM,.MSG) S PSOXRP=1 D RERROR^PSOHLSN D KL^PSOHLSIH
     143 S PSOCINV=+$P($G(^OR(100,+$G(PLACER),3)),"^",5)
     144 I PSOCINV'=$P($G(^PSRX(+$G(PREV),"OR1")),"^",2) D  S PSOMO=1 Q
     145 .S RCOMM="Order mismatch on CPRS Renewal." D EN^ORERR(RCOMM,.MSG) S PSOCVI=1 D RERROR^PSOHLSN D KL^PSOHLSIH
     146 Q
     147ZRX ;Process ZRX segment
     148 I $P(PSOSEG,"|",3)="R" S PSOOC="RNW",PSRNFLAG=1
     149 S PREV=$S(+$P(PSOSEG,"|"):+$P(PSOSEG,"|"),1:"")
     150 I $P(PSOSEG,"|")["P"!($P(PSOSEG,"|")["S") S PFLAG=1
     151 S NATURE=$P(PSOSEG,"|",2)
     152 S PSORSO=$P(PSOSEG,"|",3)
     153 S ROUTING=$P(PSOSEG,"|",4)
     154 I ROUTING="" S ROUTING="M"
     155 I $P(PSOSEG,"|",7) S DSIG=1
     156 Q
     157CHCS ;Replace CHCS number with CPRS number in .01 field
     158 N PSOHTMP
     159 I $G(PDFN),PDFN'=+$P($G(^PS(52.41,+$G(PSOCHFFL),0)),"^",2) S COMM="Patient does not match" D EN^ORERR(COMM,.MSG) K PSOPLC,PSOFFL,PSOSND Q
     160 I '$D(^PS(52.41,+$G(PSOCHFFL),0)) S COMM="Order was not located by Pharmacy" D EN^ORERR(COMM,.MSG) K PSOPLC,PSOFFL,PSOSND Q
     161 S PSOHTMP=$P($G(^PS(52.41,+$G(PSOCHFFL),0)),"^")
     162 I PSOHTMP'="" K ^PS(52.41,"B",PSOHTMP,+$G(PSOCHFFL))
     163 S $P(^PS(52.41,+$G(PSOCHFFL),0),"^")=PSOPLC,^PS(52.41,"B",PSOPLC,+$G(PSOCHFFL))=""
     164 S $P(^PS(52.41,+$G(PSOCHFFL),"EXT"),"^",2)=1
     165 Q
     166CNT ;
     167 S TAC=0 F TACA=0:0 S TACA=$O(^PSRX(PREV,"A",TACA)) Q:'TACA  S TAC=TACA
     168 S PAC=0 F PACA=0:0 S PACA=$O(^PSRX(PREV,1,PACA)) Q:'PACA  S PAC=PACA
     169 D NOW^%DTC S TAC=TAC+1,^PSRX(PREV,"A",0)="^52.3DA^"_TAC_"^"_TAC,^PSRX(PREV,"A",TAC,0)=%_"^"_"C"_"^"_$S(+$G(PROV):$G(PROV),1:+$G(ENTERED))_"^"_PAC_"^"_"Discontinued due to CPRS edit"
     170 K TAC,PAC,TACA,PACA
     171 Q
     172NTE ;
     173 S WPCT=1,WORDP=$S($P(MSG(LL),"|",2):$P(MSG(LL),"|",2),1:$P(MSG(LL),"|",3)) S:$P(MSG(LL),"|",4)'="" WPARRAY(WORDP,WPCT)=$P(MSG(LL),"|",4) S:$P(MSG(LL),"|",4)'="" WPCT=WPCT+1 F LLL=0:0 S LLL=$O(MSG(LL,LLL)) Q:'LLL  D
     174 .I $G(MSG(LL,LLL))'="" S WPARRAY(WORDP,WPCT)=$G(MSG(LL,LLL)),WPCT=WPCT+1
     175 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE2.m

    r613 r623  
    1 PSOHLNE2        ;BIR/RTR-Parsing out more OERR segments ;1/20/95
    2         ;;7.0;OUTPATIENT PHARMACY;**1,7,59,46,225**;DEC 1997;Build 29
    3         ;External reference to DG(40.8 supported by DBIA 728
    4         ;External reference to PS(50.606 supported by DBIA 2174
    5         ;External reference to PS(50.7 supported by DBIA 2223
    6         ;External reference to PSDRUG( supported by DBIA 221
    7         ;External reference to PS(55 supported by DBIA 2228
    8         ;External reference to SC( supported by DBIA 2675
    9         ;
    10 EN      ;RXO segment on new orders with multiple subscripts
    11         S (POVAR,POVAR1)="",(NNN,NNNN)=0,PSOIII=1,MSG(ZZ,0)=$E(MSG(ZZ),5,$L(MSG(ZZ)))
    12         S AAA="" F  S AAA=$O(MSG(ZZ,AAA)) Q:AAA=""  S NNN=0 F OOO=1:1:$L(MSG(ZZ,AAA)) S NNN=NNN+1 D  D:$G(POVAR1)="|" PARSE
    13         .I $E(MSG(ZZ,AAA),OOO)="|" S NNNN=NNNN+1
    14         .S POVAR1=$E(MSG(ZZ,AAA),OOO)
    15         .S POLIM=POVAR
    16         .S POVAR=$S(POVAR="":POVAR1,1:POVAR_POVAR1)
    17         I $G(POVAR)'="" I NNNN=13!(NNNN=12) S PSOREFIL=POVAR
    18         K MSG(ZZ,0)
    19         Q
    20 PARSE   ;
    21         I NNNN=1 S PSORDITE=$P(POLIM,"^",4) G SET
    22         I NNNN=10 S PSODDRUG=$P(POLIM,"^",4) I $G(PSODDRUG),('$D(^PSDRUG(PSODDRUG,0))) S PSODDRUG="" G SET
    23         I NNNN=10 G SET
    24         I NNNN=11 S PSOXQTY=POLIM G SET
    25         I NNNN=13 S PSOREFIL=POLIM G SET
    26         I NNNN=17 S PSODYSPL=POLIM
    27 SET     S (POVAR,POLIM)="" Q
    28         ;
    29 OBXX    ;Parse out OBX segments
    30         S OCOUNT=OCOUNT+1
    31         S (POVAR,POVAR)="",(NNCK,NNN,NNNN)=0,PSOIII=1,MSG(ZZ,0)=$E(MSG(ZZ),5,$L(MSG(ZZ)))
    32         S AAA="" F  S AAA=$O(MSG(ZZ,AAA)) Q:AAA=""  S NNN=0 F OOO=1:1:$L(MSG(ZZ,AAA)) S NNN=NNN+1 D  D:$G(POVAR1)="&"&(NNNN=4) OPARSE D:$G(POVAR1)="|" OPARSE
    33         .I $E(MSG(ZZ,AAA),OOO)="|" S NNNN=NNNN+1
    34         .S POVAR1=$E(MSG(ZZ,AAA),OOO)
    35         .S POLIM=POVAR
    36         .S POVAR=$S(POVAR="":POVAR1,1:POVAR_POVAR1)
    37         I $G(POVAR)'="" I NNNN=4!(NNNN=5) S NNCK=NNCK+1 S OBXAR(OCOUNT,NNCK)=POVAR
    38         K MSG(ZZ,0)
    39         F OOO=2:1 Q:'$D(OBXAR(OCOUNT,OOO))  S OBXAR(OCOUNT,1)=OBXAR(OCOUNT,1)_"&"_OBXAR(OCOUNT,OOO) K OBXAR(OCOUNT,OOO)
    40         Q
    41 OPARSE  ;
    42         I NNNN=4,$G(POVAR1)="&" S NNCK=NNCK+1,OBXAR(OCOUNT,NNCK)=$G(POLIM) G OSET
    43         I NNNN=5 S NNCK=NNCK+1 S OBXAR(OCOUNT,NNCK)=$G(POLIM)
    44 OSET    S (POVAR,POLIM)="" Q
    45         ;
    46 PURGE   ;Purge order initiated by CPRS
    47         N DA,PREER,PRG,PPG,PND,PRGFLAG,PURGCOMM,PEER,PURGPV1,PURGPID,PURGORC,PURGRX,PURGPLC,PRGSTAT,PSCC,PSARC,PSCA,PSACOUNT,PURGEXRX,PLAST,PURGLTH,PURGNODE
    48         S PSOMSORR=1
    49         S PRGFLAG=0
    50         ;S PURGRX=$O(^PSRX("APL",OR("PLACE"),0)) I PURGRX G PRX
    51         I $G(PSOFILNM),$G(PSOFILNM)'["S" S PURGRX=PSOFILNM G PRX
    52         S PND=+$G(PSOFILNM) I PND D  G PDNO
    53         .I '$D(^PS(52.41,PND,0)) Q
    54         .I $G(PDFN),$G(PDFN)'=$P($G(^PS(52.41,PND,0)),"^",2) S PURGCOMM="Patient does not match" D PDERR Q
    55         .S PRGSTAT=$P($G(^PS(52.41,PND,0)),"^",3) I PRGSTAT="NW"!(PRGSTAT="RNW")!(PRGSTAT="HD") S PRGFLAG=1 Q
    56         .K DIK S DA=PND,DIK="^PS(52.41," D ^DIK K DIK Q
    57         S PURGCOMM="Order was not located by Pharmacy."
    58         D PDERR G PDNO
    59 PDERR   D EN^ORERR(PURGCOMM,.MSG)
    60         Q
    61 PDNO    F PEER=0:0 S PEER=$O(MSG(PEER)) Q:'PEER  S:$P(MSG(PEER),"|")="PV1" PURGPV1=MSG(PEER) S:$P(MSG(PEER),"|")="PID" PURGPID=MSG(PEER) S:$P(MSG(PEER),"|")="ORC"&($G(PURGORC)="") PURGORC=MSG(PEER)
    62         N MSG,PSOHINST D INIT^PSOHLSN S MSG(2)=$G(PURGPID),MSG(3)=$G(PURGPV1),MSG(4)="ORC|"_$S($G(PRGFLAG):"ZU",1:"ZR")_"|"_$G(OR("PLACE"))_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PURGORC),"|",4)'="":$P(PURGORC,"|",4),1:"")
    63         F PREER=11,13 I $P($G(PURGORC),"|",PREER)'="" S $P(MSG(4),"|",PREER)=$P($G(PURGORC),"|",PREER)
    64         S $P(MSG(4),"|",17)="^^^^"_$S($G(PRGFLAG):"Unable to Purge order.",1:"OK to Purge order.")_"^"
    65         D SEND^PSOHLSN
    66 PURGEX  K PSOMSORR Q
    67 PRX     ;Purge from PSRX here
    68         I '$D(^PSRX(PURGRX,0)) G PDNO
    69         I $G(PDFN),$G(PDFN)'=$P($G(^PSRX(PURGRX,0)),"^",2) S PURGCOMM="Patient does not match" D PDERR G PDNO
    70         I '$P($G(^PSRX(PURGRX,"ARC")),"^") S PRGFLAG=1 G PDNO
    71         ;purge from PSRX
    72         S PURGEXRX=$P(^PSRX(PURGRX,0),"^")
    73         S PSOSUSPA=1 K DIK S DA=PURGRX,PSCC=$P($G(^PSRX(PURGRX,0)),"^",2),DIK="^PSRX(" D ^DIK K DIK,PSOSUSPA
    74         I $D(^PS(55,+$G(PSCC),0)) S DA(1)=PSCC,DIK="^PS(55,"_DA(1)_",""P""," F PSCA=0:0 S PSCA=$O(^PS(55,+$G(PSCC),"P",PSCA)) Q:'PSCA  I ^PS(55,+$G(PSCC),"P",PSCA,0)=PURGRX S DA=PSCA D ^DIK K DA,DIK
    75         I $D(^PS(52.4,PURGRX,0)) S DA=PURGRX,DIK="^PS(52.4," D ^DIK K DA,DIK
    76         S DA=$O(^PS(52.5,"B",PURGRX,"")) I DA S DIK="^PS(52.5," D ^DIK K DIK,DA
    77         I '$G(DT) S DT=$$DT^XLFDT
    78         I '$G(PSCC) G PUQUIT
    79         I '$D(^PS(55,PSCC,"ARC",DT)) S DA=PSCC,DIE=55,DR="101///"_DT,DR(2,55.13)="1///"_$G(PURGEXRX) D ^DIE K DIE G PUQUIT
    80         S PLAST=0 F PSARC=0:0 S PSARC=$O(^PS(55,PSCC,"ARC",DT,1,PSARC)) Q:'PSARC  S PLAST=PSARC
    81         I $G(PLAST),$D(^PS(55,PSCC,"ARC",DT,1,PLAST,0)) S PURGNODE=^PS(55,PSCC,"ARC",DT,1,PLAST,0) S PURGLTH=$L(PURGNODE) I $G(PURGLTH),PURGLTH<220 S ^PS(55,PSCC,"ARC",DT,1,PLAST,0)=PURGNODE_$S($E(PURGNODE,PURGLTH)'="*":"*",1:"")_PURGEXRX G PUQUIT
    82         S DA=PSCC,DIE=55,DR="101///"_DT,DR(2,55.13)="1///"_$G(PURGEXRX) D ^DIE K DIE
    83 PUQUIT  G PDNO
    84         ;
    85 REF     ;Refill request from CPRS
    86         N PSORXFL,PSORFX,REFXXX,REFCOM,REFCOMXX,REFEER,REFPV1,REFPID,REFORC,RREER,RFLOOP,REFSEG,RFTYPE,REFILLER,REFVR
    87         ;S PSOMSORR=1
    88         ;S PSORXFL=$O(^PSRX("APL",OR("PLACE"),0)) I PSORXFL G REFRX
    89         I $G(PSOFILNM),$G(PSOFILNM)'["S" S PSORXFL=PSOFILNM G REFRX
    90         I $G(PSOFILNM) S PSORFX=+$G(PSOFILNM) D  S REFXXX=1 G REFSND
    91         .I '$D(^PS(52.41,PSORFX,0)) S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR Q
    92         .I $G(PDFN),$G(PDFN)'=$P($G(^PS(52.41,PSORFX,0)),"^",2) S (REFCOMXX,REFCOM)="Patient does not match." D REFERR Q
    93         .I $P($G(^PS(52.41,PSORFX,0)),"^",3)="RF" S REFCOM="Refill has already been requested." Q
    94         .S REFCOM="Refill request not allowed on Pending order."
    95         S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR S REFXXX=1 G REFSND
    96 REFERR  D EN^ORERR(REFCOMXX,.MSG)
    97         Q
    98 REFSND  ;REBUILD AND SEND MESSAGE  REFXXX IS VARIABL, REFCOM IS COMMENT
    99         ;F REFEER=0:0 S REFEER=$O(MSG(REFEER)) Q:'REFEER  S:$P(MSG(REFEER),"|")="PV1" REFPV1=MSG(REFEER) S:$P(MSG(REFEER),"|")="PID" REFPID=MSG(REFEER) S:$P(MSG(REFEER),"|")="ORC"&($G(REFORC)="") REFORC=MSG(REFEER)
    100         ;N MSG,PSOHINST D INIT^PSOHLSN S MSG(2)=$G(REFPID),MSG(3)=$G(REFPV1),MSG(4)="ORC|"_$S($G(REFXXX):"UF",1:"FL")_"|"_$G(OR("PLACE"))_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(REFORC),"|",4)'="":$P(REFORC,"|",4),1:"")
    101         ;use commented out code if response message is ever required
    102         ;F RREER=11,13 I $P($G(REFORC),"|",RREER)'="" S $P(MSG(4),"|",RREER)=$P($G(REFORC),"|",RREER)
    103         ;S $P(MSG(4),"|",17)="^^^^"_$S($G(REFXXX):$G(REFCOM),1:"Refill request sent to Pharmacy.")_"^"
    104         ;D SEND^PSOHLSN
    105 REFSNDX ;K PSOMSORR
    106         Q
    107 REFRX   ;
    108         I $O(^PS(52.41,"ARF",PSORXFL,0)) S REFXXX=1,REFCOM="Refill request already exists." G REFSND
    109         I '$D(^PSRX(PSORXFL,0)) S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR S REFXXX=1 G REFSND
    110         I $G(PDFN),$G(PDFN)'=$P($G(^PSRX(PSORXFL,0)),"^",2) S (REFCOMXX,REFCOM)="Patient does not match." D REFERR S REFXXX=1 G REFSND
    111         ;S REFVR=$$REFILL^PSOREF(OR("PLACE")) I $P($G(REFVR),"^")'=1 S REFXXX=1,REFCOM=$P($G(REFVR),"^",2) G REFSND
    112         F RFLOOP=0:0 S RFLOOP=$O(MSG(RFLOOP)) Q:'RFLOOP  S REFSEG=$G(MSG(RFLOOP)),RFTYPE=$P(REFSEG,"|")_"Z" S REFSEG=$E(REFSEG,5,$L(REFSEG)) I RFTYPE="PIDZ"!(RFTYPE="PV1Z")!(RFTYPE="ORCZ")!(RFTYPE="ZRXZ") D @RFTYPE
    113         I '$G(PLACER) S REFXXX=1,REFCOM="Unable to process refill request." G REFSND
    114         I $G(REFILLER),$G(REFILLER)'=$G(PSORXFL) S REFCOMXX="Filler number mismatch" D REFERR S REFXXX=1,REFCOM="Unable to process refill request." G REFSND
    115         K DD,DO S DIC="^PS(52.41,",DIC(0)="L",X=PLACER,DIC("DR")="1////"_$G(DFN)_";2////"_"RF"_";4////"_$G(ENTERED)_";5////"_$G(PROV) D FILE^DICN K DIC,DR I Y<0 S REFXXX=1,REFCOM="Unable to process refill request." G REFSND
    116         S PENDING=+Y S $P(^PS(52.41,PENDING,0),"^",13)=$G(LOCATION),$P(^(0),"^",17)=$S($G(ROUTING)'="":$G(ROUTING),1:"W"),$P(^(0),"^",19)=$G(PSORXFL),$P(^(0),"^",20)="F",$P(^(0),"^",14)="R"
    117         S $P(^PS(52.41,PENDING,0),"^",8)=$P($G(^PSRX(PSORXFL,"OR1")),"^"),$P(^PS(52.41,PENDING,0),"^",9)=$P($G(^PSRX(PSORXFL,0)),"^",6)
    118         S $P(^PS(52.41,PENDING,"INI"),"^")=$G(PSINPTR) D NOW^%DTC S $P(^PS(52.41,PENDING,0),"^",12)=% K %
    119         K DIK S DA=PENDING,DIK="^PS(52.41," D IX1^DIK K DIK
    120         G REFSND
    121 PIDZ    ;
    122         S DFN=+$P(REFSEG,"|",3)
    123         Q
    124 PV1Z    ;
    125         S LOCATION=+$P(+$P(REFSEG,"|",3),"^")
    126         S:'$D(^SC(LOCATION,0)) LOCATION=""
    127         S INPTRX=0 I $G(LOCATION) S PSINPTR=$P($G(^SC(LOCATION,0)),"^",4) I PSINPTR Q
    128         I $G(LOCATION) S INPTRX=$P($G(^SC(LOCATION,0)),"^",15)
    129         I '$G(INPTRX) S INPTRX=$O(^DG(40.8,0))
    130         I '$G(DT) S DT=$$DT^XLFDT
    131         S PSINPTR=+$$SITE^VASITE(DT,INPTRX)
    132         Q
    133 ORCZ    ;
    134         S PLACER=+$P(REFSEG,"|",2),REFILLER=+$P(REFSEG,"|",3),ENTERED=+$P(REFSEG,"|",10),PROV=+$P(REFSEG,"|",12)
    135         Q
    136 ZRXZ    ;
    137         S ROUTING=$P(REFSEG,"|",4)
    138         Q
    139 STUFF   ;
    140         S PSOVRBD=$P($G(^PS(50.7,+$G(PSORDITE),0)),"^",2)
    141         I '$G(PSOVRBD) K PSOVRBD Q
    142         ;K PSONUNN F PSONUN=0:0 S PSONUN=$O(^PS(50.606,PSOVRBD,"NOUN",PSONUN)) Q:'PSONUN!($D(PSONUNN))  S:$P($G(^(PSONUN,0)),"^")'="" PSONUNN=$P($G(^(0)),"^")
    143         S PSOVRB=$P($G(^PS(50.606,PSOVRBD,"MISC")),"^")
    144         F EE=0:0 S EE=$O(^PS(52.41,PENDING,1,EE)) Q:'EE  S $P(^PS(52.41,PENDING,1,EE,1),"^",10)=$$UNESC^ORHLESC($G(PSOVRB))
    145         K PSOVRBD,PSONUNN,PSONUN,PSOVRB
    146         Q
     1PSOHLNE2 ;BIR/RTR-Parsing out more OERR segments ; 1/20/95
     2 ;;7.0;OUTPATIENT PHARMACY;**1,7,59,46**;DEC 1997
     3 ;External reference to DG(40.8 supported by DBIA 728
     4 ;External reference to PS(50.606 supported by DBIA 2174
     5 ;External reference to PS(50.7 supported by DBIA 2223
     6 ;External reference to PSDRUG( supported by DBIA 221
     7 ;External reference to PS(55 supported by DBIA 2228
     8 ;External reference to SC( supported by DBIA 2675
     9 ;
     10EN ;RXO segment on new orders with multiple subscripts
     11 S (POVAR,POVAR1)="",(NNN,NNNN)=0,PSOIII=1,MSG(ZZ,0)=$E(MSG(ZZ),5,$L(MSG(ZZ)))
     12 S AAA="" F  S AAA=$O(MSG(ZZ,AAA)) Q:AAA=""  S NNN=0 F OOO=1:1:$L(MSG(ZZ,AAA)) S NNN=NNN+1 D  D:$G(POVAR1)="|" PARSE
     13 .I $E(MSG(ZZ,AAA),OOO)="|" S NNNN=NNNN+1
     14 .S POVAR1=$E(MSG(ZZ,AAA),OOO)
     15 .S POLIM=POVAR
     16 .S POVAR=$S(POVAR="":POVAR1,1:POVAR_POVAR1)
     17 I $G(POVAR)'="" I NNNN=13!(NNNN=12) S PSOREFIL=POVAR
     18 K MSG(ZZ,0)
     19 Q
     20PARSE ;
     21 I NNNN=1 S PSORDITE=$P(POLIM,"^",4) G SET
     22 I NNNN=10 S PSODDRUG=$P(POLIM,"^",4) I $G(PSODDRUG),('$D(^PSDRUG(PSODDRUG,0))) S PSODDRUG="" G SET
     23 I NNNN=10 G SET
     24 I NNNN=11 S PSOXQTY=POLIM G SET
     25 I NNNN=13 S PSOREFIL=POLIM G SET
     26 I NNNN=17 S PSODYSPL=POLIM
     27SET S (POVAR,POLIM)="" Q
     28 ;
     29OBXX ;Parse out OBX segments
     30 S OCOUNT=OCOUNT+1
     31 S (POVAR,POVAR)="",(NNCK,NNN,NNNN)=0,PSOIII=1,MSG(ZZ,0)=$E(MSG(ZZ),5,$L(MSG(ZZ)))
     32 S AAA="" F  S AAA=$O(MSG(ZZ,AAA)) Q:AAA=""  S NNN=0 F OOO=1:1:$L(MSG(ZZ,AAA)) S NNN=NNN+1 D  D:$G(POVAR1)="&"&(NNNN=4) OPARSE D:$G(POVAR1)="|" OPARSE
     33 .I $E(MSG(ZZ,AAA),OOO)="|" S NNNN=NNNN+1
     34 .S POVAR1=$E(MSG(ZZ,AAA),OOO)
     35 .S POLIM=POVAR
     36 .S POVAR=$S(POVAR="":POVAR1,1:POVAR_POVAR1)
     37 I $G(POVAR)'="" I NNNN=4!(NNNN=5) S NNCK=NNCK+1 S OBXAR(OCOUNT,NNCK)=POVAR
     38 K MSG(ZZ,0)
     39 F OOO=2:1 Q:'$D(OBXAR(OCOUNT,OOO))  S OBXAR(OCOUNT,1)=OBXAR(OCOUNT,1)_"&"_OBXAR(OCOUNT,OOO) K OBXAR(OCOUNT,OOO)
     40 Q
     41OPARSE ;
     42 I NNNN=4,$G(POVAR1)="&" S NNCK=NNCK+1,OBXAR(OCOUNT,NNCK)=$G(POLIM) G OSET
     43 I NNNN=5 S NNCK=NNCK+1 S OBXAR(OCOUNT,NNCK)=$G(POLIM)
     44OSET S (POVAR,POLIM)="" Q
     45 ;
     46PURGE ;Purge order initiated by CPRS
     47 N DA,PREER,PRG,PPG,PND,PRGFLAG,PURGCOMM,PEER,PURGPV1,PURGPID,PURGORC,PURGRX,PURGPLC,PRGSTAT,PSCC,PSARC,PSCA,PSACOUNT,PURGEXRX,PLAST,PURGLTH,PURGNODE
     48 S PSOMSORR=1
     49 S PRGFLAG=0
     50 ;S PURGRX=$O(^PSRX("APL",OR("PLACE"),0)) I PURGRX G PRX
     51 I $G(PSOFILNM),$G(PSOFILNM)'["S" S PURGRX=PSOFILNM G PRX
     52 S PND=+$G(PSOFILNM) I PND D  G PDNO
     53 .I '$D(^PS(52.41,PND,0)) Q
     54 .I $G(PDFN),$G(PDFN)'=$P($G(^PS(52.41,PND,0)),"^",2) S PURGCOMM="Patient does not match" D PDERR Q
     55 .S PRGSTAT=$P($G(^PS(52.41,PND,0)),"^",3) I PRGSTAT="NW"!(PRGSTAT="RNW")!(PRGSTAT="HD") S PRGFLAG=1 Q
     56 .K DIK S DA=PND,DIK="^PS(52.41," D ^DIK K DIK Q
     57 S PURGCOMM="Order was not located by Pharmacy."
     58 D PDERR G PDNO
     59PDERR D EN^ORERR(PURGCOMM,.MSG)
     60 Q
     61PDNO F PEER=0:0 S PEER=$O(MSG(PEER)) Q:'PEER  S:$P(MSG(PEER),"|")="PV1" PURGPV1=MSG(PEER) S:$P(MSG(PEER),"|")="PID" PURGPID=MSG(PEER) S:$P(MSG(PEER),"|")="ORC"&($G(PURGORC)="") PURGORC=MSG(PEER)
     62 N MSG,PSOHINST D INIT^PSOHLSN S MSG(2)=$G(PURGPID),MSG(3)=$G(PURGPV1),MSG(4)="ORC|"_$S($G(PRGFLAG):"ZU",1:"ZR")_"|"_$G(OR("PLACE"))_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PURGORC),"|",4)'="":$P(PURGORC,"|",4),1:"")
     63 F PREER=11,13 I $P($G(PURGORC),"|",PREER)'="" S $P(MSG(4),"|",PREER)=$P($G(PURGORC),"|",PREER)
     64 S $P(MSG(4),"|",17)="^^^^"_$S($G(PRGFLAG):"Unable to Purge order.",1:"OK to Purge order.")_"^"
     65 D SEND^PSOHLSN
     66PURGEX K PSOMSORR Q
     67PRX ;Purge from PSRX here
     68 I '$D(^PSRX(PURGRX,0)) G PDNO
     69 I $G(PDFN),$G(PDFN)'=$P($G(^PSRX(PURGRX,0)),"^",2) S PURGCOMM="Patient does not match" D PDERR G PDNO
     70 I '$P($G(^PSRX(PURGRX,"ARC")),"^") S PRGFLAG=1 G PDNO
     71 ;purge from PSRX
     72 S PURGEXRX=$P(^PSRX(PURGRX,0),"^")
     73 S PSOSUSPA=1 K DIK S DA=PURGRX,PSCC=$P($G(^PSRX(PURGRX,0)),"^",2),DIK="^PSRX(" D ^DIK K DIK,PSOSUSPA
     74 I $D(^PS(55,+$G(PSCC),0)) S DA(1)=PSCC,DIK="^PS(55,"_DA(1)_",""P""," F PSCA=0:0 S PSCA=$O(^PS(55,+$G(PSCC),"P",PSCA)) Q:'PSCA  I ^PS(55,+$G(PSCC),"P",PSCA,0)=PURGRX S DA=PSCA D ^DIK K DA,DIK
     75 I $D(^PS(52.4,PURGRX,0)) S DA=PURGRX,DIK="^PS(52.4," D ^DIK K DA,DIK
     76 S DA=$O(^PS(52.5,"B",PURGRX,"")) I DA S DIK="^PS(52.5," D ^DIK K DIK,DA
     77 I '$G(DT) S DT=$$DT^XLFDT
     78 I '$G(PSCC) G PUQUIT
     79 I '$D(^PS(55,PSCC,"ARC",DT)) S DA=PSCC,DIE=55,DR="101///"_DT,DR(2,55.13)="1///"_$G(PURGEXRX) D ^DIE K DIE G PUQUIT
     80 S PLAST=0 F PSARC=0:0 S PSARC=$O(^PS(55,PSCC,"ARC",DT,1,PSARC)) Q:'PSARC  S PLAST=PSARC
     81 I $G(PLAST),$D(^PS(55,PSCC,"ARC",DT,1,PLAST,0)) S PURGNODE=^PS(55,PSCC,"ARC",DT,1,PLAST,0) S PURGLTH=$L(PURGNODE) I $G(PURGLTH),PURGLTH<220 S ^PS(55,PSCC,"ARC",DT,1,PLAST,0)=PURGNODE_$S($E(PURGNODE,PURGLTH)'="*":"*",1:"")_PURGEXRX G PUQUIT
     82 S DA=PSCC,DIE=55,DR="101///"_DT,DR(2,55.13)="1///"_$G(PURGEXRX) D ^DIE K DIE
     83PUQUIT G PDNO
     84 ;
     85REF ;Refill request from CPRS
     86 N PSORXFL,PSORFX,REFXXX,REFCOM,REFCOMXX,REFEER,REFPV1,REFPID,REFORC,RREER,RFLOOP,REFSEG,RFTYPE,REFILLER,REFVR
     87 ;S PSOMSORR=1
     88 ;S PSORXFL=$O(^PSRX("APL",OR("PLACE"),0)) I PSORXFL G REFRX
     89 I $G(PSOFILNM),$G(PSOFILNM)'["S" S PSORXFL=PSOFILNM G REFRX
     90 I $G(PSOFILNM) S PSORFX=+$G(PSOFILNM) D  S REFXXX=1 G REFSND
     91 .I '$D(^PS(52.41,PSORFX,0)) S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR Q
     92 .I $G(PDFN),$G(PDFN)'=$P($G(^PS(52.41,PSORFX,0)),"^",2) S (REFCOMXX,REFCOM)="Patient does not match." D REFERR Q
     93 .I $P($G(^PS(52.41,PSORFX,0)),"^",3)="RF" S REFCOM="Refill has already been requested." Q
     94 .S REFCOM="Refill request not allowed on Pending order."
     95 S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR S REFXXX=1 G REFSND
     96REFERR D EN^ORERR(REFCOMXX,.MSG)
     97 Q
     98REFSND ;REBUILD AND SEND MESSAGE  REFXXX IS VARIABL, REFCOM IS COMMENT
     99 ;F REFEER=0:0 S REFEER=$O(MSG(REFEER)) Q:'REFEER  S:$P(MSG(REFEER),"|")="PV1" REFPV1=MSG(REFEER) S:$P(MSG(REFEER),"|")="PID" REFPID=MSG(REFEER) S:$P(MSG(REFEER),"|")="ORC"&($G(REFORC)="") REFORC=MSG(REFEER)
     100 ;N MSG,PSOHINST D INIT^PSOHLSN S MSG(2)=$G(REFPID),MSG(3)=$G(REFPV1),MSG(4)="ORC|"_$S($G(REFXXX):"UF",1:"FL")_"|"_$G(OR("PLACE"))_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(REFORC),"|",4)'="":$P(REFORC,"|",4),1:"")
     101 ;use commented out code if response message is ever required
     102 ;F RREER=11,13 I $P($G(REFORC),"|",RREER)'="" S $P(MSG(4),"|",RREER)=$P($G(REFORC),"|",RREER)
     103 ;S $P(MSG(4),"|",17)="^^^^"_$S($G(REFXXX):$G(REFCOM),1:"Refill request sent to Pharmacy.")_"^"
     104 ;D SEND^PSOHLSN
     105REFSNDX ;K PSOMSORR
     106 Q
     107REFRX ;
     108 I $O(^PS(52.41,"ARF",PSORXFL,0)) S REFXXX=1,REFCOM="Refill request already exists." G REFSND
     109 I '$D(^PSRX(PSORXFL,0)) S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR S REFXXX=1 G REFSND
     110 I $G(PDFN),$G(PDFN)'=$P($G(^PSRX(PSORXFL,0)),"^",2) S (REFCOMXX,REFCOM)="Patient does not match." D REFERR S REFXXX=1 G REFSND
     111 ;S REFVR=$$REFILL^PSOREF(OR("PLACE")) I $P($G(REFVR),"^")'=1 S REFXXX=1,REFCOM=$P($G(REFVR),"^",2) G REFSND
     112 F RFLOOP=0:0 S RFLOOP=$O(MSG(RFLOOP)) Q:'RFLOOP  S REFSEG=$G(MSG(RFLOOP)),RFTYPE=$P(REFSEG,"|")_"Z" S REFSEG=$E(REFSEG,5,$L(REFSEG)) I RFTYPE="PIDZ"!(RFTYPE="PV1Z")!(RFTYPE="ORCZ")!(RFTYPE="ZRXZ") D @RFTYPE
     113 I '$G(PLACER) S REFXXX=1,REFCOM="Unable to process refill request." G REFSND
     114 I $G(REFILLER),$G(REFILLER)'=$G(PSORXFL) S REFCOMXX="Filler number mismatch" D REFERR S REFXXX=1,REFCOM="Unable to process refill request." G REFSND
     115 K DD,DO S DIC="^PS(52.41,",DIC(0)="L",X=PLACER,DIC("DR")="1////"_$G(DFN)_";2////"_"RF"_";4////"_$G(ENTERED)_";5////"_$G(PROV) D FILE^DICN K DIC,DR I Y<0 S REFXXX=1,REFCOM="Unable to process refill request." G REFSND
     116 S PENDING=+Y S $P(^PS(52.41,PENDING,0),"^",13)=$G(LOCATION),$P(^(0),"^",17)=$S($G(ROUTING)'="":$G(ROUTING),1:"W"),$P(^(0),"^",19)=$G(PSORXFL),$P(^(0),"^",20)="F",$P(^(0),"^",14)="R"
     117 S $P(^PS(52.41,PENDING,0),"^",8)=$P($G(^PSRX(PSORXFL,"OR1")),"^"),$P(^PS(52.41,PENDING,0),"^",9)=$P($G(^PSRX(PSORXFL,0)),"^",6)
     118 S $P(^PS(52.41,PENDING,"INI"),"^")=$G(PSINPTR) D NOW^%DTC S $P(^PS(52.41,PENDING,0),"^",12)=% K %
     119 K DIK S DA=PENDING,DIK="^PS(52.41," D IX1^DIK K DIK
     120 G REFSND
     121PIDZ ;
     122 S DFN=+$P(REFSEG,"|",3)
     123 Q
     124PV1Z ;
     125 S LOCATION=+$P(+$P(REFSEG,"|",3),"^")
     126 S:'$D(^SC(LOCATION,0)) LOCATION=""
     127 S INPTRX=0 I $G(LOCATION) S PSINPTR=$P($G(^SC(LOCATION,0)),"^",4) I PSINPTR Q
     128 I $G(LOCATION) S INPTRX=$P($G(^SC(LOCATION,0)),"^",15)
     129 I '$G(INPTRX) S INPTRX=$O(^DG(40.8,0))
     130 I '$G(DT) S DT=$$DT^XLFDT
     131 S PSINPTR=+$$SITE^VASITE(DT,INPTRX)
     132 Q
     133ORCZ ;
     134 S PLACER=+$P(REFSEG,"|",2),REFILLER=+$P(REFSEG,"|",3),ENTERED=+$P(REFSEG,"|",10),PROV=+$P(REFSEG,"|",12)
     135 Q
     136ZRXZ ;
     137 S ROUTING=$P(REFSEG,"|",4)
     138 Q
     139STUFF ;
     140 S PSOVRBD=$P($G(^PS(50.7,+$G(PSORDITE),0)),"^",2)
     141 I '$G(PSOVRBD) K PSOVRBD Q
     142 ;K PSONUNN F PSONUN=0:0 S PSONUN=$O(^PS(50.606,PSOVRBD,"NOUN",PSONUN)) Q:'PSONUN!($D(PSONUNN))  S:$P($G(^(PSONUN,0)),"^")'="" PSONUNN=$P($G(^(0)),"^")
     143 S PSOVRB=$P($G(^PS(50.606,PSOVRBD,"MISC")),"^")
     144 F EE=0:0 S EE=$O(^PS(52.41,PENDING,1,EE)) Q:'EE  S $P(^PS(52.41,PENDING,1,EE,1),"^",10)=$G(PSOVRB)
     145 K PSOVRBD,PSONUNN,PSONUN,PSOVRB
     146 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE3.m

    r613 r623  
    1 PSOHLNE3        ;BIR/LE - Process Edit Information from CPRS ;02/27/04
    2         ;;7.0;OUTPATIENT PHARMACY;**143,239,201,225**;DEC 1997;Build 29
    3         ;External reference to ^OR(100 private DBIA 2219
    4         ;External reference VADPT supported by DBIA 10061
    5         ;
    6         ;This API is used to update the prescription file when ICD-9 diagnosis and SC/EI's are updated as a result of an e-sig in CPRS. 
    7         ;
    8 EN(DFN,ORITEM,ORIEN,ORDX,ORSCEI)        ;ENTRY POINT
    9         ;     Used to import edit information from CPRS
    10         ;Where Input:
    11         ;DFN = Patient IEN
    12         ;ORITEM = Package reference number from file 100
    13         ;ORIEN = ien from file 100
    14         ;ORDX(1)= (pointer to file 80) up to 8 accepted and first is primary ICD
    15         ;ORDX(2)= (pointer to file 80)
    16         ;ORSCEI=  seven pieces - where 1=yes, 0=no, null or ? =not asked
    17         ;  ORSCEI=AO^IR^SC^EC^MST^HNC^CV^SHAD
    18         N %,DX,DX2,DX3,RXN,PSOSCP,PSOX,ORDPROV,PSOSCP2,DA,RET,PSOANSQ,PSORX,PTSTATUS,ARRAY,PSOOI,ORITEM2,ORID,OICHK,PSORENW
    19         N PSODCPY,PSONEW,PSOOIBQ,PSOFLD,PSODCZ,PSOSTAZ,PREA,PSOPIBQ,PSOIBQC,PSOSCA,PSOPICD,PSODGUP,PSOOICD,PSOPFS,TYPE,PSONW,PSOOLD,PSODA
    20         N PSODD,PSOSI,X,PSOSITE,PSOBILL,PSOCPAY,PSOCICD
    21         S:'$D(ORIEN) ORIEN="" S:'$D(ORSCEI) ORSCEI="" S:'$D(ORITEM) ORITEM=""
    22         ;
    23         ;validate prescription IEN with DFN, ord item, and placer#
    24         S RET=1,PSODCZ=",12,14,15,"
    25         S RXN=ORITEM I '$D(^PSRX(RXN)) S RET="0^1" Q RET  ;invalid RX ien
    26         I $D(^PSRX(RXN,"STA")) S PSOSTAZ=^PSRX(RXN,"STA")
    27         ; get prescription file patient ien, drug, and placer order #
    28         D GETS^DIQ(52,RXN_",","2;6;39.3","I","ARRAY")
    29         I '$D(ARRAY(52,RXN_",",2,"I")) S RET="0^3" Q RET  ;quit if you don't have a patient ien
    30         I ARRAY(52,RXN_",",2,"I")'=DFN S RET="0^3" Q RET  ;quit if patient dfn is different
    31         I '$D(ARRAY(52,RXN_",",39.3,"I")) S ARRAY(52,RXN_",",39.3,"I")=""  ;if don't have it; treat is as null
    32         I ARRAY(52,RXN_",",39.3,"I")'="" I ARRAY(52,RXN_",",39.3,"I")'=ORIEN S RET="0^5" Q RET  ;placer # is different
    33         I ARRAY(52,RXN_",",39.3,"I")="" S OICHK=0 D CHKOI I OICHK S RET="0^4" Q RET  ;quit if placer # is null and orderable item is different or null.
    34         ;end of validation process
    35         ;
    36         S PSODD=$$GET1^DIQ(52,RXN_",",6,"I") S:($P($G(^PSDRUG(PSODD,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") PSOSI=1
    37         S PSOPIBQ=$G(^PSRX(RXN,"IBQ")),PSOPICD=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,8)
    38         S PSOX("IRXN")=RXN,PSORENW("IRXN")=RXN
    39         S (PSONEW("PATIENT STATUS"),PTSTATUS)=$$GET1^DIQ(52,RXN_",","3","I")
    40         I '$D(PTSTATUS) S (PSONEW("PATIENT STATUS"),PTSTATUS)=""
    41         ;if patient status is null, treat same as PSONEW2, PSORN52, PSONEWG, AND PSONEWF.  If piece 7 of ^PS(53 doesn't equal 1, it's not exempt from copay.
    42         I ORSCEI["?" S ORSCEI=$TR(ORSCEI,"?","")
    43         D SCP^PSORN52D
    44         S PSOANSQ(PSOX("IRXN"),"VEH")=$P(ORSCEI,U,1)
    45         S PSOANSQ(PSOX("IRXN"),"RAD")=$P(ORSCEI,U,2)
    46         I PSOSCP<50&($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1) S PSOANSQ(PSOX("IRXN"),"SC")=$P(ORSCEI,U,3),PSOANSQ("SC")=$P(ORSCEI,U,3)
    47         I PSOSCP>49!($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)=1) S PSOANSQ(PSOX("IRXN"),"SC>50")=$P(ORSCEI,U,3),PSOANSQ("SC>50")=$P(ORSCEI,U,3)
    48         I PSOSCP=""&('$D(PSOANSQ("SC")))&($D(^PSRX(RXN,"ICD",1))) S PSOANSQ("SC")=$P(^PSRX(RXN,"ICD",1,0),"^",4),PSOANSQ(PSOX("IRXN"),"SC")=PSOANSQ("SC")  ;for SC with no percentage defined/ legacy
    49         S PSOANSQ(PSOX("IRXN"),"PGW")=$P(ORSCEI,U,4)
    50         S PSOANSQ(PSOX("IRXN"),"MST")=$P(ORSCEI,U,5)
    51         S PSOANSQ(PSOX("IRXN"),"HNC")=$P(ORSCEI,U,6)
    52         S PSOANSQ(PSOX("IRXN"),"CV")=$P(ORSCEI,U,7)
    53         S PSOANSQ(PSOX("IRXN"),"SHAD")=$P(ORSCEI,U,8)
    54         D:'$$PATCH^XPDUTL("OR*3.0*243") SHAD^PSORN52D
    55         S DX="",DX2=0 F  S DX=$O(ORDX(DX)) Q:DX=""  S DX2=DX2+1,PSORX("ICD",DX2)=ORDX(DX)  ;Multi signed Rx's come in consecutively and the diagnosis subscript doesn't start with 1 for each Rx
    56         S PSOSCP2=1  ;used in PSORN52D
    57         ;
    58 ICD2    ;Check to see if SC/EI changed during CPRS sign order
    59         D GETS^DIQ(52,PSOX("IRXN")_",","52311*","I","PSOOICD")
    60         S PSODCPY=0,PSOFLD=""
    61         F TYPE="VEH","RAD","SC>50","PGW","MST","HNC","CV","SHAD" Q:PSODCPY  F PSOFLD=1:1:8 D  Q:PSODCPY
    62         . I TYPE="VEH"&(PSOFLD=1) D CHOC
    63         . I TYPE="RAD"&(PSOFLD=2) D CHOC
    64         . I TYPE="SC>50"&(PSOFLD=3)&($D(PSOANSQ(PSOX("IRXN"),TYPE))) D CHOC
    65         . I TYPE="PGW"&(PSOFLD=4) D CHOC
    66         . I TYPE="MST"&(PSOFLD=5) D CHOC
    67         . I TYPE="HNC"&(PSOFLD=6) D CHOC
    68         . I TYPE="CV"&(PSOFLD=7) D CHOC
    69         . I TYPE="SHAD"&(PSOFLD=8) D:$$PATCH^XPDUTL("OR*3.0*243") CHOC
    70         I $D(PSOANSQ("SC")) S PSOFLD=3 S:PSOANSQ("SC")'=PSOOICD(52.052311,1_","_PSOX("IRXN")_",",PSOFLD,"I") PSODCPY=1,PSOFLD=""
    71         ; IF NO SC/EI DIFFERENCES, CHECK FOR ICD CHANGES.  If there were SC/EI difference, don't need to check ICD because they are sent anyway when copay update is done.
    72         I '$G(PSODCPY) D
    73         .I '$D(PSORX("ICD"))&($G(PSOOICD(52.052311,1_","_RXN_",",.01,"I"))) S PSODGUP=1 Q  ;if no ICD's passed and ICD's defined in 52, CPRS overrides OP
    74         .S (DX3,DX2,DX)="" F  S DX=$O(PSOOICD(52.052311,DX)) Q:DX=""  S DX2=+DX  ;get last entry for file 52
    75         .S DX="" F  S DX=$O(PSORX("ICD",DX)) Q:DX=""  S DX3=DX D  ;get last entry for new ICD's from CPRS
    76         .. I $G(PSOOICD(52.052311,DX_","_PSOX("IRXN")_",",.01,"I"))'=PSORX("ICD",DX) S PSODGUP=1  ;if ICD'S changed or more new ICD's than old ones.
    77         .I DX2>DX3 S PSODGUP=1  ;if more old ICD's than new ones
    78         Q:'$G(PSODCPY)&('$G(PSODGUP)) 1
    79         D FILE2^PSORN52D  ;file SC/EI/ICD'S into Rx file
    80         ;S PSOCIDC=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,8)
    81         ;only do copay if SC/EI changed and SC is less than 50%.
    82         I PSODCZ[(","_$G(PSOSTAZ)_",") S RET="0^6" Q RET  ;discontinue's no copay changes allowed.
    83         ;
    84         ;Get last fill number
    85         N PSOLFIL S PSOLFIL=$$LF^PSOPFSU1(RXN)
    86         S PSOPFS=$P($S('PSOLFIL:$G(^PSRX(RXN,"PFS")),1:$G(^PSRX(RXN,1,PSOLFIL,"PFS"))),"^",1,2)
    87         ; No-copay to copay updates
    88         S PSOIBQC=$G(^PSRX(RXN,"IBQ")),PSOCICD=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,8)
    89         D CPAY
    90         ; must check IBQ node in case it's a pre-CIDC rx/copay, ICD node for exempt/supply items, and for diagnosis updates for NSC Rx's
    91         I (PSOPIBQ[1&(PSOIBQC'[1))!(PSOIBQC=""&(PSOPICD[1&(PSOCICD'[1)))!($G(PSODGUP)) D  Q RET  ;don't do no copay to copay bills, but update status
    92         . D ALOG
    93         . I (PSOSCP<50)&($G(PSODCPY)) D
    94         .. I $P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1&('$G(PSOSI)) D
    95         ... S:+$G(PSOCPAY)<1&($D(^PSRX(RXN,"IB"))) $P(^PSRX(RXN,"IB"),"^",1)=""
    96         ... I +$G(PSOCPAY)>0 S $P(^PSRX(RXN,"IB"),"^",1)=+$G(PSOCPAY),PSOOLD="No Copay",PSONW="Copay",PREA="R",PSODA=RXN D:'$G(PSOSI) ACTLOG^PSOCPA
    97         . I +$G(PSOPFS)>0&('$P($G(PSOPFS),"^",2)) K PSOPFS Q   ;don't send unreleased charge msg
    98         . I +$G(PSOPFS)<1 K PSOPFS  ;invalid PFSS ACCT REF/ SEND TO IB
    99         . I +$G(PSOPFS)>0 S PSOPFS="1^"_PSOPFS
    100         . ;
    101         . I +$G(PSOPFS) D CHRG^PSOPFSU1(RXN,PSOLFIL,"CG",PSOPFS) ;always send to external bill sys
    102         ;
    103         ; Copay to no-copay updates
    104         I $G(PSODCPY) D COPAY^PSOHLNE4
    105         ;ICD UPDATE ONLY FOR COPAYS
    106         I ('$G(PSODCPY)&($G(PSODGUP)))&($P($G(PSOPFS),"^",2)) D CHRG^PSOPFSU1(RXN,PSOLFIL,"CG",PSOPFS) ;DIAGNOSIS UPDATE ONLY
    107         I ($G(PSODCPY)!($G(PSODGUP))) D ALOG
    108         Q RET
    109         ;
    110 CPAY    ;
    111         N X,Y,III,ACTYP,BL
    112         S PSOSITE=$P(^PSRX(RXN,2),"^",9)
    113         S X=$P($G(^PS(59,+PSOSITE,"IB")),"^")_"^"_DFN D XTYPE^IBARX
    114         S (ACTYP,BL)="",(PSOBILL,PSOCPAY)=0
    115 CPAY1   ;
    116         S ACTYP=$O(Y(ACTYP)) G:'ACTYP CSKP F III=0:0 S BL=$O(Y(ACTYP,BL)) Q:BL=""  I BL>0 S PSOBILL=BL,PSOCPAY=BL_"^"_Y(ACTYP,BL)
    117         G CPAY1
    118 CSKP    ;
    119         S:$G(PSOSI) PSOCPAY=0  ;Supply item/investigational drug
    120         S:$P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)=1 PSOCPAY=0  ;Rx Patient Status exempt
    121         I PSOIBQC'="" S:PSOIBQC'[1 PSOCPAY=1  ;Yes SC/EI from CPRS
    122         I (PSOBILL'>0)!(PSOCPAY=0) S PSOCPAY=0  ;INELIGIBLE
    123         Q
    124         ;
    125 CHOC    ;check outpatient classifications
    126         S:PSOANSQ(PSOX("IRXN"),TYPE)'=PSOOICD(52.052311,1_","_PSOX("IRXN")_",",PSOFLD,"I") PSODCPY=1
    127         Q
    128         ;
    129 ALOG    ;set activity log with edit info from cprs
    130         N ACNT,SUB,RF,RFCNT
    131         S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(RXN,"A",SUB)) Q:'SUB  S ACNT=SUB
    132         S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF  S RFCNT=RF S:RF>5 RFCNT=RF+1
    133         D NOW^%DTC S ACNT=ACNT+1
    134         S ^PSRX(RXN,"A",0)="^52.3DA^"_ACNT_"^"_ACNT S ^PSRX(RXN,"A",ACNT,0)=%_"^"_"E"_"^^"_RFCNT_"^Clinical Indicators and SC/EI's were updated from a CPRS e-sig edit at "_$E($P(%,".",2),1,2)_":"_$E($P(%,".",2),3,4)_"."
    135         Q
    136         ;
    137 CHKOI   ;get and compare orderable items in file #100 and #52; don't process
    138         ;  if it's different and the placer # is null.
    139         I '$D(ARRAY(52,RXN_",",6,"I")) S OICHK=1 Q
    140         D GETS^DIQ(50,ARRAY(52,RXN_",",6,"I")_",","2.1","I","PSOOI")
    141         S ORITEM2=$$GET1^DIQ(100.001,"1,"_ORIEN_",",".01","I")
    142         S ORID=$$GET1^DIQ(101.43,ORITEM2_",","2","I") S ORID=$P(ORID,";",1)
    143         I PSOOI(50,ARRAY(52,RXN_",",6,"I")_",",2.1,"I")'="" I PSOOI(50,ARRAY(52,RXN_",",6,"I")_",",2.1,"I")'=ORID S OICHK=1
    144         Q
    145 TEST(ORIEN)     ;manually test an individual order record
    146         N I,X,ORSCEIS,ORSCEI,ORDX,EDFLG,ORITEM,DFN,JJ
    147         S (JJ,I)=0 F  S I=$O(^OR(100,ORIEN,5.1,I)) Q:I=""!(I'?1N.NN)  S JJ=JJ+1,ORDX(JJ)=$G(^OR(100,ORIEN,5.1,I,0))
    148         S ORSCEIS=^OR(100,ORIEN,5.2),ORITEM=$P($G(^OR(100,ORIEN,4)),"^",1)
    149         S ORSCEI="" F I=3,4,1,5,2,6,7 S ORSCEI=ORSCEI_"^"_$P(ORSCEIS,"^",I)
    150         S:$$PATCH^XPDUTL("OR*3.0*243") ORSCEI=ORSCEI_"^"_$P(ORSCEIS,"^",8)
    151         S ORSCEI=$E(ORSCEI,2,99)
    152         S RXN=ORITEM,DFN=$P($P(^OR(100,ORIEN,0),"^",2),";",1)
    153         D EN^PSOHLNE3(DFN,ORITEM,ORIEN,.ORDX,ORSCEI)
    154         Q
    155 OBXNTE  ; Called from PSOHLNEW due to it's routine size.
    156         S LL=ZZ+1,PSOBCT=2
    157         I $P($G(MSG(LL)),"|")="NTE" D
    158         .I $P(MSG(LL),"|",4)'="" S PSOBCT=3,OBXAR(OCOUNT,2)=$P(MSG(LL),"|",4)
    159         .F LLL=0:0 S LLL=$O(MSG(LL,LLL)) Q:'LLL  D
    160         ..I $P($G(MSG(LL,LLL)),"|",4)'="" S OBXAR(OCOUNT,PSOBCT)=$P(MSG(LL,LLL),"|",4),PSOBCT=PSOBCT+1
    161         Q
     1PSOHLNE3 ;BIR/LE - Process Edit Information from CPRS ;02/27/04
     2 ;;7.0;OUTPATIENT PHARMACY;**143,239,201**;DEC 1997
     3 ;External reference to ^OR(100 private DBIA 2219
     4 ;External reference VADPT supported by DBIA 10061
     5 ;
     6 ;This API is used to update the prescription file when ICD-9 diagnosis and SC/EI's are updated as a result of an e-sig in CPRS. 
     7 ;
     8EN(DFN,ORITEM,ORIEN,ORDX,ORSCEI) ;ENTRY POINT
     9 ;     Used to import edit information from CPRS
     10 ;Where Input:
     11 ;DFN = Patient IEN
     12 ;ORITEM = Package reference number from file 100
     13 ;ORIEN = ien from file 100
     14 ;ORDX(1)= (pointer to file 80) up to 8 accepted and first is primary ICD
     15 ;ORDX(2)= (pointer to file 80)
     16 ;ORSCEI=  seven pieces - where 1=yes, 0=no, null or ? =not asked
     17 ;  ORSCEI=AO^IR^SC^EC^MST^HNC^CV
     18 N %,DX,DX2,DX3,RXN,PSOSCP,PSOX,ORDPROV,PSOSCP2,DA,RET,PSOANSQ,PSORX,PTSTATUS,ARRAY,PSOOI,ORITEM2,ORID,OICHK,PSORENW
     19 N PSODCPY,PSONEW,PSOOIBQ,PSOFLD,PSODCZ,PSOSTAZ,PREA,PSOPIBQ,PSOIBQC,PSOSCA,PSOPICD,PSODGUP,PSOOICD,PSOPFS,TYPE,PSONW,PSOOLD,PSODA
     20 N PSODD,PSOSI,X,PSOSITE,PSOBILL,PSOCPAY,PSOCICD
     21 S:'$D(ORIEN) ORIEN="" S:'$D(ORSCEI) ORSCEI="" S:'$D(ORITEM) ORITEM=""
     22 ;
     23 ;validate prescription IEN with DFN, ord item, and placer#
     24 S RET=1,PSODCZ=",12,14,15,"
     25 S RXN=ORITEM I '$D(^PSRX(RXN)) S RET="0^1" Q RET  ;invalid RX ien
     26 I $D(^PSRX(RXN,"STA")) S PSOSTAZ=^PSRX(RXN,"STA")
     27 ; get prescription file patient ien, drug, and placer order #
     28 D GETS^DIQ(52,RXN_",","2;6;39.3","I","ARRAY")
     29 I '$D(ARRAY(52,RXN_",",2,"I")) S RET="0^3" Q RET  ;quit if you don't have a patient ien
     30 I ARRAY(52,RXN_",",2,"I")'=DFN S RET="0^3" Q RET  ;quit if patient dfn is different
     31 I '$D(ARRAY(52,RXN_",",39.3,"I")) S ARRAY(52,RXN_",",39.3,"I")=""  ;if don't have it; treat is as null
     32 I ARRAY(52,RXN_",",39.3,"I")'="" I ARRAY(52,RXN_",",39.3,"I")'=ORIEN S RET="0^5" Q RET  ;placer # is different
     33 I ARRAY(52,RXN_",",39.3,"I")="" S OICHK=0 D CHKOI I OICHK S RET="0^4" Q RET  ;quit if placer # is null and orderable item is different or null.
     34 ;end of validation process
     35 ;
     36 S PSODD=$$GET1^DIQ(52,RXN_",",6,"I") S:($P($G(^PSDRUG(PSODD,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") PSOSI=1
     37 S PSOPIBQ=$G(^PSRX(RXN,"IBQ")),PSOPICD=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,7)
     38 S PSOX("IRXN")=RXN,PSORENW("IRXN")=RXN
     39 S (PSONEW("PATIENT STATUS"),PTSTATUS)=$$GET1^DIQ(52,RXN_",","3","I")
     40 I '$D(PTSTATUS) S (PSONEW("PATIENT STATUS"),PTSTATUS)=""
     41 ;if patient status is null, treat same as PSONEW2, PSORN52, PSONEWG, AND PSONEWF.  If piece 7 of ^PS(53 doesn't equal 1, it's not exempt from copay.
     42 I ORSCEI["?" S ORSCEI=$TR(ORSCEI,"?","")
     43 D SCP^PSORN52D
     44 S PSOANSQ(PSOX("IRXN"),"VEH")=$P(ORSCEI,U,1)
     45 S PSOANSQ(PSOX("IRXN"),"RAD")=$P(ORSCEI,U,2)
     46 I PSOSCP<50&($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1) S PSOANSQ(PSOX("IRXN"),"SC")=$P(ORSCEI,U,3),PSOANSQ("SC")=$P(ORSCEI,U,3)
     47 I PSOSCP>49!($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)=1) S PSOANSQ(PSOX("IRXN"),"SC>50")=$P(ORSCEI,U,3),PSOANSQ("SC>50")=$P(ORSCEI,U,3)
     48 I PSOSCP=""&('$D(PSOANSQ("SC")))&($D(^PSRX(RXN,"ICD",1))) S PSOANSQ("SC")=$P(^PSRX(RXN,"ICD",1,0),"^",4),PSOANSQ(PSOX("IRXN"),"SC")=PSOANSQ("SC")  ;for SC with no percentage defined/ legacy
     49 S PSOANSQ(PSOX("IRXN"),"PGW")=$P(ORSCEI,U,4)
     50 S PSOANSQ(PSOX("IRXN"),"MST")=$P(ORSCEI,U,5)
     51 S PSOANSQ(PSOX("IRXN"),"HNC")=$P(ORSCEI,U,6)
     52 S PSOANSQ(PSOX("IRXN"),"CV")=$P(ORSCEI,U,7)
     53 ;
     54 S DX="",DX2=0 F  S DX=$O(ORDX(DX)) Q:DX=""  S DX2=DX2+1,PSORX("ICD",DX2)=ORDX(DX)  ;Multi signed Rx's come in consecutively and the diagnosis subscript doesn't start with 1 for each Rx
     55 S PSOSCP2=1  ;used in PSORN52D
     56 ;
     57ICD2 ;Check to see if SC/EI changed during CPRS sign order
     58 D GETS^DIQ(52,PSOX("IRXN")_",","52311*","I","PSOOICD")
     59 S PSODCPY=0,PSOFLD=""
     60 F TYPE="VEH","RAD","SC>50","PGW","MST","HNC","CV" Q:PSODCPY  F PSOFLD=1:1:7 D  Q:PSODCPY
     61 . I TYPE="VEH"&(PSOFLD=1) D CHOC
     62 . I TYPE="RAD"&(PSOFLD=2) D CHOC
     63 . I TYPE="SC>50"&(PSOFLD=3)&($D(PSOANSQ(PSOX("IRXN"),TYPE))) D CHOC
     64 . I TYPE="PGW"&(PSOFLD=4) D CHOC
     65 . I TYPE="MST"&(PSOFLD=5) D CHOC
     66 . I TYPE="HNC"&(PSOFLD=6) D CHOC
     67 . I TYPE="CV"&(PSOFLD=7) D CHOC
     68 I $D(PSOANSQ("SC")) S PSOFLD=3 S:PSOANSQ("SC")'=PSOOICD(52.052311,1_","_PSOX("IRXN")_",",PSOFLD,"I") PSODCPY=1,PSOFLD=""
     69 ; IF NO SC/EI DIFFERENCES, CHECK FOR ICD CHANGES.  If there were SC/EI difference, don't need to check ICD because they are sent anyway when copay update is done.
     70 I '$G(PSODCPY) D
     71 .I '$D(PSORX("ICD"))&($G(PSOOICD(52.052311,1_","_RXN_",",.01,"I"))) S PSODGUP=1 Q  ;if no ICD's passed and ICD's defined in 52, CPRS overrides OP
     72 .S (DX3,DX2,DX)="" F  S DX=$O(PSOOICD(52.052311,DX)) Q:DX=""  S DX2=+DX  ;get last entry for file 52
     73 .S DX="" F  S DX=$O(PSORX("ICD",DX)) Q:DX=""  S DX3=DX D  ;get last entry for new ICD's from CPRS
     74 .. I $G(PSOOICD(52.052311,DX_","_PSOX("IRXN")_",",.01,"I"))'=PSORX("ICD",DX) S PSODGUP=1  ;if ICD'S changed or more new ICD's than old ones.
     75 .I DX2>DX3 S PSODGUP=1  ;if more old ICD's than new ones
     76 Q:'$G(PSODCPY)&('$G(PSODGUP)) 1
     77 D FILE2^PSORN52D  ;file SC/EI/ICD'S into Rx file
     78 ;S PSOCIDC=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,7)
     79 ;only do copay if SC/EI changed and SC is less than 50%.
     80 I PSODCZ[(","_$G(PSOSTAZ)_",") S RET="0^6" Q RET  ;discontinue's no copay changes allowed.
     81 ;
     82 ;Get last fill number
     83 N PSOLFIL S PSOLFIL=$$LF^PSOPFSU1(RXN)
     84 S PSOPFS=$P($S('PSOLFIL:$G(^PSRX(RXN,"PFS")),1:$G(^PSRX(RXN,1,PSOLFIL,"PFS"))),"^",1,2)
     85 ; No-copay to copay updates
     86 S PSOIBQC=$G(^PSRX(RXN,"IBQ")),PSOCICD=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,7)
     87 D CPAY
     88 ; must check IBQ node in case it's a pre-CIDC rx/copay, ICD node for exempt/supply items, and for diagnosis updates for NSC Rx's
     89 I (PSOPIBQ[1&(PSOIBQC'[1))!(PSOIBQC=""&(PSOPICD[1&(PSOCICD'[1)))!($G(PSODGUP)) D  Q RET  ;don't do no copay to copay bills, but update status
     90 . D ALOG
     91 . I (PSOSCP<50)&($G(PSODCPY)) D
     92 .. I $P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1&('$G(PSOSI)) D
     93 ... S:+$G(PSOCPAY)<1&($D(^PSRX(RXN,"IB"))) $P(^PSRX(RXN,"IB"),"^",1)=""
     94 ... I +$G(PSOCPAY)>0 S $P(^PSRX(RXN,"IB"),"^",1)=+$G(PSOCPAY),PSOOLD="No Copay",PSONW="Copay",PREA="R",PSODA=RXN D:'$G(PSOSI) ACTLOG^PSOCPA
     95 . I +$G(PSOPFS)>0&('$P($G(PSOPFS),"^",2)) K PSOPFS Q   ;don't send unreleased charge msg
     96 . I +$G(PSOPFS)<1 K PSOPFS  ;invalid PFSS ACCT REF/ SEND TO IB
     97 . I +$G(PSOPFS)>0 S PSOPFS="1^"_PSOPFS
     98 . ;
     99 . I +$G(PSOPFS) D CHRG^PSOPFSU1(RXN,PSOLFIL,"CG",PSOPFS) ;always send to external bill sys
     100 ;
     101 ; Copay to no-copay updates
     102 I $G(PSODCPY) D COPAY^PSOHLNE4
     103 ;ICD UPDATE ONLY FOR COPAYS
     104 I ('$G(PSODCPY)&($G(PSODGUP)))&($P($G(PSOPFS),"^",2)) D CHRG^PSOPFSU1(RXN,PSOLFIL,"CG",PSOPFS) ;DIAGNOSIS UPDATE ONLY
     105 I ($G(PSODCPY)!($G(PSODGUP))) D ALOG
     106 Q RET
     107 ;
     108CPAY ;
     109 N X,Y,III,ACTYP,BL
     110 S PSOSITE=$P(^PSRX(RXN,2),"^",9)
     111 S X=$P($G(^PS(59,+PSOSITE,"IB")),"^")_"^"_DFN D XTYPE^IBARX
     112 S (ACTYP,BL)="",(PSOBILL,PSOCPAY)=0
     113CPAY1 ;
     114 S ACTYP=$O(Y(ACTYP)) G:'ACTYP CSKP F III=0:0 S BL=$O(Y(ACTYP,BL)) Q:BL=""  I BL>0 S PSOBILL=BL,PSOCPAY=BL_"^"_Y(ACTYP,BL)
     115 G CPAY1
     116CSKP ;
     117 S:$G(PSOSI) PSOCPAY=0  ;Supply item/investigational drug
     118 S:$P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)=1 PSOCPAY=0  ;Rx Patient Status exempt
     119 I PSOIBQC'="" S:PSOIBQC'[1 PSOCPAY=1  ;Yes SC/EI from CPRS
     120 I (PSOBILL'>0)!(PSOCPAY=0) S PSOCPAY=0  ;INELIGIBLE
     121 Q
     122 ;
     123CHOC ;check outpatient classifications
     124 S:PSOANSQ(PSOX("IRXN"),TYPE)'=PSOOICD(52.052311,1_","_PSOX("IRXN")_",",PSOFLD,"I") PSODCPY=1
     125 Q
     126 ;
     127ALOG ;set activity log with edit info from cprs
     128 N ACNT,SUB,RF,RFCNT
     129 S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(RXN,"A",SUB)) Q:'SUB  S ACNT=SUB
     130 S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF  S RFCNT=RF S:RF>5 RFCNT=RF+1
     131 D NOW^%DTC S ACNT=ACNT+1
     132 S ^PSRX(RXN,"A",0)="^52.3DA^"_ACNT_"^"_ACNT S ^PSRX(RXN,"A",ACNT,0)=%_"^"_"E"_"^^"_RFCNT_"^Clinical Indicators and SC/EI's were updated from a CPRS e-sig edit at "_$E($P(%,".",2),1,2)_":"_$E($P(%,".",2),3,4)_"."
     133 Q
     134 ;
     135CHKOI ;get and compare orderable items in file #100 and #52; don't process
     136 ;  if it's different and the placer # is null.
     137 I '$D(ARRAY(52,RXN_",",6,"I")) S OICHK=1 Q
     138 D GETS^DIQ(50,ARRAY(52,RXN_",",6,"I")_",","2.1","I","PSOOI")
     139 S ORITEM2=$$GET1^DIQ(100.001,"1,"_ORIEN_",",".01","I")
     140 S ORID=$$GET1^DIQ(101.43,ORITEM2_",","2","I") S ORID=$P(ORID,";",1)
     141 I PSOOI(50,ARRAY(52,RXN_",",6,"I")_",",2.1,"I")'="" I PSOOI(50,ARRAY(52,RXN_",",6,"I")_",",2.1,"I")'=ORID S OICHK=1
     142 Q
     143TEST(ORIEN) ;manually test an individual order record
     144 N I,X,ORSCEIS,ORSCEI,ORDX,EDFLG,ORITEM,DFN,JJ
     145 S (JJ,I)=0 F  S I=$O(^OR(100,ORIEN,5.1,I)) Q:I=""!(I'?1N.NN)  S JJ=JJ+1,ORDX(JJ)=$G(^OR(100,ORIEN,5.1,I,0))
     146 S ORSCEIS=^OR(100,ORIEN,5.2),ORITEM=$P($G(^OR(100,ORIEN,4)),"^",1)
     147 S ORSCEI="" F I=3,4,1,5,2,6,7 S ORSCEI=ORSCEI_"^"_$P(ORSCEIS,"^",I)
     148 S ORSCEI=$E(ORSCEI,2,99)
     149 S RXN=ORITEM,DFN=$P($P(^OR(100,ORIEN,0),"^",2),";",1)
     150 D EN^PSOHLNE3(DFN,ORITEM,ORIEN,.ORDX,ORSCEI)
     151 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE4.m

    r613 r623  
    1 PSOHLNE4        ;BIR/LE - Process Edit Information from CPRS - CONTINUED FROM PSOHLNE3 ;02/27/04
    2         ;;7.0;OUTPATIENT PHARMACY;**201,225**;DEC 1997;Build 29
    3         ;
    4         ;This API is used to update the prescription file when ICD-9 diagnosis
    5         ; and SC/EI's are updated as a result of an e-sig in CPRS.
    6         Q
    7 COPAY   ;For IB, cancel copay charges if SC<50% and SC/EI changed and released; For PFS, send charge update msgs for SC 0-100%
    8         ;  must have PSODA,PSO,PSODAYS,PSOFLAG,PSOREF,PSOIB,PSOPAR7,PSOOLD,PSONW before call to PSOCPA
    9         N PSODA,PSO,PSODAYS,PSOFLAG,PSOREF,PSOIB,PSZ,PSOPAR7,PSOCSEQ,PSZ1,PSZ2,RELDAT,PSOOLD,PSONW,PSOSITE,PREA,PSOFLD,PSOPFS
    10         S PSODA=RXN,PSO=3,PSODAYS=$$GET1^DIQ(52,PSODA_",","8")
    11         S PSOOLD="Copay"
    12         S PSONW="No Copay"
    13         S PSOSITE=$P(^PSRX(PSODA,2),"^",9)
    14         S PSOPAR7=$G(^PS(59,PSOSITE,"IB"))
    15         S PSOFLAG=1  ;1 used here to eliminate display/print of messages.
    16 CSORT   ; get orig fill copay info if released.
    17         S RELDAT=$$GET1^DIQ(52,PSODA_",","31","I")
    18         I RELDAT'="" S PSOCSEQ("A",0)=$G(^PSRX(PSODA,"IB"))
    19         ;I RELDAT="" S PREA="R" D:'$G(PSOSI)&(PSOSCP<50)&($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1) ACTLOG^PSOCPA G SET ;set act log when unreleased, but SC/EI changed copay
    20         I RELDAT="" S PREA="R" D:+$G(PSOCPAY)>0&(PSOIBQC[1&(PSOPIBQ'[1)) ACTLOG^PSOCPA G SET ;set act log when unreleased, but SC/EI changed copay
    21         ; get copay info for all released refills; if any
    22         F PSZ=0:0 S PSZ=$O(^PSRX(PSODA,1,PSZ)) Q:PSZ'>0  D
    23         . S RELDAT="",RELDAT=$$GET1^DIQ(52.1,PSZ_","_PSODA_",","17","I")
    24         . Q:RELDAT=""
    25         . S PSOCSEQ("A",PSZ)=$G(^PSRX(PSODA,1,PSZ,"IB"))
    26         ; Sort potential refills to be cancelled first starting with last fill
    27         ;    then orig fill then the rest of the entries.
    28         S (PSZ1,PSZ2,PSZ)="" F  S PSZ=$O(PSOCSEQ("A",PSZ),-1) Q:PSZ=""  D
    29         . I PSZ>0&($P(PSOCSEQ("A",PSZ),"^",2)'="") S PSZ1=PSZ1+1,PSOCSEQ("B",PSZ1,PSZ)="" Q
    30         . I PSZ>0&($P(PSOCSEQ("A",PSZ),"^",2)="") S PSZ2=PSZ2+1000,PSOCSEQ("B",PSZ2,PSZ)="" Q
    31         . I PSZ=0&($P(PSOCSEQ("A",PSZ),"^",4)'="") S PSZ1=PSZ1+1,PSOCSEQ("B",PSZ1,PSZ)="" Q
    32         . I PSZ=0&($P(PSOCSEQ("A",PSZ),"^",4)="") S PSZ2=PSZ2+1000,PSOCSEQ("B",PSZ2,PSZ)="" Q
    33         ;
    34         ;S (PSZ,PSZ1)="",PSOFLD=0,PREA="R" D:'$G(PSOSI)&(PSOSCP<50)&($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1) ACTLOG^PSOCPA F  S PSZ1=$O(PSOCSEQ("B",PSZ1)) Q:PSZ1=""  D
    35         S (PSZ,PSZ1)="",PSOFLD=0,PREA="R" D:+$G(PSOCPAY)>0&(PSOIBQC[1&(PSOPIBQ'[1)) ACTLOG^PSOCPA F  S PSZ1=$O(PSOCSEQ("B",PSZ1)) Q:PSZ1=""  D
    36         . F  S PSZ=$O(PSOCSEQ("B",PSZ1,PSZ)) Q:PSZ=""  D
    37         .. S (PSOREF,PSOIB)="",PSOFLD=PSOFLD+1 S PREA="C" ;$S(PSOFLD=1:"R",1:"C")
    38         .. ;I PSOFLD>1
    39         .. S (PSOOLD,PSONW)=""
    40         .. S PSOREF=PSZ
    41         .. ;
    42         .. S PSOPFS="",PSOPFS=$P($S('PSOREF:$G(^PSRX(PSODA,"PFS")),1:$G(^PSRX(PSODA,1,PSOREF,"PFS"))),"^",1,2)
    43         .. I +$G(PSOPFS)>0&('$P($G(PSOPFS),"^",2)) K PSOPFS Q   ;don't send unreleased charge msg
    44         .. I +$G(PSOPFS)<1 K PSOPFS  ;invalid PFSS ACCT REF/ SEND TO IB
    45         .. I +$G(PSOPFS)>0 S PSOPFS="1^"_PSOPFS
    46         .. ;
    47         .. N TYPE S PSOIB=PSOCSEQ("A",PSOREF),TYPE=PSOREF
    48         .. I +$G(PSOPFS) D CHRG^PSOPFSU1(PSODA,PSOREF,"CG",PSOPFS) D:+$G(PSOCPAY)>0&(PSOIBQC[1&(PSOPIBQ'[1)) ACTLOG^PSOCPA Q  ;PFSS charge update only
    49         .. I PSOSCP<50 D RXED^PSOCPA  ;IB - if SC<50 and not billed via PFSS
    50 SET     S:$D(^PSRX(RXN,"IB"))&(PSOSCP<50)&('$G(PSOSI)) $P(^PSRX(RXN,"IB"),"^",1)=""
    51         K PSOSCP
    52         Q
    53         ;
    54 OBR     ;Flag/Unflag orders
    55         I PSOTYPE'="OBR"!($G(PSOSEG)="") Q
    56         N PSOFLAG,PSORDER,PSOPEN,DR,PSOREA,PSOBY,PSONOW
    57         S PSORDER=+$P($P(PSOSEG,"|",2),"^")           ; Pointer to ORDER file (#100)
    58         S PSOPEN=+$O(^PS(52.41,"B",PSORDER,0))        ; Pointer to PENDING OUTPATIENT ORDERS file (#52.41)
    59         S PSOFLAG=$P(PSOSEG,"|",4)                    ; "FL" for Flag and "UF" for Unflag action
    60         S PSOREA=$P(PSOSEG,"|",13)                    ; Reason for Flag/Unflag (Freetext up to 80chars)
    61         S PSOBY=$P(PSOSEG,"|",16)                     ; Flagged/Unflagged By - Pointer to NEW PERSON file (#200)
    62         S PSONOW=$E($$NOW^XLFDT(),1,12)               ; CURRENT DATE/TIME wihtout seconds
    63         ;
    64         I 'PSOPEN!'$P($G(^PS(52.41,PSOPEN,0)),"^") D EN^ORERR("Invalid Pending Order/Flag Msg",.MSG) Q
    65         ;
    66         I PSOFLAG="FL" D
    67         . S $P(^PS(52.41,PSOPEN,"FLG"),"^",1,3)=PSONOW_"^"_PSOBY_"^"_$E(PSOREA,1,80)
    68         . S $P(^PS(52.41,PSOPEN,"FLG"),"^",4,6)="^^"
    69         . S $P(^PS(52.41,PSOPEN,0),"^",23)=1
    70         E  D
    71         . S $P(^PS(52.41,PSOPEN,"FLG"),"^",4,6)=PSONOW_"^"_PSOBY_"^"_$E(PSOREA,1,80)
    72         . S $P(^PS(52.41,PSOPEN,0),"^",23)=""
    73         ;
    74         Q
     1PSOHLNE4 ;BIR/LE - Process Edit Information from CPRS - CONTINUED FROM PSOHLNE3 ;02/27/04
     2 ;;7.0;OUTPATIENT PHARMACY;**201**;DEC 1997
     3 ;
     4 ;This API is used to update the prescription file when ICD-9 diagnosis
     5 ; and SC/EI's are updated as a result of an e-sig in CPRS.
     6 Q
     7COPAY ;For IB, cancel copay charges if SC<50% and SC/EI changed and released; For PFS, send charge update msgs for SC 0-100%
     8 ;  must have PSODA,PSO,PSODAYS,PSOFLAG,PSOREF,PSOIB,PSOPAR7,PSOOLD,PSONW before call to PSOCPA
     9 N PSODA,PSO,PSODAYS,PSOFLAG,PSOREF,PSOIB,PSZ,PSOPAR7,PSOCSEQ,PSZ1,PSZ2,RELDAT,PSOOLD,PSONW,PSOSITE,PREA,PSOFLD,PSOPFS
     10 S PSODA=RXN,PSO=3,PSODAYS=$$GET1^DIQ(52,PSODA_",","8")
     11 S PSOOLD="Copay"
     12 S PSONW="No Copay"
     13 S PSOSITE=$P(^PSRX(PSODA,2),"^",9)
     14 S PSOPAR7=$G(^PS(59,PSOSITE,"IB"))
     15 S PSOFLAG=1  ;1 used here to eliminate display/print of messages.
     16CSORT ; get orig fill copay info if released.
     17 S RELDAT=$$GET1^DIQ(52,PSODA_",","31","I")
     18 I RELDAT'="" S PSOCSEQ("A",0)=$G(^PSRX(PSODA,"IB"))
     19 ;I RELDAT="" S PREA="R" D:'$G(PSOSI)&(PSOSCP<50)&($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1) ACTLOG^PSOCPA G SET ;set act log when unreleased, but SC/EI changed copay
     20 I RELDAT="" S PREA="R" D:+$G(PSOCPAY)>0&(PSOIBQC[1&(PSOPIBQ'[1)) ACTLOG^PSOCPA G SET ;set act log when unreleased, but SC/EI changed copay
     21 ; get copay info for all released refills; if any
     22 F PSZ=0:0 S PSZ=$O(^PSRX(PSODA,1,PSZ)) Q:PSZ'>0  D
     23 . S RELDAT="",RELDAT=$$GET1^DIQ(52.1,PSZ_","_PSODA_",","17","I")
     24 . Q:RELDAT=""
     25 . S PSOCSEQ("A",PSZ)=$G(^PSRX(PSODA,1,PSZ,"IB"))
     26 ; Sort potential refills to be cancelled first starting with last fill
     27 ;    then orig fill then the rest of the entries.
     28 S (PSZ1,PSZ2,PSZ)="" F  S PSZ=$O(PSOCSEQ("A",PSZ),-1) Q:PSZ=""  D
     29 . I PSZ>0&($P(PSOCSEQ("A",PSZ),"^",2)'="") S PSZ1=PSZ1+1,PSOCSEQ("B",PSZ1,PSZ)="" Q
     30 . I PSZ>0&($P(PSOCSEQ("A",PSZ),"^",2)="") S PSZ2=PSZ2+1000,PSOCSEQ("B",PSZ2,PSZ)="" Q
     31 . I PSZ=0&($P(PSOCSEQ("A",PSZ),"^",4)'="") S PSZ1=PSZ1+1,PSOCSEQ("B",PSZ1,PSZ)="" Q
     32 . I PSZ=0&($P(PSOCSEQ("A",PSZ),"^",4)="") S PSZ2=PSZ2+1000,PSOCSEQ("B",PSZ2,PSZ)="" Q
     33 ;
     34 ;S (PSZ,PSZ1)="",PSOFLD=0,PREA="R" D:'$G(PSOSI)&(PSOSCP<50)&($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1) ACTLOG^PSOCPA F  S PSZ1=$O(PSOCSEQ("B",PSZ1)) Q:PSZ1=""  D
     35 S (PSZ,PSZ1)="",PSOFLD=0,PREA="R" D:+$G(PSOCPAY)>0&(PSOIBQC[1&(PSOPIBQ'[1)) ACTLOG^PSOCPA F  S PSZ1=$O(PSOCSEQ("B",PSZ1)) Q:PSZ1=""  D
     36 . F  S PSZ=$O(PSOCSEQ("B",PSZ1,PSZ)) Q:PSZ=""  D
     37 .. S (PSOREF,PSOIB)="",PSOFLD=PSOFLD+1 S PREA="C" ;$S(PSOFLD=1:"R",1:"C")
     38 .. ;I PSOFLD>1
     39 .. S (PSOOLD,PSONW)=""
     40 .. S PSOREF=PSZ
     41 .. ;
     42 .. S PSOPFS="",PSOPFS=$P($S('PSOREF:$G(^PSRX(PSODA,"PFS")),1:$G(^PSRX(PSODA,1,PSOREF,"PFS"))),"^",1,2)
     43 .. I +$G(PSOPFS)>0&('$P($G(PSOPFS),"^",2)) K PSOPFS Q   ;don't send unreleased charge msg
     44 .. I +$G(PSOPFS)<1 K PSOPFS  ;invalid PFSS ACCT REF/ SEND TO IB
     45 .. I +$G(PSOPFS)>0 S PSOPFS="1^"_PSOPFS
     46 .. ;
     47 .. N TYPE S PSOIB=PSOCSEQ("A",PSOREF),TYPE=PSOREF
     48 .. I +$G(PSOPFS) D CHRG^PSOPFSU1(PSODA,PSOREF,"CG",PSOPFS) D:+$G(PSOCPAY)>0&(PSOIBQC[1&(PSOPIBQ'[1)) ACTLOG^PSOCPA Q  ;PFSS charge update only
     49 .. I PSOSCP<50 D RXED^PSOCPA  ;IB - if SC<50 and not billed via PFSS
     50SET S:$D(^PSRX(RXN,"IB"))&(PSOSCP<50)&('$G(PSOSI)) $P(^PSRX(RXN,"IB"),"^",1)=""
     51 K PSOSCP
     52 Q
     53 ;

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNEW.m

    r613 r623  
    1 PSOHLNEW        ;BIR/RTR - CPRS orders ;11/30/06 11:49am
    2         ;;7.0;OUTPATIENT PHARMACY;**1,7,15,46,71,98,111,124,117,131,146,132,143,223,235,148,239,249,225**;DEC 1997;Build 29
    3         ;40.8-728,50-221,SC-2675,100-2219,50.7-2223,EN^ORERR-2187
    4 EN(MSG) ;
    5         N PSODDRUG,ENTERED,LOCATION,PLACER,PSOOC,ROUTE,NATURE,PREV,ROUTING,OO,OR,STAT,ZZ,DFN,COMM,QCOUNT,OCOUNT,Q1I,QTARRAY,QTARRAY2,EE,PP,XOFLAG,PSODYSPL,PSOFILNM
    6         N ONEFLAG,SERV,WPCT,EFFECT,PROV,PENDING,RRX,PSOLQ1I,PSOLQ1II,PSOQWX,PSOLQ1IX,PSONVA,PSOICD,PSOSCP,EEE
    7         N OBXAR,AA,II,SIG1,FILLER,COMM,GG,FF,JJ,JJJ,CT,LIM,VAR,VAR1,QQQ,PSRNFLAG,PSRNQFLG,RCOMM,XOFLAGZ,NWFLAG,PFLAG,PSINPTR,INPTRX,PSOIBN,PSOIBY
    8         N DSIG,PSOCHFFL,PSOCVI,PSOMO,PSOXRP,NN,LL,LLL,WPARRAY,QTVAR,POVAR,POVAR1,ORCSEG,NNN,OOO,AAA,NNNN,POLIM,NNCK,PRIOR,IPPLACER,PLACERXX,EER,PSERRPID,PSERRPV1,PSERRORC,PSOEXFLG,PSOMSORR,PDFN,VAL
    9         S (SEND,PSOSND,OCOUNT)=0 K PSOPLC,PSOFFL,PSORSO,PSOSUSZ
    10         F OO=0:0 S OO=$O(MSG(OO)) Q:'OO!(SEND)!(PSOSND)  D:$P(MSG(OO),"|")="PID" SPDFN I $P(MSG(OO),"|")="ORC",$P(MSG(OO),"|",2)'="NW",$P(MSG(OO),"|",2)'="XO" D
    11         .S OR("STAT")=$P(MSG(OO),"|",2),OR("PLACE")=+$P(MSG(OO),"|",3),PLACERXX=+$P($P(MSG(OO),"|",3),";",2),OR("COMM")=$P(MSG(OO),"|",17),OR("USER")=$P(MSG(OO),"|",11) I $P(MSG(OO),"|",2)'="DE",$P(MSG(OO),"|",2)'="NA" S SEND=1 D FILL Q
    12         .S PSOPLC=+$P(MSG(OO),"|",3),PSOFFL=+$P(MSG(OO),"|",4),PSOSND=1,PSOCHFFL=$P($P(MSG(OO),"|",4),"^")
    13         I $G(OR("COMM"))["^" S OR("COMM")=$P(OR("COMM"),"^",5)
    14         I PSOSND,$G(PSOCHFFL)["S",$G(OR("STAT"))="NA" D CHCS^PSOHLNE1 Q
    15         I PSOSND,'$D(^PSRX(+$G(PSOFFL),0)) S COMM="Order was not located by Pharmacy" D EN^ORERR(COMM,.MSG) D KL Q
    16         I PSOSND,$G(PDFN),PDFN'=+$P($G(^PSRX(+$G(PSOFFL),0)),"^",2) S COMM="Patient does not match" D EN^ORERR(COMM,.MSG) D KL Q
    17         I PSOSND,$G(OR("STAT"))'="DE" N PSONAS S PSONAS=$S($P($G(^PSRX(PSOFFL,"OR1")),"^",2)="":1,1:0) S $P(^PSRX(PSOFFL,"OR1"),"^",2)=PSOPLC,^PSRX("APL",PSOPLC,PSOFFL)="" D:PSONAS EN^PSOHDR("PRES",PSOFFL) D KL Q
    18         D KL
    19         I SEND,$G(OR("STAT"))="Z@" G PURGE^PSOHLNE2
    20         I SEND,$G(OR("STAT"))="ZF" G REF^PSOHLNE2
    21         I SEND,$G(OR("STAT"))'="CA",$G(OR("STAT"))'="DC",$G(OR("STAT"))'="HD",$G(OR("STAT"))'="RL",$G(OR("STAT"))'="SS" S RCOMM="Invalid Order Control Code" D EN^ORERR(RCOMM,.MSG) Q
    22         I SEND K SEND G:$G(OR("STAT"))="SS" ESTAT D EN^PSOORUTL(.OR) S PLACER=OR("PLACE"),STAT=OR("STAT"),COMM=OR("COMM") S PSOMSORR=1 D  K PSOMSORR Q
    23         .I $G(OR("FILLER"))="" D  D ERROR^PSOHLSN Q
    24         ..F EER=0:0 S EER=$O(MSG(EER)) Q:'EER  S:$P(MSG(EER),"|")="PV1" PSERRPV1=MSG(EER) S:$P(MSG(EER),"|")="PID" PSERRPID=MSG(EER) S:$P(MSG(EER),"|")="ORC"&($G(PSERRORC)="") PSERRORC=MSG(EER)
    25         .I $P(OR("FILLER"),"^",2)="R" S FILLER=$P(OR("FILLER"),"^") D EN^PSOHLSN1(FILLER,STAT,$G(OR("PHARMST")),COMM) K:$G(PSOEXFLG) PSOMSORR,PLACERXX D:$G(PSOEXFLG) EN^PSOHLSN1(FILLER,"SC","ZE","") D:$G(PSOSUSZ) SUS^PSOORUT1 K PSOSUSZ Q
    26         .D EN^PSOHLSN(PLACER,STAT,COMM) Q
    27         D KL^PSOHLSIH S RRX=1 F ZZ=0:0 S ZZ=$O(MSG(ZZ)) Q:'ZZ  S PSOSEG=$G(MSG(ZZ)),PSOTYPE=$P(PSOSEG,"|") S PSOSEG=$E(PSOSEG,5,$L(PSOSEG)) I PSOTYPE'="NTE" D @PSOTYPE
    28         I $G(PSRNFLAG) S PSOMO=0 D MISRN^PSOHLNE1 I $G(PSOMO) Q
    29         S PSRNQFLG=0 I $G(PSRNFLAG),$G(PREV) D  I $G(PSRNQFLG) S RCOMM="Duplicate Renewal Request. Order rejected by Pharmacy." D EN^ORERR(RCOMM,.MSG) D RERROR^PSOHLSN D KL^PSOHLSIH Q
    30         .I $P($G(^PSRX(PREV,"OR1")),"^",4) S PSRNQFLG=1 Q
    31         .I $O(^PS(52.41,"AQ",PREV,0)) S PSRNQFLG=1
    32         .I $G(XOFLAG),$G(DFN)'=$S($G(PFLAG):$P($G(^PS(52.41,+$G(PREV),0)),"^",2),1:$P($G(^PSRX(+$G(PREV),0)),"^",2)) S RCOMM="Patient mismatch on previous order." D EN^ORERR(RCOMM,.MSG) S XOFLAGZ=1 D RERROR^PSOHLSN D KL^PSOHLSIH Q
    33         I $G(PLACER) I $G(DFN)'=+$P($G(^OR(100,+PLACER,0)),"^",2) G MISX^PSOHLNE1
    34         I $G(PLACER) D NFILE
    35         D KL^PSOHLSIH
    36         Q
    37 ESTAT   ;
    38         D EXP^PSOHLNE1
    39         Q
    40 MSH     Q
    41 PID     S DFN=+$P(PSOSEG,"|",3)
    42         Q
    43 PV1     S LOCATION=+$P(+$P(PSOSEG,"|",3),"^")
    44         S:'$D(^SC(LOCATION,0)) LOCATION=""
    45         S INPTRX=0 I $G(LOCATION) S PSINPTR=$P($G(^SC(LOCATION,0)),"^",4) I PSINPTR Q
    46         I $G(LOCATION) S INPTRX=$P($G(^SC(LOCATION,0)),"^",15)
    47         I '$G(INPTRX) S INPTRX=$O(^DG(40.8,0))
    48         I '$G(DT) S DT=$$DT^XLFDT
    49         S PSINPTR=+$$SITE^VASITE(DT,INPTRX)
    50         Q
    51 OBR     ;This segment is used to pass flagging information from CPRS.
    52         D OBR^PSOHLNE4
    53         Q
    54 DG1     S $P(PSOICD($P(PSOSEG,"|",1)),"^")=$P($P(PSOSEG,"|",3),"^")
    55         Q
    56 ORC     ;
    57         Q:$P(PSOSEG,"|")="DE"
    58         S:$P(PSOSEG,"|")="XO" XOFLAG=1 D ^PSOHLNE1 S:$G(PRIOR)="A" PRIOR="E" S:$G(PRIOR)="" PRIOR="R"
    59         Q
    60         ;
    61 RXO     I $O(MSG(ZZ,0)) D ^PSOHLNE2 G RXOPS
    62         S PSORDITE=$P($P(PSOSEG,"|"),"^",4)
    63         S PSODDRUG=$P($P(PSOSEG,"|",10),"^",4) I $G(PSODDRUG) S:'$D(^PSDRUG(PSODDRUG,0)) PSODDRUG=""
    64         S PSOXQTY=$P(PSOSEG,"|",11)
    65         S PSOREFIL=$P(PSOSEG,"|",13)
    66         S PSODYSPL=$P(PSOSEG,"|",17)
    67 RXOPS   S ONEFLAG=0,WPCT=1,LL=ZZ+1
    68         I $P($G(MSG(LL)),"|")="NTE" D
    69         .S ONEFLAG=1,WORDP=$S($P(MSG(LL),"|",2):$P(MSG(LL),"|",2),1:$P(MSG(LL),"|",3)) S:$P(MSG(LL),"|",4)'="" WPARRAY(WORDP,WPCT)=$P(MSG(LL),"|",4) S:$P(MSG(LL),"|",4)'="" WPCT=WPCT+1 F LLL=0:0 S LLL=$O(MSG(LL,LLL)) Q:'LLL  D
    70         ..I $G(MSG(LL,LLL))'="" S WPARRAY(WORDP,WPCT)=$G(MSG(LL,LLL)),WPCT=WPCT+1
    71         I ONEFLAG S LL=LL+1 I $P($G(MSG(LL)),"|")="NTE" D NTE^PSOHLNE1
    72         K WORDP
    73         Q
    74 RXR     I $P($P(PSOSEG,"|"),"^",4) S ROUTE(RRX)=$P($P(PSOSEG,"|"),"^",4) S RRX=RRX+1
    75         Q
    76 OBX     I $O(MSG(ZZ,0)) D OBXX^PSOHLNE2 G OBXNTE
    77         S OCOUNT=OCOUNT+1
    78         S OBXAR(OCOUNT,1)=$P(PSOSEG,"|",5)
    79 OBXNTE  ;
    80         D OBXNTE^PSOHLNE3
    81         Q
    82 ZRN     S PSODSC=1_"^"_$P(PSOSEG,"|",2)
    83         I $O(MSG(ZZ,0)) F T=0:0 S T=$O(MSG(ZZ,T)) Q:'T  S PSODSC(T)=MSG(ZZ,T)
    84         K T
    85         Q
    86         ;
    87 ZRX     D ZRX^PSOHLNE1
    88         Q
    89         ;
    90 ZCL     D ZCL^PSOHLNE1
    91         Q
    92 ZSC     D CP^PSOHLNE1
    93         Q
    94 NFILE   ;
    95         I $G(PSODSC) D ^PSONVNEW Q  ;adds non-va med to #55
    96         ;
    97         K DD,DO,DIC S DLAYGO="52.41",DIC="^PS(52.41,",DIC(0)="L",X=PLACER,DIC("DR")="1////"_DFN_";2////"_PSOOC_";6////"_$G(EFFECT)_";12////"_$G(PSOXQTY)_";25////"_$G(PRIOR)
    98         S DIC("DR")=DIC("DR")_";22////"_$G(PSORSO)_";22.1////"_$G(PREV)_";19////"_$G(ROUTING)_";17////"_$$UNESC^ORHLESC($G(SERV))_";7////"_$G(NATURE)_";13////"_$G(PSOREFIL)_";1.1////"_$G(LOCATION)_";117////"_$G(DSIG)
    99         D FILE^DICN K DIC,DR I Y<0 Q
    100         S PENDING=+Y
    101         S $P(^PS(52.41,PENDING,0),"^",4)=$S($G(ENTERED):+$G(ENTERED),1:""),$P(^(0),"^",5)=$S($G(PROV):+$G(PROV),1:""),$P(^(0),"^",8)=$S($G(PSORDITE):+$G(PSORDITE),1:""),$P(^(0),"^",9)=$S($G(PSODDRUG):+$G(PSODDRUG),1:""),$P(^(0),"^",15)=$G(ROUTE)
    102         S ^PS(52.41,PENDING,"IBQ")=$G(PSOIBY)
    103         I $G(PSODYSPL)'="",$E(PSODYSPL)?1A S PSODYSPL=$E(PSODYSPL,2,$L(PSODYSPL))
    104         S $P(^PS(52.41,PENDING,"INI"),"^")=$G(PSINPTR),$P(^(0),"^",12)=$G(PSOLOG),$P(^(0),"^",22)=$G(PSODYSPL)
    105         I $G(QCOUNT) S ^PS(52.41,PENDING,1,0)="^52.413^"_QCOUNT_"^"_QCOUNT
    106         S PSOQWX=$G(PSODDRUG) D:'$G(PSOQWX) OID^PSOHLNE1
    107         F PP=0:0 S PP=$O(Q1I(PP)) Q:'PP  S VAL=$S($G(PSOQWX)&($G(PSOLQ1II(PP))):Q1I(PP),$G(PSOQWX)&($G(PSOLQ1IX(PP))'="")&('$G(PSOLQ1II(PP))):PSOLQ1IX(PP),1:PSOLQ1I(PP)) S ^PS(52.41,PENDING,1,PP,0)=$$UNESC^ORHLESC(VAL)
    108         F EE=0:0 S EE=$O(QTARRAY(EE)) Q:'EE  S ^PS(52.41,PENDING,1,EE,1)=$$UNESC^ORHLESC(QTARRAY(EE)) S VAL=$S($G(PSOQWX)&($G(PSOLQ1II(EE))):$G(QTARRAY2(EE)),$G(PSOQWX)&($G(PSOLQ1IX(EE))'="")&('$G(PSOLQ1II(EE))):PSOLQ1IX(EE),1:$G(PSOLQ1I(EE))) D
    109         .S ^PS(52.41,PENDING,1,EE,2)=$$UNESC^ORHLESC(VAL) S $P(^PS(52.41,PENDING,1,EE,1),"^",8)=+$G(ROUTE(EE))
    110         S:$P($G(^PS(52.41,PENDING,1,1,1)),"^",3) $P(^PS(52.41,PENDING,0),"^",18)=$E($P($G(^PS(52.41,PENDING,1,1,1)),"^",3),1,7)
    111         D STUFF^PSOHLNE2
    112         D ^PSOHLPII
    113         S LL=0 I $O(WPARRAY(6,0)) F LLL=0:0 S LLL=$O(WPARRAY(6,LLL)) Q:'LLL  S LL=LL+1 S ^PS(52.41,PENDING,3,LL,0)=$$UNESC^ORHLESC($G(WPARRAY(6,LLL)))
    114         I LL S ^PS(52.41,PENDING,3,0)="^52.42^"_LL_"^"_LL
    115         S LL=0 I $O(WPARRAY(7,0)) F LLL=0:0 S LLL=$O(WPARRAY(7,LLL)) Q:'LLL  S LL=LL+1 S ^PS(52.41,PENDING,"INS1",LL,0)=$$UNESC^ORHLESC($G(WPARRAY(7,LLL)))
    116         I LL S ^PS(52.41,PENDING,"INS1",0)="^^"_LL_"^"_LL_"^"_$G(DT)_"^"
    117         I $P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^")'="" S $P(^PS(52.41,PENDING,"INS"),"^",2)=$S($O(^PS(52.41,PENDING,"INS1",0)):1,1:0)
    118         I $G(OCOUNT) S ^PS(52.41,PENDING,"OBX",0)="^52.4118A^"_OCOUNT_"^"_OCOUNT F OCOUNT=1:1:OCOUNT D
    119         .S ^PS(52.41,PENDING,"OBX",OCOUNT,0)=$$UNESC^ORHLESC($G(OBXAR(OCOUNT,1)))
    120         .D USER^PSOORFI2(+$G(PROV)) S ^PS(52.41,PENDING,"OBX",OCOUNT,1)=$$UNESC^ORHLESC(USER1) K USER1
    121         .S PSOBCT=1 F LLL=2:1 Q:'$D(OBXAR(OCOUNT,LLL))  S ^PS(52.41,PENDING,"OBX",OCOUNT,2,PSOBCT,0)=$$UNESC^ORHLESC(OBXAR(OCOUNT,LLL)),^PS(52.41,PENDING,"OBX",OCOUNT,2,0)="^^"_PSOBCT_"^"_PSOBCT_"^"_$G(DT)_"^"
    122         D ^PSOHLPIS
    123         K DIK S DIK="^PS(52.41,",DA=PENDING D IX^DIK
    124         I $G(PSOOC)="RNW",$G(PREV),$D(^PSRX(+$G(PREV),0)) D EN^PSOHLSN1(PREV,"SC","ZZ","")
    125         S PSOMSORR=1,IPPLACER=$P($G(^PS(52.41,PENDING,0)),"^") I IPPLACER D
    126         .I '$G(XOFLAG) D EN^PSOHLSN(IPPLACER,"OK","IP") Q
    127         .D EN^PSOHLSN(IPPLACER,"XR","IP") I $G(PFLAG) D DCP^PSOHLSN Q
    128         .K PSOMSORR I $D(^PSRX(+$G(PREV),0)) D  D EN^PSOHLSN1(PREV,"RP","","","A")
    129         ..S $P(^PSRX(PREV,"STA"),"^")=15,$P(^PSRX(PREV,3),"^",5)=DT,$P(^PSRX(PREV,3),"^",10)=$P(^PSRX(PREV,3),"^")  ;;PSO*7*249
    130         ..D REVERSE^PSOBPSU1(PREV,,"DC",7),CAN^PSOTPCAN(PREV),CAN^PSOUTL(PREV)
    131         ..D CNT^PSOHLNE1
    132         ..D:$G(^PS(52.41,PENDING,1,1,0))=""&($P($G(^PS(52.41,PENDING,1,1,1)),"^")="")&($G(^PS(52.41,PENDING,"SIG",1,0))="")
    133         ...N FSIG,BSIG
    134         ...I '$P($G(^PSRX(PREV,"SIG")),"^",2),$P($G(^("SIG")),"^")'="" D
    135         ....D EN3^PSOUTLA1(PREV,70)
    136         ....I $G(BSIG(1))'="" S ^PS(52.41,PENDING,"SIG",1,0)=$$UNESC^ORHLESC($G(BSIG(1))) I $O(BSIG(1)) F EE=1:0 S EE=$O(BSIG(EE)) Q:'EE  S ^PS(52.41,PENDING,"SIG",EE,0)=$$UNESC^ORHLESC($G(BSIG(EE)))
    137         ...I $P($G(^PSRX(PREV,"SIG")),"^",2),$G(^PSRX(PREV,"SIG1",1,0))'="" D
    138         ....D FSIG^PSOUTLA("R",PREV,70)
    139         ....I $G(FSIG(1))'="" S ^PS(52.41,PENDING,"SIG",1,0)=$$UNESC^ORHLESC($G(FSIG(1))) I $O(FSIG(1)) F EE=1:0 S EE=$O(FSIG(EE)) Q:'EE  S ^PS(52.41,PENDING,"SIG",EE,0)=$$UNESC^ORHLESC($G(FSIG(EE)))
    140         ...F EE=0:0 S EE=$O(^PS(52.41,PENDING,"SIG",EE)) Q:'EE  S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_EE_"^"_EE
    141         D CSET^PSODIAG
    142         Q
    143 SPDFN   S PDFN=$P($G(MSG(OO)),"|",4) Q
    144 KL      K PSOPLC,PSOFFL,PSOSND
    145         Q
    146 FILL    ;
    147         S (PSOFILNM,OR("PSOFILNM"))=$P($P(MSG(OO),"|",4),"^")
    148         Q
     1PSOHLNEW ;BIR/RTR - CPRS orders ; 11/30/06 11:49am
     2 ;;7.0;OUTPATIENT PHARMACY;**1,7,15,46,71,98,111,124,117,131,146,132,143,223,235,148,239,249**;DEC 1997;Build 9
     3 ;40.8-728,50-221,SC-2675,100-2219,50.7-2223,EN^ORERR-2187
     4EN(MSG) ;
     5 N PSODDRUG,ENTERED,LOCATION,PLACER,PSOOC,ROUTE,NATURE,PREV,ROUTING,OO,OR,STAT,ZZ,DFN,COMM,QCOUNT,OCOUNT,Q1I,QTARRAY,QTARRAY2,EE,PP,XOFLAG,PSODYSPL,PSOFILNM
     6 N ONEFLAG,SERV,WPCT,EFFECT,PROV,PENDING,RRX,PSOLQ1I,PSOLQ1II,PSOQWX,PSOLQ1IX,PSONVA,PSOICD,PSOSCP,EEE
     7 N OBXAR,AA,II,SIG1,FILLER,COMM,GG,FF,JJ,JJJ,CT,LIM,VAR,VAR1,QQQ,PSRNFLAG,PSRNQFLG,RCOMM,XOFLAGZ,NWFLAG,PFLAG,PSINPTR,INPTRX,PSOIBN,PSOIBY
     8 N DSIG,PSOCHFFL,PSOCVI,PSOMO,PSOXRP,NN,LL,LLL,WPARRAY,QTVAR,POVAR,POVAR1,ORCSEG,NNN,OOO,AAA,NNNN,POLIM,NNCK,PRIOR,IPPLACER,PLACERXX,EER,PSERRPID,PSERRPV1,PSERRORC,PSOEXFLG,PSOMSORR,PDFN
     9 S (SEND,PSOSND,OCOUNT)=0 K PSOPLC,PSOFFL,PSORSO,PSOSUSZ
     10 F OO=0:0 S OO=$O(MSG(OO)) Q:'OO!(SEND)!(PSOSND)  D:$P(MSG(OO),"|")="PID" SPDFN I $P(MSG(OO),"|")="ORC",$P(MSG(OO),"|",2)'="NW",$P(MSG(OO),"|",2)'="XO" D
     11 .S OR("STAT")=$P(MSG(OO),"|",2),OR("PLACE")=+$P(MSG(OO),"|",3),PLACERXX=+$P($P(MSG(OO),"|",3),";",2),OR("COMM")=$P(MSG(OO),"|",17),OR("USER")=$P(MSG(OO),"|",11) I $P(MSG(OO),"|",2)'="DE",$P(MSG(OO),"|",2)'="NA" S SEND=1 D FILL Q
     12 .S PSOPLC=+$P(MSG(OO),"|",3),PSOFFL=+$P(MSG(OO),"|",4),PSOSND=1,PSOCHFFL=$P($P(MSG(OO),"|",4),"^")
     13 I $G(OR("COMM"))["^" S OR("COMM")=$P(OR("COMM"),"^",5)
     14 I PSOSND,$G(PSOCHFFL)["S",$G(OR("STAT"))="NA" D CHCS^PSOHLNE1 Q
     15 I PSOSND,'$D(^PSRX(+$G(PSOFFL),0)) S COMM="Order was not located by Pharmacy" D EN^ORERR(COMM,.MSG) D KL Q
     16 I PSOSND,$G(PDFN),PDFN'=+$P($G(^PSRX(+$G(PSOFFL),0)),"^",2) S COMM="Patient does not match" D EN^ORERR(COMM,.MSG) D KL Q
     17 I PSOSND,$G(OR("STAT"))'="DE" N PSONAS S PSONAS=$S($P($G(^PSRX(PSOFFL,"OR1")),"^",2)="":1,1:0) S $P(^PSRX(PSOFFL,"OR1"),"^",2)=PSOPLC,^PSRX("APL",PSOPLC,PSOFFL)="" D:PSONAS EN^PSOHDR("PRES",PSOFFL) D KL Q
     18 D KL
     19 I SEND,$G(OR("STAT"))="Z@" G PURGE^PSOHLNE2
     20 I SEND,$G(OR("STAT"))="ZF" G REF^PSOHLNE2
     21 I SEND,$G(OR("STAT"))'="CA",$G(OR("STAT"))'="DC",$G(OR("STAT"))'="HD",$G(OR("STAT"))'="RL",$G(OR("STAT"))'="SS" S RCOMM="Invalid Order Control Code" D EN^ORERR(RCOMM,.MSG) Q
     22 I SEND K SEND G:$G(OR("STAT"))="SS" ESTAT D EN^PSOORUTL(.OR) S PLACER=OR("PLACE"),STAT=OR("STAT"),COMM=OR("COMM") S PSOMSORR=1 D  K PSOMSORR Q
     23 .I $G(OR("FILLER"))="" D  D ERROR^PSOHLSN Q
     24 ..F EER=0:0 S EER=$O(MSG(EER)) Q:'EER  S:$P(MSG(EER),"|")="PV1" PSERRPV1=MSG(EER) S:$P(MSG(EER),"|")="PID" PSERRPID=MSG(EER) S:$P(MSG(EER),"|")="ORC"&($G(PSERRORC)="") PSERRORC=MSG(EER)
     25 .I $P(OR("FILLER"),"^",2)="R" S FILLER=$P(OR("FILLER"),"^") D EN^PSOHLSN1(FILLER,STAT,$G(OR("PHARMST")),COMM) K:$G(PSOEXFLG) PSOMSORR,PLACERXX D:$G(PSOEXFLG) EN^PSOHLSN1(FILLER,"SC","ZE","") D:$G(PSOSUSZ) SUS^PSOORUT1 K PSOSUSZ Q
     26 .D EN^PSOHLSN(PLACER,STAT,COMM) Q
     27 D KL^PSOHLSIH S RRX=1 F ZZ=0:0 S ZZ=$O(MSG(ZZ)) Q:'ZZ  S PSOSEG=$G(MSG(ZZ)),PSOTYPE=$P(PSOSEG,"|") S PSOSEG=$E(PSOSEG,5,$L(PSOSEG)) I PSOTYPE'="NTE" D @PSOTYPE
     28 I $G(PSRNFLAG) S PSOMO=0 D MISRN^PSOHLNE1 I $G(PSOMO) Q
     29 S PSRNQFLG=0 I $G(PSRNFLAG),$G(PREV) D  I $G(PSRNQFLG) S RCOMM="Duplicate Renewal Request. Order rejected by Pharmacy." D EN^ORERR(RCOMM,.MSG) D RERROR^PSOHLSN D KL^PSOHLSIH Q
     30 .I $P($G(^PSRX(PREV,"OR1")),"^",4) S PSRNQFLG=1 Q
     31 .I $O(^PS(52.41,"AQ",PREV,0)) S PSRNQFLG=1
     32 .I $G(XOFLAG),$G(DFN)'=$S($G(PFLAG):$P($G(^PS(52.41,+$G(PREV),0)),"^",2),1:$P($G(^PSRX(+$G(PREV),0)),"^",2)) S RCOMM="Patient mismatch on previous order." D EN^ORERR(RCOMM,.MSG) S XOFLAGZ=1 D RERROR^PSOHLSN D KL^PSOHLSIH Q
     33 I $G(DFN)'=+$P($G(^OR(100,+$G(PLACER),0)),"^",2) G MISX^PSOHLNE1
     34 I $G(PLACER) D NFILE
     35 D KL^PSOHLSIH
     36 Q
     37ESTAT ;
     38 D EXP^PSOHLNE1
     39 Q
     40MSH Q
     41PID S DFN=+$P(PSOSEG,"|",3)
     42 Q
     43PV1 S LOCATION=+$P(+$P(PSOSEG,"|",3),"^")
     44 S:'$D(^SC(LOCATION,0)) LOCATION=""
     45 S INPTRX=0 I $G(LOCATION) S PSINPTR=$P($G(^SC(LOCATION,0)),"^",4) I PSINPTR Q
     46 I $G(LOCATION) S INPTRX=$P($G(^SC(LOCATION,0)),"^",15)
     47 I '$G(INPTRX) S INPTRX=$O(^DG(40.8,0))
     48 I '$G(DT) S DT=$$DT^XLFDT
     49 S PSINPTR=+$$SITE^VASITE(DT,INPTRX)
     50 Q
     51DG1 S $P(PSOICD($P(PSOSEG,"|",1)),"^")=$P($P(PSOSEG,"|",3),"^")
     52 Q
     53ORC ;
     54 Q:$P(PSOSEG,"|")="DE"
     55 S:$P(PSOSEG,"|")="XO" XOFLAG=1 D ^PSOHLNE1 S:$G(PRIOR)="A" PRIOR="E" S:$G(PRIOR)="" PRIOR="R"
     56 Q
     57 ;
     58RXO I $O(MSG(ZZ,0)) D ^PSOHLNE2 G RXOPS
     59 S PSORDITE=$P($P(PSOSEG,"|"),"^",4)
     60 S PSODDRUG=$P($P(PSOSEG,"|",10),"^",4) I $G(PSODDRUG) S:'$D(^PSDRUG(PSODDRUG,0)) PSODDRUG=""
     61 S PSOXQTY=$P(PSOSEG,"|",11)
     62 S PSOREFIL=$P(PSOSEG,"|",13)
     63 S PSODYSPL=$P(PSOSEG,"|",17)
     64RXOPS S ONEFLAG=0,WPCT=1,LL=ZZ+1
     65 I $P($G(MSG(LL)),"|")="NTE" D
     66 .S ONEFLAG=1,WORDP=$S($P(MSG(LL),"|",2):$P(MSG(LL),"|",2),1:$P(MSG(LL),"|",3)) S:$P(MSG(LL),"|",4)'="" WPARRAY(WORDP,WPCT)=$P(MSG(LL),"|",4) S:$P(MSG(LL),"|",4)'="" WPCT=WPCT+1 F LLL=0:0 S LLL=$O(MSG(LL,LLL)) Q:'LLL  D
     67 ..I $G(MSG(LL,LLL))'="" S WPARRAY(WORDP,WPCT)=$G(MSG(LL,LLL)),WPCT=WPCT+1
     68 I ONEFLAG S LL=LL+1 I $P($G(MSG(LL)),"|")="NTE" D NTE^PSOHLNE1
     69 K WORDP
     70 Q
     71RXR I $P($P(PSOSEG,"|"),"^",4) S ROUTE(RRX)=$P($P(PSOSEG,"|"),"^",4) S RRX=RRX+1
     72 Q
     73OBX I $O(MSG(ZZ,0)) D OBXX^PSOHLNE2 G OBXNTE
     74 S OCOUNT=OCOUNT+1
     75 S OBXAR(OCOUNT,1)=$P(PSOSEG,"|",5)
     76OBXNTE ;
     77 S LL=ZZ+1,PSOBCT=2
     78 I $P($G(MSG(LL)),"|")="NTE" D
     79 .I $P(MSG(LL),"|",4)'="" S PSOBCT=3,OBXAR(OCOUNT,2)=$P(MSG(LL),"|",4)
     80 .F LLL=0:0 S LLL=$O(MSG(LL,LLL)) Q:'LLL  D
     81 ..I $P($G(MSG(LL,LLL)),"|",4)'="" S OBXAR(OCOUNT,PSOBCT)=$P(MSG(LL,LLL),"|",4),PSOBCT=PSOBCT+1
     82 Q
     83ZRN S PSODSC=1_"^"_$P(PSOSEG,"|",2)
     84 I $O(MSG(ZZ,0)) F T=0:0 S T=$O(MSG(ZZ,T)) Q:'T  S PSODSC(T)=MSG(ZZ,T)
     85 K T
     86 Q
     87 ;
     88ZRX D ZRX^PSOHLNE1
     89 Q
     90 ;
     91ZCL D ZCL^PSOHLNE1
     92 Q
     93ZSC D CP^PSOHLNE1
     94 Q
     95NFILE ;
     96 I $G(PSODSC) D ^PSONVNEW Q  ;adds non-va med to #55
     97 ;
     98 K DD,DO,DIC S DLAYGO="52.41",DIC="^PS(52.41,",DIC(0)="L",X=PLACER,DIC("DR")="1////"_DFN_";2////"_PSOOC_";6////"_$G(EFFECT)_";12////"_$G(PSOXQTY)_";25////"_$G(PRIOR)
     99 S DIC("DR")=DIC("DR")_";22////"_$G(PSORSO)_";22.1////"_$G(PREV)_";19////"_$G(ROUTING)_";17////"_$G(SERV)_";7////"_$G(NATURE)_";13////"_$G(PSOREFIL)_";1.1////"_$G(LOCATION)_";117////"_$G(DSIG)
     100 D FILE^DICN K DIC,DR I Y<0 Q
     101 S PENDING=+Y
     102 S $P(^PS(52.41,PENDING,0),"^",4)=$S($G(ENTERED):+$G(ENTERED),1:""),$P(^(0),"^",5)=$S($G(PROV):+$G(PROV),1:""),$P(^(0),"^",8)=$S($G(PSORDITE):+$G(PSORDITE),1:""),$P(^(0),"^",9)=$S($G(PSODDRUG):+$G(PSODDRUG),1:""),$P(^(0),"^",15)=$G(ROUTE)
     103 S ^PS(52.41,PENDING,"IBQ")=$G(PSOIBY)
     104 I $G(PSODYSPL)'="",$E(PSODYSPL)?1A S PSODYSPL=$E(PSODYSPL,2,$L(PSODYSPL))
     105 S $P(^PS(52.41,PENDING,"INI"),"^")=$G(PSINPTR),$P(^(0),"^",12)=$G(PSOLOG),$P(^(0),"^",22)=$G(PSODYSPL)
     106 I $G(QCOUNT) S ^PS(52.41,PENDING,1,0)="^52.413^"_QCOUNT_"^"_QCOUNT
     107 S PSOQWX=$G(PSODDRUG) D:'$G(PSOQWX) OID^PSOHLNE1
     108 F PP=0:0 S PP=$O(Q1I(PP)) Q:'PP  S ^PS(52.41,PENDING,1,PP,0)=$S($G(PSOQWX)&($G(PSOLQ1II(PP))):Q1I(PP),$G(PSOQWX)&($G(PSOLQ1IX(PP))'="")&('$G(PSOLQ1II(PP))):PSOLQ1IX(PP),1:PSOLQ1I(PP))
     109 F EE=0:0 S EE=$O(QTARRAY(EE)) Q:'EE  S ^PS(52.41,PENDING,1,EE,1)=QTARRAY(EE),^PS(52.41,PENDING,1,EE,2)=$S($G(PSOQWX)&($G(PSOLQ1II(EE))):$G(QTARRAY2(EE)),$G(PSOQWX)&($G(PSOLQ1IX(EE))'="")&('$G(PSOLQ1II(EE))):PSOLQ1IX(EE),1:$G(PSOLQ1I(EE))) D
     110 .S $P(^PS(52.41,PENDING,1,EE,1),"^",8)=+$G(ROUTE(EE))
     111 S:$P($G(^PS(52.41,PENDING,1,1,1)),"^",3) $P(^PS(52.41,PENDING,0),"^",18)=$E($P($G(^PS(52.41,PENDING,1,1,1)),"^",3),1,7)
     112 D STUFF^PSOHLNE2
     113 D ^PSOHLPII
     114 S LL=0 I $O(WPARRAY(6,0)) F LLL=0:0 S LLL=$O(WPARRAY(6,LLL)) Q:'LLL  S LL=LL+1 S ^PS(52.41,PENDING,3,LL,0)=$G(WPARRAY(6,LLL))
     115 I LL S ^PS(52.41,PENDING,3,0)="^52.42^"_LL_"^"_LL
     116 S LL=0 I $O(WPARRAY(7,0)) F LLL=0:0 S LLL=$O(WPARRAY(7,LLL)) Q:'LLL  S LL=LL+1 S ^PS(52.41,PENDING,"INS1",LL,0)=$G(WPARRAY(7,LLL))
     117 I LL S ^PS(52.41,PENDING,"INS1",0)="^^"_LL_"^"_LL_"^"_$G(DT)_"^"
     118 I $P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^")'="" S $P(^PS(52.41,PENDING,"INS"),"^",2)=$S($O(^PS(52.41,PENDING,"INS1",0)):1,1:0)
     119 I $G(OCOUNT) S ^PS(52.41,PENDING,"OBX",0)="^52.4118A^"_OCOUNT_"^"_OCOUNT F OCOUNT=1:1:OCOUNT D
     120 .S ^PS(52.41,PENDING,"OBX",OCOUNT,0)=$G(OBXAR(OCOUNT,1))
     121 .D USER^PSOORFI2(+$G(PROV)) S ^PS(52.41,PENDING,"OBX",OCOUNT,1)=USER1 K USER1
     122 .S PSOBCT=1 F LLL=2:1 Q:'$D(OBXAR(OCOUNT,LLL))  S ^PS(52.41,PENDING,"OBX",OCOUNT,2,PSOBCT,0)=OBXAR(OCOUNT,LLL),^PS(52.41,PENDING,"OBX",OCOUNT,2,0)="^^"_PSOBCT_"^"_PSOBCT_"^"_$G(DT)_"^"
     123 D ^PSOHLPIS
     124 K DIK S DIK="^PS(52.41,",DA=PENDING D IX^DIK
     125 I $G(PSOOC)="RNW",$G(PREV),$D(^PSRX(+$G(PREV),0)) D EN^PSOHLSN1(PREV,"SC","ZZ","")
     126 S PSOMSORR=1,IPPLACER=$P($G(^PS(52.41,PENDING,0)),"^") I IPPLACER D
     127 .I '$G(XOFLAG) D EN^PSOHLSN(IPPLACER,"OK","IP") Q
     128 .D EN^PSOHLSN(IPPLACER,"XR","IP") I $G(PFLAG) D DCP^PSOHLSN Q
     129 .K PSOMSORR I $D(^PSRX(+$G(PREV),0)) D  D EN^PSOHLSN1(PREV,"RP","","","A")
     130 ..S $P(^PSRX(PREV,"STA"),"^")=15,$P(^PSRX(PREV,3),"^",5)=DT,$P(^PSRX(PREV,3),"^",10)=$P(^PSRX(PREV,3),"^")  ;;PSO*7*249
     131 ..D REVERSE^PSOBPSU1(PREV,,"DC",7),CAN^PSOTPCAN(PREV),CAN^PSOUTL(PREV)
     132 ..D CNT^PSOHLNE1
     133 ..D:$G(^PS(52.41,PENDING,1,1,0))=""&($P($G(^PS(52.41,PENDING,1,1,1)),"^")="")&($G(^PS(52.41,PENDING,"SIG",1,0))="")
     134 ...N FSIG,BSIG
     135 ...I '$P($G(^PSRX(PREV,"SIG")),"^",2),$P($G(^("SIG")),"^")'="" D
     136 ....D EN3^PSOUTLA1(PREV,70)
     137 ....I $G(BSIG(1))'="" S ^PS(52.41,PENDING,"SIG",1,0)=$G(BSIG(1)) I $O(BSIG(1)) F EE=1:0 S EE=$O(BSIG(EE)) Q:'EE  S ^PS(52.41,PENDING,"SIG",EE,0)=$G(BSIG(EE))
     138 ...I $P($G(^PSRX(PREV,"SIG")),"^",2),$G(^PSRX(PREV,"SIG1",1,0))'="" D
     139 ....D FSIG^PSOUTLA("R",PREV,70)
     140 ....I $G(FSIG(1))'="" S ^PS(52.41,PENDING,"SIG",1,0)=$G(FSIG(1)) I $O(FSIG(1)) F EE=1:0 S EE=$O(FSIG(EE)) Q:'EE  S ^PS(52.41,PENDING,"SIG",EE,0)=$G(FSIG(EE))
     141 ...F EE=0:0 S EE=$O(^PS(52.41,PENDING,"SIG",EE)) Q:'EE  S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_EE_"^"_EE
     142 D CSET^PSODIAG
     143 Q
     144SPDFN S PDFN=$P($G(MSG(OO)),"|",4) Q
     145KL K PSOPLC,PSOFFL,PSOSND
     146 Q
     147FILL ;
     148 S (PSOFILNM,OR("PSOFILNM"))=$P($P(MSG(OO),"|",4),"^")
     149 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLPII.m

    r613 r623  
    1 PSOHLPII        ;BIR/RTR-Parse out and create CPRS Instructions ;7/21/96
    2         ;;7.0;OUTPATIENT PHARMACY;**46,225**;DEC 1997;Build 29
    3         ;External reference to File #50.7 supported by DBIA 2223
    4         ;External reference to File #51 supported by DBIA 2224
    5         ;External reference to File #51.1 supported by DBIA 2225
    6         ;External reference to File #51.2 supported by DBIA 2226
    7         ;External reference to File #50.606 supported by DBIA 2174
    8 EN      ;
    9         Q:'$D(^PS(52.41,PENDING,1,0))
    10         N PISI,PSOFX,SDF,SZZ,ZZS,ZZSB,SSZZ,SCHHOLD,GGGZ,SGLFLAG,SGLOOP,ZSCHED,SPFG,PSNOUN,MEDEXP,PSDUR,NOUN,SCHED,INTERVAL,SIG0,SIG2,SIG3,SDL,WW,TODOSE,PDAYS,WWFL,PSOCJI
    11         N SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2
    12         N SIG
    13         F PISI=0:0 S PISI=$O(^PS(52.41,PENDING,1,PISI)) Q:'PISI  D:$D(^(PISI,0))
    14         .S PSOFX("DOSE",PISI)=$P($G(^PS(52.41,PENDING,1,PISI,2)),"^") I $P($G(^(2)),"^",2)'="" S PSOFX("DOSE ORDERED",PISI)=$P($G(^(2)),"^",2)
    15         .S PSOFX("SCHEDULE",PISI)=$P($G(^PS(52.41,PENDING,1,PISI,1)),"^"),PSOFX("ROUTE",PISI)=$P($G(^(1)),"^",8),PSOFX("DURATION",PISI)=$P($G(^(1)),"^",2),PSOFX("NOUN",PISI)=$P($G(^(1)),"^",5),PSOFX("CONJUNCTION",PISI)=$P($G(^(1)),"^",6)
    16         .I $G(PSOFX("DURATION",PISI)) S PSOFX("DURATION",PISI)="D"_$G(PSOFX("DURATION",PISI))
    17         .I $G(PSOFX("DURATION",PISI))'="" S PSOFX("DURATION",PISI)=$E(PSOFX("DURATION",PISI),2,999)_$E(PSOFX("DURATION",PISI))
    18         S TODOSE=0 F WW=0:0 S WW=$O(PSOFX("DOSE",WW)) Q:'WW  S TODOSE=WW
    19         Q:'TODOSE
    20         S SIGDS=+$P($G(^PS(50.7,+$G(PSORDITE),0)),"^",2),VERB=$P($G(^PS(50.606,SIGDS,"MISC")),"^"),PREP=$P($G(^("MISC")),"^",3)
    21         F SSS=1:1:TODOSE D
    22         .S SIG0(SSS)=$S($G(PSOFX("DOSE ORDERED",SSS))'="":$G(PSOFX("DOSE ORDERED",SSS)),1:$G(PSOFX("DOSE",SSS)))
    23         .S PSNOUN(SSS)=$G(PSOFX("NOUN",SSS))
    24         .;S PSOROUTE(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",2)'="":$P(^(0),"^",2),$P($G(^(0)),"^",3)'="":$P(^(0),"^",3),1:$P($G(^(0)),"^")) S MEDEXP(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",2)="":0,1:1)
    25         .S PSOROUTE(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",3)'="":$P($G(^(0)),"^",3),1:$P($G(^(0)),"^"))
    26         .S PDAYS(SSS)=$G(PSOFX("DURATION",SSS))
    27         .I $G(PSOFX("DURATION",SSS))'="",($E(PSOFX("DURATION",SSS),$L(PSOFX("DURATION",SSS)))'?1A) S PDAYS(SSS)=PDAYS(SSS)_"D"
    28         .S PSDUR(SSS)=$S($G(PDAYS(SSS))="":"NULL",1:"FOR "_$E($G(PDAYS(SSS)),1,($L($G(PDAYS(SSS)))-1))) D  I PSDUR(SSS)'="NULL" S PSDUR(SSS)=PSDUR(SSS)_" "_INTERVAL
    29         ..I PSDUR(SSS)'="NULL" S INTERVAL=$E(PDAYS(SSS),$L(PDAYS(SSS))),INTERVAL=$S(INTERVAL="D":"DAYS",INTERVAL="W":"WEEKS",INTERVAL="H":"HOURS",INTERVAL="L":"MONTHS",INTERVAL="M":"MINUTES",INTERVAL="S":"SECONDS",1:"") D
    30         ...I $G(INTERVAL)'="",$G(PSOFX("DURATION",SSS)),$G(PSOFX("DURATION",SSS))'>1 S INTERVAL=$E(INTERVAL,1,($L(INTERVAL)-1))
    31         F GGG=1:1:TODOSE S ZSCHED(GGG)=$G(PSOFX("SCHEDULE",GGG))
    32         ;.I $G(ZSCHED(GGG))="" S SCHED(GGG)="" Q
    33         ;.S SGLFLAG=0 F WW=0:0 S WW=$O(^PS(51.1,"B",ZSCHED(GGG),WW)) Q:'WW!($G(SGLFLAG))  I $P($G(^PS(51.1,WW,0)),"^",8)'="" S SCHED(GGG)=$P($G(^(0)),"^",8),SGLFLAG=1
    34         ;.Q:$G(SGLFLAG)
    35         ;.I $G(^PS(51,"A",ZSCHED(GGG)))'="" S SCHED(GGG)=$P(^(ZSCHED(GGG)),"^") Q
    36         ;.S ZZSB=0 F ZZS=1:1:$L(ZSCHED(GGG)) S SZZ=$E(ZSCHED(GGG),ZZS) I SZZ=" " S ZZSB=ZZSB+1
    37         ;.S ZZSB=ZZSB+1
    38         ;.K SCHHOLD F GGGZ=1:1:ZZSB S (SDL,SCHHOLD(GGGZ))=$P(ZSCHED(GGG)," ",GGGZ) D
    39         ;..Q:$G(SDL)=""
    40         ;..S SGLFLAG=0 F WW=0:0 S WW=$O(^PS(51.1,"B",SDL,WW)) Q:'WW!($G(SGLFLAG))  I $P($G(^PS(51.1,WW,0)),"^",8)'="" S SCHHOLD(GGGZ)=$P($G(^(0)),"^",8),SGLFLAG=1
    41         ;..Q:$G(SGLFLAG)
    42         ;..I $G(^PS(51,"A",SDL))'="" S SCHHOLD(GGGZ)=$P(^(SDL),"^")
    43         ;.S SCHED(GGG)="",SGLFLAG=0 F WW=1:1:ZZSB S SCHED(GGG)=SCHED(GGG)_$S($G(SGLFLAG):" ",1:"")_$G(SCHHOLD(WW)),SGLFLAG=1
    44         S PREP=""
    45         F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF  D
    46         .K PSOSG1,PSOSG2 D VERB D:$G(PSNOUN(FFF))'=""&('$G(PSOSG1)) SSS
    47         .D FRAC
    48         .S SIG2(FFF)=$S(VERB'=""&('$G(PSOSG1)):VERB_" ",1:"")_$S($G(PSOFX("DOSE ORDERED",FFF))'="":$S($G(PSOFRAC)'="":$G(PSOFRAC),1:$G(PSOFX("DOSE ORDERED",FFF)))_" ",1:$G(PSOFX("DOSE",FFF))_" ")
    49         .K PSOFRAC,PSOFRACX
    50         .S SIG2(FFF)=SIG2(FFF)_$S($G(PSNOUN(FFF))'=""&('$G(PSOSG2)):$G(PSNOUN(FFF))_" ",1:"")_$S(PREP'=""&($G(MEDEXP(FFF))):PREP_" ",1:"")
    51         .S SIG2(FFF)=SIG2(FFF)_$S(PSOROUTE(FFF)'="":PSOROUTE(FFF)_" ",1:"")
    52         .;S SIG2(FFF)=SIG2(FFF)_$S(SCHED(FFF)'="":SCHED(FFF)_" ",1:"")_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_" ",1:"")_$S($G(PSOFX("CONJUNCTION",FFF))="A":"AND",$G(PSOFX("CONJUNCTION",FFF))="T":"THEN",$G(PSOFX("CONJUNCTION",FFF))="S":"THEN",1:"")
    53         .S SIG2(FFF)=SIG2(FFF)_$S(ZSCHED(FFF)'="":ZSCHED(FFF)_$S($G(PSDUR(FFF))="NULL"&($G(PSOFX("CONJUNCTION",FFF))="")&('$O(SIG0(FFF))):"",1:" "),1:"")
    54         .S PSOCJI=$G(PSOFX("CONJUNCTION",FFF))
    55         .S SIG2(FFF)=SIG2(FFF)_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_$S($G(PSOFX("CONJUNCTION",FFF))=""&('$O(SIG0(FFF))):"",1:", "),1:"")_$S($G(PSOCJI)="A":"AND",$G(PSOCJI)="T":"THEN",$G(PSOCJI)="S":"THEN",$G(PSOCJI)="X":"EXCEPT",1:"")
    56         .K PSOSG1,PSOSG2
    57         .K PSOUCS S SIG2(FFF)=$$UPPER(SIG2(FFF)) K PSOUCS
    58         ;I $G(PSOFX("INS"))'="" S TODOSE=TODOSE+1,SIG2(TODOSE)=$G(PSOFX("INS"))
    59 STUFF   ;
    60         S DCOUNT=0
    61         I '$D(SIG2(1)) G QUIT
    62         ;I '$O(SIG2(1)),$L(SIG2(1))<71 S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_1_"^"_1 S ^PS(52.41,PENDING,"SIG",1,0)=SIG2(1) G QUIT
    63         S (VAR,VAR1)="",II=1
    64         F FF=0:0 S FF=$O(SIG2(FF)) Q:'FF  S CT=0 F NN=1:1:$L(SIG2(FF)) I $E(SIG2(FF),NN)=" "!($L(SIG2(FF))=NN) S CT=CT+1 D  I $L(VAR)>200 S SIG(II)=LIM_" ",II=II+1,VAR=VAR1
    65         .S VAR1=$P(SIG2(FF)," ",(CT))
    66         .S LIM=VAR
    67         .S VAR=$S(VAR="":VAR1,1:VAR_" "_VAR1)
    68         I $G(VAR)'="" S SIG(II)=VAR
    69         F II=0:0 S II=$O(SIG(II)) Q:'II  S DCOUNT=DCOUNT+1 S ^PS(52.41,PENDING,2,DCOUNT,0)=$$UNESC^ORHLESC(SIG(II))
    70         I DCOUNT S ^PS(52.41,PENDING,2,0)="^52.419A^"_DCOUNT_"^"_DCOUNT
    71 QUIT    K SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2 Q
    72 SIG1    ;
    73         F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF  S SIG2(FFF)=SIG0(FFF)
    74         Q
    75 DAYS    I +$E($P(SIG1(TT),"^",2))!($E($P(SIG1(TT),"^",2))=0) S $P(SIG1(TT),"^",2)="D"_$P(SIG1(TT),"^",2)
    76         Q
    77 NON     ;
    78         I $P($G(SIG0(SSS)),"&",2)'="" S PSNOUN(SSS)=$P($G(SIG0(SSS)),"&",2) Q
    79         Q
    80         F NOUN=0:0 S NOUN=$O(^PS(50.606,SIGDS,"NOUN",NOUN)) Q:'NOUN!($G(PSNOUN(SSS))'="")  I $P($G(^PS(50.606,SIGDS,"NOUN",NOUN,0)),"^")'="" S PSNOUN(SSS)=$P(^(0),"^")
    81         Q
    82 VERB    ;Check if verb and noun need to be added to SIG
    83         K PSOLCS,PSOUCS,PSOISL,PSOVL
    84         I $G(VERB)'="" S PSOVL=$L(VERB),PSOISL=$E($G(SIG0(FFF)),1,$G(PSOVL)) I $G(PSOISL)'="" D
    85         .S PSOUCS=VERB
    86         .S PSOUCS=$$UPPER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q
    87         .S PSOUCS=$$LOWER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q
    88         .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOUCS=PSOISL S PSOSG1=1 Q
    89         I $G(PSNOUN(FFF))="" G VERBEX
    90         S PSOISL=$G(SIG0(FFF)) I $G(PSOISL)="" G VERBEX
    91         S PSOVL=$F(PSNOUN(FFF),"(")
    92         I $G(PSOVL)>2 S PSOUCS=$E(PSNOUN(FFF),1,(PSOVL-2))
    93         I $G(PSOVL)'>2 S PSOUCS=PSNOUN(FFF)
    94         I $G(PSOISL)'="" D
    95         .S PSOUCS=$$UPPER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q
    96         .S PSOUCS=$$LOWER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q
    97         .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOISL[PSOUCS S PSOSG2=1
    98 VERBEX  K PSOLCS,PSOUCS,PSOISL,PSOVL Q
    99         ;
    100 UPPER(PSOUCS)   ;
    101         Q $TR(PSOUCS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    102         ;
    103 LOWER(PSOLCS)   ;
    104         Q $TR(PSOLCS,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
    105         Q
    106         ;
    107 SSS     ;
    108         K PSOFNL,PSOFNLF,PSOFNLX
    109         Q:$G(PSNOUN(FFF))=""
    110         Q:$L(PSNOUN(FFF))'>3
    111         Q:'$G(PSOFX("DOSE ORDERED",FFF))
    112         ;Q:$G(PSOFX("DOSE ORDERED",FFF))>1
    113         S PSOFNL=$E(PSNOUN(FFF),($L(PSNOUN(FFF))-2),$L(PSNOUN(FFF)))
    114         I $G(PSOFNL)="(S)"!($G(PSOFNL)="(s)") D
    115         .I $G(PSOFX("DOSE ORDERED",FFF))'>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3))
    116         .I $G(PSOFX("DOSE ORDERED",FFF))>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3))_$E(PSOFNL,2)
    117         Q
    118 FRAC    ;
    119         K PSOFRAC,PSOFRACX,PSOFRAC1,PSOFRAC2
    120         I $G(PSOFX("DOSE ORDERED",FFF))="" Q
    121         I $G(PSOFX("DOSE ORDERED",FFF))'["." S (PSOFRAC1,PSOFRAC)=$G(PSOFX("DOSE ORDERED",FFF)) D NUM D  G FRACQ
    122         .I $G(PSOFRAC1)=$G(PSOFRAC) K PSOFRAC,PSOFRAC1 Q
    123         .S PSOFRAC=$G(PSOFRAC1)
    124         S PSOFRAC1=$P(PSOFX("DOSE ORDERED",FFF),"."),PSOFRAC2=$P(PSOFX("DOSE ORDERED",FFF),".",2)
    125         S PSOFRACX="."_$G(PSOFRAC2)
    126         S PSOFRAC=$S(PSOFRACX=".5":"ONE-HALF",PSOFRACX=".25":"ONE-FOURTH",PSOFRACX=".33":"ONE-THIRD",PSOFRACX=".34":"ONE-THIRD",PSOFRACX=".50":"ONE-HALF",PSOFRACX=".66":"TWO-THIRDS",PSOFRACX=".67":"TWO-THIRDS",PSOFRACX=".75":"THREE-FOURTHS",1:"")
    127         I $G(PSOFRAC)="" K PSOFRAC G FRACQ
    128         I $G(PSOFRAC1)'="",+$G(PSOFRAC1) D NUM S PSOFRAC=$G(PSOFRAC1)_" AND "_$G(PSOFRAC)
    129 FRACQ   K PSOFRAC1,PSOFRAC2
    130         Q
    131 NUM     ;
    132         Q:$G(PSOFRAC1)=""
    133         S PSOFRAC1=$S(PSOFRAC1="1":"ONE",PSOFRAC1="2":"TWO",PSOFRAC1="3":"THREE",PSOFRAC1="4":"FOUR",PSOFRAC1="5":"FIVE",PSOFRAC1="6":"SIX",PSOFRAC1="7":"SEVEN",PSOFRAC1="8":"EIGHT",PSOFRAC1="9":"NINE",PSOFRAC1="10":"TEN",1:PSOFRAC1)
    134         Q
     1PSOHLPII ;BIR/RTR-Parse out and create CPRS Instructions ;7/21/96
     2 ;;7.0;OUTPATIENT PHARMACY;**46**;DEC 1997
     3 ;External reference to File #50.7 supported by DBIA 2223
     4 ;External reference to File #51 supported by DBIA 2224
     5 ;External reference to File #51.1 supported by DBIA 2225
     6 ;External reference to File #51.2 supported by DBIA 2226
     7 ;External reference to File #50.606 supported by DBIA 2174
     8EN ;
     9 Q:'$D(^PS(52.41,PENDING,1,0))
     10 N PISI,PSOFX,SDF,SZZ,ZZS,ZZSB,SSZZ,SCHHOLD,GGGZ,SGLFLAG,SGLOOP,ZSCHED,SPFG,PSNOUN,MEDEXP,PSDUR,NOUN,SCHED,INTERVAL,SIG0,SIG2,SIG3,SDL,WW,TODOSE,PDAYS,WWFL,PSOCJI
     11 N SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2
     12 N SIG
     13 F PISI=0:0 S PISI=$O(^PS(52.41,PENDING,1,PISI)) Q:'PISI  D:$D(^(PISI,0))
     14 .S PSOFX("DOSE",PISI)=$P($G(^PS(52.41,PENDING,1,PISI,2)),"^") I $P($G(^(2)),"^",2)'="" S PSOFX("DOSE ORDERED",PISI)=$P($G(^(2)),"^",2)
     15 .S PSOFX("SCHEDULE",PISI)=$P($G(^PS(52.41,PENDING,1,PISI,1)),"^"),PSOFX("ROUTE",PISI)=$P($G(^(1)),"^",8),PSOFX("DURATION",PISI)=$P($G(^(1)),"^",2),PSOFX("NOUN",PISI)=$P($G(^(1)),"^",5),PSOFX("CONJUNCTION",PISI)=$P($G(^(1)),"^",6)
     16 .I $G(PSOFX("DURATION",PISI)) S PSOFX("DURATION",PISI)="D"_$G(PSOFX("DURATION",PISI))
     17 .I $G(PSOFX("DURATION",PISI))'="" S PSOFX("DURATION",PISI)=$E(PSOFX("DURATION",PISI),2,999)_$E(PSOFX("DURATION",PISI))
     18 S TODOSE=0 F WW=0:0 S WW=$O(PSOFX("DOSE",WW)) Q:'WW  S TODOSE=WW
     19 Q:'TODOSE
     20 S SIGDS=+$P($G(^PS(50.7,+$G(PSORDITE),0)),"^",2),VERB=$P($G(^PS(50.606,SIGDS,"MISC")),"^"),PREP=$P($G(^("MISC")),"^",3)
     21 F SSS=1:1:TODOSE D
     22 .S SIG0(SSS)=$S($G(PSOFX("DOSE ORDERED",SSS))'="":$G(PSOFX("DOSE ORDERED",SSS)),1:$G(PSOFX("DOSE",SSS)))
     23 .S PSNOUN(SSS)=$G(PSOFX("NOUN",SSS))
     24 .;S PSOROUTE(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",2)'="":$P(^(0),"^",2),$P($G(^(0)),"^",3)'="":$P(^(0),"^",3),1:$P($G(^(0)),"^")) S MEDEXP(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",2)="":0,1:1)
     25 .S PSOROUTE(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",3)'="":$P($G(^(0)),"^",3),1:$P($G(^(0)),"^"))
     26 .S PDAYS(SSS)=$G(PSOFX("DURATION",SSS))
     27 .I $G(PSOFX("DURATION",SSS))'="",($E(PSOFX("DURATION",SSS),$L(PSOFX("DURATION",SSS)))'?1A) S PDAYS(SSS)=PDAYS(SSS)_"D"
     28 .S PSDUR(SSS)=$S($G(PDAYS(SSS))="":"NULL",1:"FOR "_$E($G(PDAYS(SSS)),1,($L($G(PDAYS(SSS)))-1))) D  I PSDUR(SSS)'="NULL" S PSDUR(SSS)=PSDUR(SSS)_" "_INTERVAL
     29 ..I PSDUR(SSS)'="NULL" S INTERVAL=$E(PDAYS(SSS),$L(PDAYS(SSS))),INTERVAL=$S(INTERVAL="D":"DAYS",INTERVAL="W":"WEEKS",INTERVAL="H":"HOURS",INTERVAL="L":"MONTHS",INTERVAL="M":"MINUTES",INTERVAL="S":"SECONDS",1:"") D
     30 ...I $G(INTERVAL)'="",$G(PSOFX("DURATION",SSS)),$G(PSOFX("DURATION",SSS))'>1 S INTERVAL=$E(INTERVAL,1,($L(INTERVAL)-1))
     31 F GGG=1:1:TODOSE S ZSCHED(GGG)=$G(PSOFX("SCHEDULE",GGG))
     32 ;.I $G(ZSCHED(GGG))="" S SCHED(GGG)="" Q
     33 ;.S SGLFLAG=0 F WW=0:0 S WW=$O(^PS(51.1,"B",ZSCHED(GGG),WW)) Q:'WW!($G(SGLFLAG))  I $P($G(^PS(51.1,WW,0)),"^",8)'="" S SCHED(GGG)=$P($G(^(0)),"^",8),SGLFLAG=1
     34 ;.Q:$G(SGLFLAG)
     35 ;.I $G(^PS(51,"A",ZSCHED(GGG)))'="" S SCHED(GGG)=$P(^(ZSCHED(GGG)),"^") Q
     36 ;.S ZZSB=0 F ZZS=1:1:$L(ZSCHED(GGG)) S SZZ=$E(ZSCHED(GGG),ZZS) I SZZ=" " S ZZSB=ZZSB+1
     37 ;.S ZZSB=ZZSB+1
     38 ;.K SCHHOLD F GGGZ=1:1:ZZSB S (SDL,SCHHOLD(GGGZ))=$P(ZSCHED(GGG)," ",GGGZ) D
     39 ;..Q:$G(SDL)=""
     40 ;..S SGLFLAG=0 F WW=0:0 S WW=$O(^PS(51.1,"B",SDL,WW)) Q:'WW!($G(SGLFLAG))  I $P($G(^PS(51.1,WW,0)),"^",8)'="" S SCHHOLD(GGGZ)=$P($G(^(0)),"^",8),SGLFLAG=1
     41 ;..Q:$G(SGLFLAG)
     42 ;..I $G(^PS(51,"A",SDL))'="" S SCHHOLD(GGGZ)=$P(^(SDL),"^")
     43 ;.S SCHED(GGG)="",SGLFLAG=0 F WW=1:1:ZZSB S SCHED(GGG)=SCHED(GGG)_$S($G(SGLFLAG):" ",1:"")_$G(SCHHOLD(WW)),SGLFLAG=1
     44 S PREP=""
     45 F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF  D
     46 .K PSOSG1,PSOSG2 D VERB D:$G(PSNOUN(FFF))'=""&('$G(PSOSG1)) SSS
     47 .D FRAC
     48 .S SIG2(FFF)=$S(VERB'=""&('$G(PSOSG1)):VERB_" ",1:"")_$S($G(PSOFX("DOSE ORDERED",FFF))'="":$S($G(PSOFRAC)'="":$G(PSOFRAC),1:$G(PSOFX("DOSE ORDERED",FFF)))_" ",1:$G(PSOFX("DOSE",FFF))_" ")
     49 .K PSOFRAC,PSOFRACX
     50 .S SIG2(FFF)=SIG2(FFF)_$S($G(PSNOUN(FFF))'=""&('$G(PSOSG2)):$G(PSNOUN(FFF))_" ",1:"")_$S(PREP'=""&($G(MEDEXP(FFF))):PREP_" ",1:"")
     51 .S SIG2(FFF)=SIG2(FFF)_$S(PSOROUTE(FFF)'="":PSOROUTE(FFF)_" ",1:"")
     52 .;S SIG2(FFF)=SIG2(FFF)_$S(SCHED(FFF)'="":SCHED(FFF)_" ",1:"")_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_" ",1:"")_$S($G(PSOFX("CONJUNCTION",FFF))="A":"AND",$G(PSOFX("CONJUNCTION",FFF))="T":"THEN",$G(PSOFX("CONJUNCTION",FFF))="S":"THEN",1:"")
     53 .S SIG2(FFF)=SIG2(FFF)_$S(ZSCHED(FFF)'="":ZSCHED(FFF)_$S($G(PSDUR(FFF))="NULL"&($G(PSOFX("CONJUNCTION",FFF))="")&('$O(SIG0(FFF))):"",1:" "),1:"")
     54 .S PSOCJI=$G(PSOFX("CONJUNCTION",FFF))
     55 .S SIG2(FFF)=SIG2(FFF)_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_$S($G(PSOFX("CONJUNCTION",FFF))=""&('$O(SIG0(FFF))):"",1:", "),1:"")_$S($G(PSOCJI)="A":"AND",$G(PSOCJI)="T":"THEN",$G(PSOCJI)="S":"THEN",$G(PSOCJI)="X":"EXCEPT",1:"")
     56 .K PSOSG1,PSOSG2
     57 .K PSOUCS S SIG2(FFF)=$$UPPER(SIG2(FFF)) K PSOUCS
     58 ;I $G(PSOFX("INS"))'="" S TODOSE=TODOSE+1,SIG2(TODOSE)=$G(PSOFX("INS"))
     59STUFF ;
     60 S DCOUNT=0
     61 I '$D(SIG2(1)) G QUIT
     62 ;I '$O(SIG2(1)),$L(SIG2(1))<71 S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_1_"^"_1 S ^PS(52.41,PENDING,"SIG",1,0)=SIG2(1) G QUIT
     63 S (VAR,VAR1)="",II=1
     64 F FF=0:0 S FF=$O(SIG2(FF)) Q:'FF  S CT=0 F NN=1:1:$L(SIG2(FF)) I $E(SIG2(FF),NN)=" "!($L(SIG2(FF))=NN) S CT=CT+1 D  I $L(VAR)>200 S SIG(II)=LIM_" ",II=II+1,VAR=VAR1
     65 .S VAR1=$P(SIG2(FF)," ",(CT))
     66 .S LIM=VAR
     67 .S VAR=$S(VAR="":VAR1,1:VAR_" "_VAR1)
     68 I $G(VAR)'="" S SIG(II)=VAR
     69 F II=0:0 S II=$O(SIG(II)) Q:'II  S DCOUNT=DCOUNT+1 S ^PS(52.41,PENDING,2,DCOUNT,0)=SIG(II)
     70 I DCOUNT S ^PS(52.41,PENDING,2,0)="^52.419A^"_DCOUNT_"^"_DCOUNT
     71QUIT K SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2 Q
     72SIG1 ;
     73 F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF  S SIG2(FFF)=SIG0(FFF)
     74 Q
     75DAYS I +$E($P(SIG1(TT),"^",2))!($E($P(SIG1(TT),"^",2))=0) S $P(SIG1(TT),"^",2)="D"_$P(SIG1(TT),"^",2)
     76 Q
     77NON ;
     78 I $P($G(SIG0(SSS)),"&",2)'="" S PSNOUN(SSS)=$P($G(SIG0(SSS)),"&",2) Q
     79 Q
     80 F NOUN=0:0 S NOUN=$O(^PS(50.606,SIGDS,"NOUN",NOUN)) Q:'NOUN!($G(PSNOUN(SSS))'="")  I $P($G(^PS(50.606,SIGDS,"NOUN",NOUN,0)),"^")'="" S PSNOUN(SSS)=$P(^(0),"^")
     81 Q
     82VERB ;Check if verb and noun need to be added to SIG
     83 K PSOLCS,PSOUCS,PSOISL,PSOVL
     84 I $G(VERB)'="" S PSOVL=$L(VERB),PSOISL=$E($G(SIG0(FFF)),1,$G(PSOVL)) I $G(PSOISL)'="" D
     85 .S PSOUCS=VERB
     86 .S PSOUCS=$$UPPER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q
     87 .S PSOUCS=$$LOWER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q
     88 .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOUCS=PSOISL S PSOSG1=1 Q
     89 I $G(PSNOUN(FFF))="" G VERBEX
     90 S PSOISL=$G(SIG0(FFF)) I $G(PSOISL)="" G VERBEX
     91 S PSOVL=$F(PSNOUN(FFF),"(")
     92 I $G(PSOVL)>2 S PSOUCS=$E(PSNOUN(FFF),1,(PSOVL-2))
     93 I $G(PSOVL)'>2 S PSOUCS=PSNOUN(FFF)
     94 I $G(PSOISL)'="" D
     95 .S PSOUCS=$$UPPER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q
     96 .S PSOUCS=$$LOWER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q
     97 .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOISL[PSOUCS S PSOSG2=1
     98VERBEX K PSOLCS,PSOUCS,PSOISL,PSOVL Q
     99 ;
     100UPPER(PSOUCS) ;
     101 Q $TR(PSOUCS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     102 ;
     103LOWER(PSOLCS) ;
     104 Q $TR(PSOLCS,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
     105 Q
     106 ;
     107SSS ;
     108 K PSOFNL,PSOFNLF,PSOFNLX
     109 Q:$G(PSNOUN(FFF))=""
     110 Q:$L(PSNOUN(FFF))'>3
     111 Q:'$G(PSOFX("DOSE ORDERED",FFF))
     112 ;Q:$G(PSOFX("DOSE ORDERED",FFF))>1
     113 S PSOFNL=$E(PSNOUN(FFF),($L(PSNOUN(FFF))-2),$L(PSNOUN(FFF)))
     114 I $G(PSOFNL)="(S)"!($G(PSOFNL)="(s)") D
     115 .I $G(PSOFX("DOSE ORDERED",FFF))'>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3))
     116 .I $G(PSOFX("DOSE ORDERED",FFF))>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3))_$E(PSOFNL,2)
     117 Q
     118FRAC ;
     119 K PSOFRAC,PSOFRACX,PSOFRAC1,PSOFRAC2
     120 I $G(PSOFX("DOSE ORDERED",FFF))="" Q
     121 I $G(PSOFX("DOSE ORDERED",FFF))'["." S (PSOFRAC1,PSOFRAC)=$G(PSOFX("DOSE ORDERED",FFF)) D NUM D  G FRACQ
     122 .I $G(PSOFRAC1)=$G(PSOFRAC) K PSOFRAC,PSOFRAC1 Q
     123 .S PSOFRAC=$G(PSOFRAC1)
     124 S PSOFRAC1=$P(PSOFX("DOSE ORDERED",FFF),"."),PSOFRAC2=$P(PSOFX("DOSE ORDERED",FFF),".",2)
     125 S PSOFRACX="."_$G(PSOFRAC2)
     126 S PSOFRAC=$S(PSOFRACX=".5":"ONE-HALF",PSOFRACX=".25":"ONE-FOURTH",PSOFRACX=".33":"ONE-THIRD",PSOFRACX=".34":"ONE-THIRD",PSOFRACX=".50":"ONE-HALF",PSOFRACX=".66":"TWO-THIRDS",PSOFRACX=".67":"TWO-THIRDS",PSOFRACX=".75":"THREE-FOURTHS",1:"")
     127 I $G(PSOFRAC)="" K PSOFRAC G FRACQ
     128 I $G(PSOFRAC1)'="",+$G(PSOFRAC1) D NUM S PSOFRAC=$G(PSOFRAC1)_" AND "_$G(PSOFRAC)
     129FRACQ K PSOFRAC1,PSOFRAC2
     130 Q
     131NUM ;
     132 Q:$G(PSOFRAC1)=""
     133 S PSOFRAC1=$S(PSOFRAC1="1":"ONE",PSOFRAC1="2":"TWO",PSOFRAC1="3":"THREE",PSOFRAC1="4":"FOUR",PSOFRAC1="5":"FIVE",PSOFRAC1="6":"SIX",PSOFRAC1="7":"SEVEN",PSOFRAC1="8":"EIGHT",PSOFRAC1="9":"NINE",PSOFRAC1="10":"TEN",1:PSOFRAC1)
     134 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLPIS.m

    r613 r623  
    1 PSOHLPIS        ;BIR/RTR-Parse out and create CPRS Sig ;7/21/96
    2         ;;7.0;OUTPATIENT PHARMACY;**46,225**;DEC 1997;Build 29
    3         ;External reference to File #50.7 supported by DBIA 2223
    4         ;External reference to File #51 supported by DBIA 2224
    5         ;External reference to File #51.1 supported by DBIA 2225
    6         ;External reference to File #51.2 supported by DBIA 2226
    7         ;External reference to File #50.606 supported by DBIA 2174
    8 EN      ;
    9         Q:'$D(^PS(52.41,PENDING,1,0))
    10         N PISI,PSOFX,SDF,SZZ,ZZS,ZZSB,SSZZ,SCHHOLD,GGGZ,SGLFLAG,SGLOOP,ZSCHED,SPFG,PSNOUN,MEDEXP,PSDUR,NOUN,SCHED,INTERVAL,SIG0,SIG2,SIG3,SDL,WW,TODOSE,PDAYS,WWFL,PSOCJS,PSOFDCT,PSODCT
    11         N SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2,FTC,FTCA,FTCF,FTCNT
    12         N SIG
    13         F PISI=0:0 S PISI=$O(^PS(52.41,PENDING,1,PISI)) Q:'PISI  D:$D(^(PISI,0))
    14         .S PSOFX("DOSE",PISI)=$P($G(^PS(52.41,PENDING,1,PISI,2)),"^") I $P($G(^(2)),"^",2)'="" S PSOFX("DOSE ORDERED",PISI)=$P($G(^(2)),"^",2)
    15         .S PSOFX("SCHEDULE",PISI)=$P($G(^PS(52.41,PENDING,1,PISI,1)),"^"),PSOFX("ROUTE",PISI)=$P($G(^(1)),"^",8),PSOFX("DURATION",PISI)=$P($G(^(1)),"^",2),PSOFX("NOUN",PISI)=$P($G(^(1)),"^",5),PSOFX("CONJUNCTION",PISI)=$P($G(^(1)),"^",6)
    16         .I $G(PSOFX("DURATION",PISI)) S PSOFX("DURATION",PISI)="D"_$G(PSOFX("DURATION",PISI))
    17         .I $G(PSOFX("DURATION",PISI))'="" S PSOFX("DURATION",PISI)=$E(PSOFX("DURATION",PISI),2,999)_$E(PSOFX("DURATION",PISI))
    18         S TODOSE=0 F WW=0:0 S WW=$O(PSOFX("DOSE",WW)) Q:'WW  S TODOSE=WW
    19         Q:'TODOSE
    20         S SIGDS=+$P($G(^PS(50.7,+$G(PSORDITE),0)),"^",2),VERB=$P($G(^PS(50.606,SIGDS,"MISC")),"^"),PREP=$P($G(^("MISC")),"^",3)
    21         S FTCNT=0 K FTC,FTCA,FTCF F SSS=1:1:TODOSE D
    22         .S SIG0(SSS)=$S($G(PSOFX("DOSE ORDERED",SSS))'="":$G(PSOFX("DOSE ORDERED",SSS)),1:$G(PSOFX("DOSE",SSS)))
    23         .S PSNOUN(SSS)=$G(PSOFX("NOUN",SSS))
    24         .S FTC=+$G(PSOFX("ROUTE",SSS)) I FTC S:'FTCNT FTCA=FTC S FTCNT=FTCNT+1
    25         .I FTCNT>1,$G(FTC),$G(FTC)'=$G(FTCA) S FTCF=1
    26         .S PSOROUTE(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",2)'="":$P(^(0),"^",2),$P($G(^(0)),"^",3)'="":$P(^(0),"^",3),1:$P($G(^(0)),"^")) S MEDEXP(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",2)="":0,1:1)
    27         .S PDAYS(SSS)=$G(PSOFX("DURATION",SSS))
    28         .I $G(PSOFX("DURATION",SSS))'="",($E(PSOFX("DURATION",SSS),$L(PSOFX("DURATION",SSS)))'?1A) S PDAYS(SSS)=PDAYS(SSS)_"D"
    29         .S PSDUR(SSS)=$S($G(PDAYS(SSS))="":"NULL",1:"FOR "_$E($G(PDAYS(SSS)),1,($L($G(PDAYS(SSS)))-1))) D  I PSDUR(SSS)'="NULL" S PSDUR(SSS)=PSDUR(SSS)_" "_INTERVAL
    30         ..I PSDUR(SSS)'="NULL" S INTERVAL=$E(PDAYS(SSS),$L(PDAYS(SSS))),INTERVAL=$S(INTERVAL="D":"DAYS",INTERVAL="W":"WEEKS",INTERVAL="H":"HOURS",INTERVAL="L":"MONTHS",INTERVAL="M":"MINUTES",INTERVAL="S":"SECONDS",1:"") D
    31         ...I $G(INTERVAL)'="",$G(PSOFX("DURATION",SSS)),$G(PSOFX("DURATION",SSS))'>1 S INTERVAL=$E(INTERVAL,1,($L(INTERVAL)-1))
    32         F GGG=1:1:TODOSE S ZSCHED(GGG)=$G(PSOFX("SCHEDULE",GGG)) D
    33         .I $G(ZSCHED(GGG))="" S SCHED(GGG)="" Q
    34         .S SGLFLAG=0 F WW=0:0 S WW=$O(^PS(51.1,"B",ZSCHED(GGG),WW)) Q:'WW!($G(SGLFLAG))  I $P($G(^PS(51.1,WW,0)),"^",8)'="" S SCHED(GGG)=$P($G(^(0)),"^",8),SGLFLAG=1
    35         .Q:$G(SGLFLAG)
    36         .I $G(^PS(51,"A",ZSCHED(GGG)))'="" S SCHED(GGG)=$P(^(ZSCHED(GGG)),"^") Q
    37         .S ZZSB=0 F ZZS=1:1:$L(ZSCHED(GGG)) S SZZ=$E(ZSCHED(GGG),ZZS) I SZZ=" " S ZZSB=ZZSB+1
    38         .S ZZSB=ZZSB+1
    39         .K SCHHOLD F GGGZ=1:1:ZZSB S (SDL,SCHHOLD(GGGZ))=$P(ZSCHED(GGG)," ",GGGZ) D
    40         ..Q:$G(SDL)=""
    41         ..S SGLFLAG=0 F WW=0:0 S WW=$O(^PS(51.1,"B",SDL,WW)) Q:'WW!($G(SGLFLAG))  I $P($G(^PS(51.1,WW,0)),"^",8)'="" S SCHHOLD(GGGZ)=$P($G(^(0)),"^",8),SGLFLAG=1
    42         ..Q:$G(SGLFLAG)
    43         ..I $G(^PS(51,"A",SDL))'="" S SCHHOLD(GGGZ)=$P(^(SDL),"^")
    44         .S SCHED(GGG)="",SGLFLAG=0 F WW=1:1:ZZSB S SCHED(GGG)=SCHED(GGG)_$S($G(SGLFLAG):" ",1:"")_$G(SCHHOLD(WW)),SGLFLAG=1
    45         S (FTC,FTCA,PSOFDCT)=0 F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF  D
    46         .K PSOSG1,PSOSG2 D VERB D:$G(PSNOUN(FFF))'=""&('$G(PSOSG1)) SSS
    47         .D FRAC
    48         .S SIG2(FFF)=$S(VERB'=""&('$G(PSOSG1)):VERB_" ",1:"")_$S($G(PSOFX("DOSE ORDERED",FFF))'="":$S($G(PSOFRAC)'="":$G(PSOFRAC),1:$G(PSOFX("DOSE ORDERED",FFF)))_" ",1:$G(PSOFX("DOSE",FFF))_" ")
    49         .S PSOFDCT=PSOFDCT+1
    50         .K PSOFRAC,PSOFRACX
    51         .I FTC>0,$G(PSOROUTE(FFF))'="",'$G(FTCF) S FTCA=1
    52         .I $G(PSOROUTE(FFF))'="" S FTC=FTC+1
    53         .S SIG2(FFF)=SIG2(FFF)_$S($G(PSNOUN(FFF))'=""&('$G(PSOSG2)):$G(PSNOUN(FFF))_" ",1:"")_$S(PREP'=""&($G(MEDEXP(FFF)))&('FTCA):PREP_" ",1:"")
    54         .S SIG2(FFF)=SIG2(FFF)_$S(PSOROUTE(FFF)'=""&('FTCA):PSOROUTE(FFF)_" ",1:"")
    55         .;S SIG2(FFF)=SIG2(FFF)_$S(SCHED(FFF)'="":SCHED(FFF)_" ",1:"")_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_" ",1:"")_$S($G(PSOFX("CONJUNCTION",FFF))="A":"AND",$G(PSOFX("CONJUNCTION",FFF))="T":"THEN",$G(PSOFX("CONJUNCTION",FFF))="S":"THEN",1:"")
    56         .S SIG2(FFF)=SIG2(FFF)_$S(SCHED(FFF)'="":SCHED(FFF)_$S($G(PSDUR(FFF))="NULL"&($G(PSOFX("CONJUNCTION",FFF))="")&('$O(SIG0(FFF))):"",1:" "),1:"")
    57         .S PSOCJS=$G(PSOFX("CONJUNCTION",FFF))
    58         .S SIG2(FFF)=SIG2(FFF)_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_$S($G(PSOFX("CONJUNCTION",FFF))=""&('$O(SIG0(FFF))):"",1:", "),1:"")_$S($G(PSOCJS)="A":"AND",$G(PSOCJS)="T":"THEN",$G(PSOCJS)="S":"THEN",$G(PSOCJS)="X":"EXCEPT",1:"")
    59         .K PSOSG1,PSOSG2
    60         .K PSOUCS S SIG2(FFF)=$$UPPER(SIG2(FFF)) K PSOUCS
    61         ;I $G(PSOFX("INS"))'="" S TODOSE=TODOSE+1,SIG2(TODOSE)=$G(PSOFX("INS"))
    62         S PSODCT="" F  S PSODCT=$O(^PS(52.41,PENDING,"INS1",PSODCT)) Q:PSODCT=""  I $D(^(PSODCT,0)) S PSOFDCT=PSOFDCT+1 S SIG2(PSOFDCT)=$G(^(0)) K PSOUCS S SIG2(PSOFDCT)=$$UPPER(SIG2(PSOFDCT)) K PSOUCS
    63 STUFF   ;
    64         S DCOUNT=0
    65         I '$D(SIG2(1)) G QUIT
    66         I '$O(SIG2(1)),$L(SIG2(1))<71 S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_1_"^"_1 S ^PS(52.41,PENDING,"SIG",1,0)=$$UNESC^ORHLESC(SIG2(1)) S DCOUNT=1 G QUITIN
    67         S (VAR,VAR1)="",II=1
    68         F FF=0:0 S FF=$O(SIG2(FF)) Q:'FF  S CT=0 F NN=1:1:$L(SIG2(FF)) I $E(SIG2(FF),NN)=" "!($L(SIG2(FF))=NN) S CT=CT+1 D  I $L(VAR)>70 S SIG(II)=LIM_" ",II=II+1,VAR=VAR1
    69         .S VAR1=$P(SIG2(FF)," ",(CT))
    70         .S LIM=VAR
    71         .S VAR=$S(VAR="":VAR1,1:VAR_" "_VAR1)
    72         I $G(VAR)'="" S SIG(II)=VAR
    73         F II=0:0 S II=$O(SIG(II)) Q:'II  S DCOUNT=DCOUNT+1 S ^PS(52.41,PENDING,"SIG",DCOUNT,0)=$$UNESC^ORHLESC(SIG(II))
    74         I DCOUNT S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_DCOUNT_"^"_DCOUNT
    75 QUITIN  ;I $P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^")'="",DCOUNT S DCOUNT=DCOUNT+1,^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_DCOUNT_"^"_DCOUNT,^PS(52.41,PENDING,"SIG",DCOUNT,0)=$P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^")
    76         ;I $P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^")'="" S $P(^PS(52.41,PENDING,"INS"),"^")=$P(^PS(50.7,+$G(PSORDITE),"INS"),"^")
    77 QUIT    K SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2 Q
    78 SIG1    ;
    79         F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF  S SIG2(FFF)=SIG0(FFF)
    80         Q
    81 DAYS    I +$E($P(SIG1(TT),"^",2))!($E($P(SIG1(TT),"^",2))=0) S $P(SIG1(TT),"^",2)="D"_$P(SIG1(TT),"^",2)
    82         Q
    83 NON     ;
    84         I $P($G(SIG0(SSS)),"&",2)'="" S PSNOUN(SSS)=$P($G(SIG0(SSS)),"&",2) Q
    85         Q
    86         F NOUN=0:0 S NOUN=$O(^PS(50.606,SIGDS,"NOUN",NOUN)) Q:'NOUN!($G(PSNOUN(SSS))'="")  I $P($G(^PS(50.606,SIGDS,"NOUN",NOUN,0)),"^")'="" S PSNOUN(SSS)=$P(^(0),"^")
    87         Q
    88 VERB    ;Check if verb and noun need to be added to SIG
    89         K PSOLCS,PSOUCS,PSOISL,PSOVL
    90         I $G(VERB)'="" S PSOVL=$L(VERB),PSOISL=$E($G(SIG0(FFF)),1,$G(PSOVL)) I $G(PSOISL)'="" D
    91         .S PSOUCS=VERB
    92         .S PSOUCS=$$UPPER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q
    93         .S PSOUCS=$$LOWER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q
    94         .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOUCS=PSOISL S PSOSG1=1 Q
    95         I $G(PSNOUN(FFF))="" G VERBEX
    96         S PSOISL=$G(SIG0(FFF)) I $G(PSOISL)="" G VERBEX
    97         S PSOVL=$F(PSNOUN(FFF),"(")
    98         I $G(PSOVL)>2 S PSOUCS=$E(PSNOUN(FFF),1,(PSOVL-2))
    99         I $G(PSOVL)'>2 S PSOUCS=PSNOUN(FFF)
    100         I $G(PSOISL)'="" D
    101         .S PSOUCS=$$UPPER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q
    102         .S PSOUCS=$$LOWER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q
    103         .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOISL[PSOUCS S PSOSG2=1
    104 VERBEX  K PSOLCS,PSOUCS,PSOISL,PSOVL Q
    105         ;
    106 UPPER(PSOUCS)   ;
    107         Q $TR(PSOUCS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    108         ;
    109 LOWER(PSOLCS)   ;
    110         Q $TR(PSOLCS,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
    111         Q
    112         ;
    113 SSS     ;
    114         K PSOFNL,PSOFNLF,PSOFNLX
    115         Q:$G(PSNOUN(FFF))=""
    116         Q:$L(PSNOUN(FFF))'>3
    117         Q:'$G(PSOFX("DOSE ORDERED",FFF))
    118         ;Q:$G(PSOFX("DOSE ORDERED",FFF))>1
    119         S PSOFNL=$E(PSNOUN(FFF),($L(PSNOUN(FFF))-2),$L(PSNOUN(FFF)))
    120         I $G(PSOFNL)="(S)"!($G(PSOFNL)="(s)") D
    121         .I $G(PSOFX("DOSE ORDERED",FFF))'>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3))
    122         .I $G(PSOFX("DOSE ORDERED",FFF))>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3))_$E(PSOFNL,2)
    123         Q
    124 FRAC    ;
    125         K PSOFRAC,PSOFRACX,PSOFRAC1,PSOFRAC2
    126         I $G(PSOFX("DOSE ORDERED",FFF))="" Q
    127         I $G(PSOFX("DOSE ORDERED",FFF))'["." S (PSOFRAC1,PSOFRAC)=$G(PSOFX("DOSE ORDERED",FFF)) D NUM D  G FRACQ
    128         .I $G(PSOFRAC1)=$G(PSOFRAC) K PSOFRAC,PSOFRAC1 Q
    129         .S PSOFRAC=$G(PSOFRAC1)
    130         S PSOFRAC1=$P(PSOFX("DOSE ORDERED",FFF),"."),PSOFRAC2=$P(PSOFX("DOSE ORDERED",FFF),".",2)
    131         S PSOFRACX="."_$G(PSOFRAC2)
    132         S PSOFRAC=$S(PSOFRACX=".5":"ONE-HALF",PSOFRACX=".25":"ONE-FOURTH",PSOFRACX=".33":"ONE-THIRD",PSOFRACX=".34":"ONE-THIRD",PSOFRACX=".50":"ONE-HALF",PSOFRACX=".66":"TWO-THIRDS",PSOFRACX=".67":"TWO-THIRDS",PSOFRACX=".75":"THREE-FOURTHS",1:"")
    133         I $G(PSOFRAC)="" K PSOFRAC G FRACQ
    134         I $G(PSOFRAC1)'="",+$G(PSOFRAC1) D NUM S PSOFRAC=$G(PSOFRAC1)_" AND "_$G(PSOFRAC)
    135 FRACQ   K PSOFRAC1,PSOFRAC2
    136         Q
    137 NUM     ;
    138         Q:$G(PSOFRAC1)=""
    139         S PSOFRAC1=$S(PSOFRAC1="1":"ONE",PSOFRAC1="2":"TWO",PSOFRAC1="3":"THREE",PSOFRAC1="4":"FOUR",PSOFRAC1="5":"FIVE",PSOFRAC1="6":"SIX",PSOFRAC1="7":"SEVEN",PSOFRAC1="8":"EIGHT",PSOFRAC1="9":"NINE",PSOFRAC1="10":"TEN",1:PSOFRAC1)
    140         Q
     1PSOHLPIS ;BIR/RTR-Parse out and create CPRS Sig ;7/21/96
     2 ;;7.0;OUTPATIENT PHARMACY;**46**;DEC 1997
     3 ;External reference to File #50.7 supported by DBIA 2223
     4 ;External reference to File #51 supported by DBIA 2224
     5 ;External reference to File #51.1 supported by DBIA 2225
     6 ;External reference to File #51.2 supported by DBIA 2226
     7 ;External reference to File #50.606 supported by DBIA 2174
     8EN ;
     9 Q:'$D(^PS(52.41,PENDING,1,0))
     10 N PISI,PSOFX,SDF,SZZ,ZZS,ZZSB,SSZZ,SCHHOLD,GGGZ,SGLFLAG,SGLOOP,ZSCHED,SPFG,PSNOUN,MEDEXP,PSDUR,NOUN,SCHED,INTERVAL,SIG0,SIG2,SIG3,SDL,WW,TODOSE,PDAYS,WWFL,PSOCJS,PSOFDCT,PSODCT
     11 N SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2,FTC,FTCA,FTCF,FTCNT
     12 N SIG
     13 F PISI=0:0 S PISI=$O(^PS(52.41,PENDING,1,PISI)) Q:'PISI  D:$D(^(PISI,0))
     14 .S PSOFX("DOSE",PISI)=$P($G(^PS(52.41,PENDING,1,PISI,2)),"^") I $P($G(^(2)),"^",2)'="" S PSOFX("DOSE ORDERED",PISI)=$P($G(^(2)),"^",2)
     15 .S PSOFX("SCHEDULE",PISI)=$P($G(^PS(52.41,PENDING,1,PISI,1)),"^"),PSOFX("ROUTE",PISI)=$P($G(^(1)),"^",8),PSOFX("DURATION",PISI)=$P($G(^(1)),"^",2),PSOFX("NOUN",PISI)=$P($G(^(1)),"^",5),PSOFX("CONJUNCTION",PISI)=$P($G(^(1)),"^",6)
     16 .I $G(PSOFX("DURATION",PISI)) S PSOFX("DURATION",PISI)="D"_$G(PSOFX("DURATION",PISI))
     17 .I $G(PSOFX("DURATION",PISI))'="" S PSOFX("DURATION",PISI)=$E(PSOFX("DURATION",PISI),2,999)_$E(PSOFX("DURATION",PISI))
     18 S TODOSE=0 F WW=0:0 S WW=$O(PSOFX("DOSE",WW)) Q:'WW  S TODOSE=WW
     19 Q:'TODOSE
     20 S SIGDS=+$P($G(^PS(50.7,+$G(PSORDITE),0)),"^",2),VERB=$P($G(^PS(50.606,SIGDS,"MISC")),"^"),PREP=$P($G(^("MISC")),"^",3)
     21 S FTCNT=0 K FTC,FTCA,FTCF F SSS=1:1:TODOSE D
     22 .S SIG0(SSS)=$S($G(PSOFX("DOSE ORDERED",SSS))'="":$G(PSOFX("DOSE ORDERED",SSS)),1:$G(PSOFX("DOSE",SSS)))
     23 .S PSNOUN(SSS)=$G(PSOFX("NOUN",SSS))
     24 .S FTC=+$G(PSOFX("ROUTE",SSS)) I FTC S:'FTCNT FTCA=FTC S FTCNT=FTCNT+1
     25 .I FTCNT>1,$G(FTC),$G(FTC)'=$G(FTCA) S FTCF=1
     26 .S PSOROUTE(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",2)'="":$P(^(0),"^",2),$P($G(^(0)),"^",3)'="":$P(^(0),"^",3),1:$P($G(^(0)),"^")) S MEDEXP(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",2)="":0,1:1)
     27 .S PDAYS(SSS)=$G(PSOFX("DURATION",SSS))
     28 .I $G(PSOFX("DURATION",SSS))'="",($E(PSOFX("DURATION",SSS),$L(PSOFX("DURATION",SSS)))'?1A) S PDAYS(SSS)=PDAYS(SSS)_"D"
     29 .S PSDUR(SSS)=$S($G(PDAYS(SSS))="":"NULL",1:"FOR "_$E($G(PDAYS(SSS)),1,($L($G(PDAYS(SSS)))-1))) D  I PSDUR(SSS)'="NULL" S PSDUR(SSS)=PSDUR(SSS)_" "_INTERVAL
     30 ..I PSDUR(SSS)'="NULL" S INTERVAL=$E(PDAYS(SSS),$L(PDAYS(SSS))),INTERVAL=$S(INTERVAL="D":"DAYS",INTERVAL="W":"WEEKS",INTERVAL="H":"HOURS",INTERVAL="L":"MONTHS",INTERVAL="M":"MINUTES",INTERVAL="S":"SECONDS",1:"") D
     31 ...I $G(INTERVAL)'="",$G(PSOFX("DURATION",SSS)),$G(PSOFX("DURATION",SSS))'>1 S INTERVAL=$E(INTERVAL,1,($L(INTERVAL)-1))
     32 F GGG=1:1:TODOSE S ZSCHED(GGG)=$G(PSOFX("SCHEDULE",GGG)) D
     33 .I $G(ZSCHED(GGG))="" S SCHED(GGG)="" Q
     34 .S SGLFLAG=0 F WW=0:0 S WW=$O(^PS(51.1,"B",ZSCHED(GGG),WW)) Q:'WW!($G(SGLFLAG))  I $P($G(^PS(51.1,WW,0)),"^",8)'="" S SCHED(GGG)=$P($G(^(0)),"^",8),SGLFLAG=1
     35 .Q:$G(SGLFLAG)
     36 .I $G(^PS(51,"A",ZSCHED(GGG)))'="" S SCHED(GGG)=$P(^(ZSCHED(GGG)),"^") Q
     37 .S ZZSB=0 F ZZS=1:1:$L(ZSCHED(GGG)) S SZZ=$E(ZSCHED(GGG),ZZS) I SZZ=" " S ZZSB=ZZSB+1
     38 .S ZZSB=ZZSB+1
     39 .K SCHHOLD F GGGZ=1:1:ZZSB S (SDL,SCHHOLD(GGGZ))=$P(ZSCHED(GGG)," ",GGGZ) D
     40 ..Q:$G(SDL)=""
     41 ..S SGLFLAG=0 F WW=0:0 S WW=$O(^PS(51.1,"B",SDL,WW)) Q:'WW!($G(SGLFLAG))  I $P($G(^PS(51.1,WW,0)),"^",8)'="" S SCHHOLD(GGGZ)=$P($G(^(0)),"^",8),SGLFLAG=1
     42 ..Q:$G(SGLFLAG)
     43 ..I $G(^PS(51,"A",SDL))'="" S SCHHOLD(GGGZ)=$P(^(SDL),"^")
     44 .S SCHED(GGG)="",SGLFLAG=0 F WW=1:1:ZZSB S SCHED(GGG)=SCHED(GGG)_$S($G(SGLFLAG):" ",1:"")_$G(SCHHOLD(WW)),SGLFLAG=1
     45 S (FTC,FTCA,PSOFDCT)=0 F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF  D
     46 .K PSOSG1,PSOSG2 D VERB D:$G(PSNOUN(FFF))'=""&('$G(PSOSG1)) SSS
     47 .D FRAC
     48 .S SIG2(FFF)=$S(VERB'=""&('$G(PSOSG1)):VERB_" ",1:"")_$S($G(PSOFX("DOSE ORDERED",FFF))'="":$S($G(PSOFRAC)'="":$G(PSOFRAC),1:$G(PSOFX("DOSE ORDERED",FFF)))_" ",1:$G(PSOFX("DOSE",FFF))_" ")
     49 .S PSOFDCT=PSOFDCT+1
     50 .K PSOFRAC,PSOFRACX
     51 .I FTC>0,$G(PSOROUTE(FFF))'="",'$G(FTCF) S FTCA=1
     52 .I $G(PSOROUTE(FFF))'="" S FTC=FTC+1
     53 .S SIG2(FFF)=SIG2(FFF)_$S($G(PSNOUN(FFF))'=""&('$G(PSOSG2)):$G(PSNOUN(FFF))_" ",1:"")_$S(PREP'=""&($G(MEDEXP(FFF)))&('FTCA):PREP_" ",1:"")
     54 .S SIG2(FFF)=SIG2(FFF)_$S(PSOROUTE(FFF)'=""&('FTCA):PSOROUTE(FFF)_" ",1:"")
     55 .;S SIG2(FFF)=SIG2(FFF)_$S(SCHED(FFF)'="":SCHED(FFF)_" ",1:"")_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_" ",1:"")_$S($G(PSOFX("CONJUNCTION",FFF))="A":"AND",$G(PSOFX("CONJUNCTION",FFF))="T":"THEN",$G(PSOFX("CONJUNCTION",FFF))="S":"THEN",1:"")
     56 .S SIG2(FFF)=SIG2(FFF)_$S(SCHED(FFF)'="":SCHED(FFF)_$S($G(PSDUR(FFF))="NULL"&($G(PSOFX("CONJUNCTION",FFF))="")&('$O(SIG0(FFF))):"",1:" "),1:"")
     57 .S PSOCJS=$G(PSOFX("CONJUNCTION",FFF))
     58 .S SIG2(FFF)=SIG2(FFF)_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_$S($G(PSOFX("CONJUNCTION",FFF))=""&('$O(SIG0(FFF))):"",1:", "),1:"")_$S($G(PSOCJS)="A":"AND",$G(PSOCJS)="T":"THEN",$G(PSOCJS)="S":"THEN",$G(PSOCJS)="X":"EXCEPT",1:"")
     59 .K PSOSG1,PSOSG2
     60 .K PSOUCS S SIG2(FFF)=$$UPPER(SIG2(FFF)) K PSOUCS
     61 ;I $G(PSOFX("INS"))'="" S TODOSE=TODOSE+1,SIG2(TODOSE)=$G(PSOFX("INS"))
     62 S PSODCT="" F  S PSODCT=$O(^PS(52.41,PENDING,"INS1",PSODCT)) Q:PSODCT=""  I $D(^(PSODCT,0)) S PSOFDCT=PSOFDCT+1 S SIG2(PSOFDCT)=$G(^(0)) K PSOUCS S SIG2(PSOFDCT)=$$UPPER(SIG2(PSOFDCT)) K PSOUCS
     63STUFF ;
     64 S DCOUNT=0
     65 I '$D(SIG2(1)) G QUIT
     66 I '$O(SIG2(1)),$L(SIG2(1))<71 S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_1_"^"_1 S ^PS(52.41,PENDING,"SIG",1,0)=SIG2(1) S DCOUNT=1 G QUITIN
     67 S (VAR,VAR1)="",II=1
     68 F FF=0:0 S FF=$O(SIG2(FF)) Q:'FF  S CT=0 F NN=1:1:$L(SIG2(FF)) I $E(SIG2(FF),NN)=" "!($L(SIG2(FF))=NN) S CT=CT+1 D  I $L(VAR)>70 S SIG(II)=LIM_" ",II=II+1,VAR=VAR1
     69 .S VAR1=$P(SIG2(FF)," ",(CT))
     70 .S LIM=VAR
     71 .S VAR=$S(VAR="":VAR1,1:VAR_" "_VAR1)
     72 I $G(VAR)'="" S SIG(II)=VAR
     73 F II=0:0 S II=$O(SIG(II)) Q:'II  S DCOUNT=DCOUNT+1 S ^PS(52.41,PENDING,"SIG",DCOUNT,0)=SIG(II)
     74 I DCOUNT S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_DCOUNT_"^"_DCOUNT
     75QUITIN ;I $P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^")'="",DCOUNT S DCOUNT=DCOUNT+1,^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_DCOUNT_"^"_DCOUNT,^PS(52.41,PENDING,"SIG",DCOUNT,0)=$P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^")
     76 ;I $P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^")'="" S $P(^PS(52.41,PENDING,"INS"),"^")=$P(^PS(50.7,+$G(PSORDITE),"INS"),"^")
     77QUIT K SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2 Q
     78SIG1 ;
     79 F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF  S SIG2(FFF)=SIG0(FFF)
     80 Q
     81DAYS I +$E($P(SIG1(TT),"^",2))!($E($P(SIG1(TT),"^",2))=0) S $P(SIG1(TT),"^",2)="D"_$P(SIG1(TT),"^",2)
     82 Q
     83NON ;
     84 I $P($G(SIG0(SSS)),"&",2)'="" S PSNOUN(SSS)=$P($G(SIG0(SSS)),"&",2) Q
     85 Q
     86 F NOUN=0:0 S NOUN=$O(^PS(50.606,SIGDS,"NOUN",NOUN)) Q:'NOUN!($G(PSNOUN(SSS))'="")  I $P($G(^PS(50.606,SIGDS,"NOUN",NOUN,0)),"^")'="" S PSNOUN(SSS)=$P(^(0),"^")
     87 Q
     88VERB ;Check if verb and noun need to be added to SIG
     89 K PSOLCS,PSOUCS,PSOISL,PSOVL
     90 I $G(VERB)'="" S PSOVL=$L(VERB),PSOISL=$E($G(SIG0(FFF)),1,$G(PSOVL)) I $G(PSOISL)'="" D
     91 .S PSOUCS=VERB
     92 .S PSOUCS=$$UPPER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q
     93 .S PSOUCS=$$LOWER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q
     94 .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOUCS=PSOISL S PSOSG1=1 Q
     95 I $G(PSNOUN(FFF))="" G VERBEX
     96 S PSOISL=$G(SIG0(FFF)) I $G(PSOISL)="" G VERBEX
     97 S PSOVL=$F(PSNOUN(FFF),"(")
     98 I $G(PSOVL)>2 S PSOUCS=$E(PSNOUN(FFF),1,(PSOVL-2))
     99 I $G(PSOVL)'>2 S PSOUCS=PSNOUN(FFF)
     100 I $G(PSOISL)'="" D
     101 .S PSOUCS=$$UPPER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q
     102 .S PSOUCS=$$LOWER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q
     103 .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOISL[PSOUCS S PSOSG2=1
     104VERBEX K PSOLCS,PSOUCS,PSOISL,PSOVL Q
     105 ;
     106UPPER(PSOUCS) ;
     107 Q $TR(PSOUCS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     108 ;
     109LOWER(PSOLCS) ;
     110 Q $TR(PSOLCS,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
     111 Q
     112 ;
     113SSS ;
     114 K PSOFNL,PSOFNLF,PSOFNLX
     115 Q:$G(PSNOUN(FFF))=""
     116 Q:$L(PSNOUN(FFF))'>3
     117 Q:'$G(PSOFX("DOSE ORDERED",FFF))
     118 ;Q:$G(PSOFX("DOSE ORDERED",FFF))>1
     119 S PSOFNL=$E(PSNOUN(FFF),($L(PSNOUN(FFF))-2),$L(PSNOUN(FFF)))
     120 I $G(PSOFNL)="(S)"!($G(PSOFNL)="(s)") D
     121 .I $G(PSOFX("DOSE ORDERED",FFF))'>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3))
     122 .I $G(PSOFX("DOSE ORDERED",FFF))>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3))_$E(PSOFNL,2)
     123 Q
     124FRAC ;
     125 K PSOFRAC,PSOFRACX,PSOFRAC1,PSOFRAC2
     126 I $G(PSOFX("DOSE ORDERED",FFF))="" Q
     127 I $G(PSOFX("DOSE ORDERED",FFF))'["." S (PSOFRAC1,PSOFRAC)=$G(PSOFX("DOSE ORDERED",FFF)) D NUM D  G FRACQ
     128 .I $G(PSOFRAC1)=$G(PSOFRAC) K PSOFRAC,PSOFRAC1 Q
     129 .S PSOFRAC=$G(PSOFRAC1)
     130 S PSOFRAC1=$P(PSOFX("DOSE ORDERED",FFF),"."),PSOFRAC2=$P(PSOFX("DOSE ORDERED",FFF),".",2)
     131 S PSOFRACX="."_$G(PSOFRAC2)
     132 S PSOFRAC=$S(PSOFRACX=".5":"ONE-HALF",PSOFRACX=".25":"ONE-FOURTH",PSOFRACX=".33":"ONE-THIRD",PSOFRACX=".34":"ONE-THIRD",PSOFRACX=".50":"ONE-HALF",PSOFRACX=".66":"TWO-THIRDS",PSOFRACX=".67":"TWO-THIRDS",PSOFRACX=".75":"THREE-FOURTHS",1:"")
     133 I $G(PSOFRAC)="" K PSOFRAC G FRACQ
     134 I $G(PSOFRAC1)'="",+$G(PSOFRAC1) D NUM S PSOFRAC=$G(PSOFRAC1)_" AND "_$G(PSOFRAC)
     135FRACQ K PSOFRAC1,PSOFRAC2
     136 Q
     137NUM ;
     138 Q:$G(PSOFRAC1)=""
     139 S PSOFRAC1=$S(PSOFRAC1="1":"ONE",PSOFRAC1="2":"TWO",PSOFRAC1="3":"THREE",PSOFRAC1="4":"FOUR",PSOFRAC1="5":"FIVE",PSOFRAC1="6":"SIX",PSOFRAC1="7":"SEVEN",PSOFRAC1="8":"EIGHT",PSOFRAC1="9":"NINE",PSOFRAC1="10":"TEN",1:PSOFRAC1)
     140 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN.m

    r613 r623  
    1 PSOHLSN ;BIR/RTR-Send order information to OERR from file 52.41 ;10/10/94
    2         ;;7.0;OUTPATIENT PHARMACY;**1,7,15,24,27,30,55,46,98,88,121,292**;DEC 1997;Build 1
    3         ;Externel reference EN^ORERR supported by DBIA 2187
    4         ;
    5         ; PS EVSEND OR PROTOCOL MUST BE OUR DRIVER RTN, (52 OR 52.41 INDICATOR
    6         ; IS SENT THERE, THEN IT ROUTES, (NO NEED TO SEND FILE NUMBER HERE)
    7 EN(PLACER,STAT,COMM,PSNOO)      ;
    8         N DA,FIELD,J,JJ,MSG,LIMIT,NULLFLDS,PSIEN,PSOHINST,PSZERO,SEGMENT,NAME,DFN,COUNT,GG,CC,CT,MM,PVAR,PVAR1,PLIM,SEG1,SUBCOUNT,PSOPSTRT,PSOPSTOP,PSODFN,EDUZ,PSNOOTX,PSOHSTAT,PSOPSIEN
    9         S (PSIEN,PSOPSIEN)=$O(^PS(52.41,"B",PLACER,0))
    10         S COUNT=0
    11         ;I '$G(PSIEN) W !!,?5,"PROBLEM WITH ENTRY IN PENDING FILE!",! Q
    12         I '$G(PSIEN) Q
    13         I $G(STAT)="OC"!($G(STAT)="OD")!($G(STAT)="CR")!($G(STAT)="DR") D
    14         .D CHKOLDRX
    15         .I $D(^PS(52.41,PSIEN,0)) K ^PS(52.41,"AD",$P(^PS(52.41,PSIEN,0),"^",12),+$P($G(^("INI")),"^"),PSIEN),^PS(52.41,"ACL",+$P(^PS(52.41,PSIEN,0),"^",13),+$P(^(0),"^",12),PSIEN),^PS(52.41,"AQ",+$P($G(^PS(52.41,PSIEN,0)),"^",21),PSIEN)
    16         S PSZERO=$G(^PS(52.41,PSIEN,0)),PSOHSTAT=$G(STAT)
    17         S NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)="""""
    18         D INIT
    19         I $G(STAT)="Z@" S COUNT=1 D PID,PV1,ORC,SEND Q
    20         S COUNT=1 D PID,PV1,ORC,RXE,ZRX,SEND,REN Q
    21 INIT    K ^UTILITY("DIQ1",$J),DIQ S DA=$P($$SITE^VASITE(),"^") I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOHINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIQ,DIC
    22         S MSG(1)="MSH|^~\&|PHARMACY|"_$G(PSOHINST)_"|||||"_$S($G(PSOMSORR):"ORR",1:"ORM")
    23         Q
    24 PID     S LIMIT=5 X NULLFLDS
    25         S FIELD(0)="PID"
    26         S DFN=+$P(PSZERO,"^",2) D DEM^VADPT S NAME=$G(VADM(1)) K VADM
    27         S FIELD(3)=DFN
    28         S FIELD(5)=NAME
    29         D SEG Q
    30 PV1     S LIMIT=19 X NULLFLDS
    31         S FIELD(0)="PV1"
    32         S FIELD(2)="O"
    33         S:$P($G(^PS(52.41,PSIEN,0)),"^",13) FIELD(3)=$P(^(0),"^",13)
    34         D SEG Q
    35 ORC     S LIMIT=15 X NULLFLDS
    36         S FIELD(0)="ORC"
    37         S FIELD(1)=STAT
    38         S FIELD(2)=PLACER_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"
    39         S FIELD(3)=PSIEN_"S"_"^PS"
    40         I $G(FIELD(5))="" I $G(STAT)="OR"!($G(STAT)="OE") S FIELD(5)="IP"
    41         S:$G(COMM)="IP" FIELD(5)="IP"
    42         I $G(STAT)="SC" S FIELD(5)=$S($G(COMM)="IP":"IP",$G(COMM)="HD":"HD",$G(COMM)="DC":"DC",1:"")
    43         I $G(PSORPV),$G(STAT)="OC" S FIELD(5)="RP"
    44         ;S (PSOPSTRT,PSOPSTOP)="" S X=$P($G(^PS(52.41,PSIEN,0)),"^",6) I X S PSOPSTRT=$$FMTHL7^XLFDT(X)
    45         ;I $G(STAT)="CR"!($G(STAT)="OC") D:'$G(DT)  S X=DT S PSOPSTOP=$$FMTHL7^XLFDT(X)
    46         ;.S DT=$$DT^XLFDT
    47         ;K X S FIELD(7)="^^^"_$G(PSOPSTRT)_"^"_$G(PSOPSTOP)
    48         S EDUZ=$P($G(^PS(52.41,PSIEN,0)),"^",4) I EDUZ D USER^PSOORFI2(EDUZ) S FIELD(10)=EDUZ_"^"_USER1 K USER1
    49         I $G(PSOCANRC),$G(PSOCANRN)'="" I $G(STAT)="OC"!($G(STAT)="OD") S FIELD(12)=$G(PSOCANRC)_"^"_$G(PSOCANRN)
    50         I '$G(FIELD(12)) D USER^PSOORFI2($P(^PS(52.41,PSIEN,0),"^",5))
    51         I '$G(FIELD(12)) S FIELD(12)=$P(^PS(52.41,PSIEN,0),"^",5)_"^"_USER1 K USER1
    52         S FIELD(15)=$G(PSOPSTRT)
    53         D SEG
    54         I $G(COMM)'=""!($G(PSNOO)'="") D
    55         .I $G(PSNOO)="" I $G(COMM)="IP"!($G(COMM)="HD")!($G(COMM)="DC") Q
    56         .I $G(PSNOO)'="" D NOO^PSOHLSN1
    57         .I '$D(COMM) S COMM=""
    58         .I $L($G(COMM))+($L(MSG(COUNT)))+($L($G(PSNOOTX)))+($S($G(PSNOO)'="":11,1:5))<245 S MSG(COUNT)=MSG(COUNT)_"|"_$G(PSNOO)_"^"_$G(PSNOOTX)_"^"_$S($G(PSNOO)'="":"99ORN",1:"")_"^^"_$S(COMM="IP"!(COMM="DC")!(COMM="HD"):"",1:$G(COMM))_"^" Q
    59         .S MSG(COUNT,1)="|"_$G(PSNOO)_"^"_$G(PSNOOTX)_"^"_$S($G(PSNOO)'="":"99ORN",1:"")_"^^"_$S(COMM="IP"!(COMM="DC")!(COMM="HD"):"",1:$G(COMM))_"^" Q
    60         Q
    61 RXE     S LIMIT=1 X NULLFLDS
    62         S FIELD(0)="RXE"
    63         S (PSOPSTRT,PSOPSTOP)="" S X=$P($G(^PS(52.41,PSIEN,0)),"^",6) I X S PSOPSTRT=$$FMTHL7^XLFDT(X)
    64         I $G(STAT)="CR"!($G(STAT)="OC") D:'$G(DT)  S X=DT S PSOPSTOP=$$FMTHL7^XLFDT(X)
    65         .S DT=$$DT^XLFDT
    66         K X S FIELD(1)="^^^"_$G(PSOPSTRT)_"^"_$G(PSOPSTOP)
    67         D SEG Q
    68         ;
    69 ZRX     ;
    70         ;Only send if DC is from an external system
    71         I $G(STAT)'="OC",$G(STAT)'="OD" Q
    72         I '$G(PSOHUIOR)!('$G(PSOCANRC)) Q
    73         I $P($G(^PS(52.41,PSIEN,"EXT")),"^")="" Q
    74         S LIMIT=5 X NULLFLDS
    75         S FIELD(0)="ZRX"
    76         S FIELD(5)=PSOCANRC_"^"_$P($G(^VA(200,PSOCANRC,0)),"^")_"^"_"99NP"
    77         D SEG
    78         Q
    79         ;
    80 SEG     S SEGMENT="" F J=0:1:LIMIT S SEGMENT=$S(SEGMENT="":FIELD(J),1:SEGMENT_"|"_FIELD(J))
    81         S COUNT=COUNT+1,MSG(COUNT)=SEGMENT
    82         Q
    83 SEND    D MSG^XQOR("PS EVSEND OR",.MSG)
    84         Q
    85         ;
    86 SEGPAR  ;Parse out fields for sending segments to OERR that can be >245
    87         K PSOFIELD
    88         S COUNT=COUNT+1,CT=1,(PVAR,PVAR1)=""
    89         F MM=0:1:LIMIT S FIELD(MM)=$S(FIELD(MM)="":"|",1:FIELD(MM)_"|")
    90         I $L(FIELD(LIMIT))>1 S FIELD(LIMIT)=$E(FIELD(LIMIT),1,($L(FIELD(LIMIT))-1))
    91         F MM=0:1:LIMIT S SEG1=FIELD(MM) F CC=1:1:$L(SEG1) D  I $L(PVAR)=245 S PSOFIELD(CT)=PVAR,CT=CT+1,PVAR=""
    92         .S PVAR1=$E(SEG1,CC)
    93         .S PLIM=PVAR
    94         .S PVAR=$S(PVAR="":PVAR1,1:PVAR_PVAR1)
    95         I $G(PVAR)'="" S PSOFIELD(CT)=PVAR
    96         S MSG(COUNT)=PSOFIELD(1),SUBCOUNT=1 F GG=2:1 Q:'$D(PSOFIELD(GG))  S MSG(COUNT,SUBCOUNT)=PSOFIELD(GG),SUBCOUNT=SUBCOUNT+1
    97         K PSOFIELD
    98         Q
    99 ERROR   ;Builds error message from PSOHLNEW, usually means we can't find order
    100         D EN^ORERR(COMM,.MSG)
    101         N MSG,PSOHINST
    102         S PSOMSORR=1 D INIT
    103         S MSG(2)=$G(PSERRPID)
    104         S MSG(3)=$G(PSERRPV1)
    105         S MSG(4)="ORC|"_$S($G(STAT)'="":$G(STAT),1:"DE")_"|"_PLACER_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PSERRORC),"|",4)'="":$P(PSERRORC,"|",4),1:"")
    106         F EER=11,13 I $P($G(PSERRORC),"|",EER)'="" S $P(MSG(4),"|",EER)=$P($G(PSERRORC),"|",EER)
    107         I $G(COMM)'="" S $P(MSG(4),"|",17)="^^^^"_$G(COMM)
    108         D SEND K PSOMSORR Q
    109         ;
    110 RERROR  ;
    111         F EER=0:0 S EER=$O(MSG(EER)) Q:'EER  S:$P(MSG(EER),"|")="PV1" PSERRPV1=MSG(EER) S:$P(MSG(EER),"|")="PID" PSERRPID=MSG(EER) S:$P(MSG(EER),"|")="ORC"&($G(PSERRORC)="") PSERRORC=MSG(EER)
    112         N MSG
    113         S PSOMSORR=1 D INIT
    114         S MSG(2)=$G(PSERRPID),MSG(3)=$G(PSERRPV1)
    115         S MSG(4)="ORC|"_$S($G(XOFLAGZ):"UX",1:"UA")_"|"_$G(PLACER)_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PSERRORC),"|",4)'="":$P(PSERRORC,"|",4),1:"")
    116         F EER=11,13 I $P($G(PSERRORC),"|",EER)'="" S $P(MSG(4),"|",EER)=$P($G(PSERRORC),"|",EER)
    117         S $P(MSG(4),"|",17)="D^Duplicate^99ORN^^"_$S($G(XOFLAGZ):"Patient mismatch on previous order.",$G(NWFLAG):"Patient Mismatch on new CPRS order",$G(PSOXRP):"Patient mismatch on Renewal.",1:"Duplicate Renewal Request. Order rejected by Pharmacy.")
    118         I $G(PSOCVI) S $P(MSG(4),"|",17)="D^Duplicate^99ORN^^Order mismatch on Renewal."
    119         D SEND K PSOMSORR Q
    120         ;
    121 DCP     ;
    122         K ^PS(52.41,"AOR",+$G(DFN),+$P($G(^PS(52.41,+$G(PREV),"INI")),"^"),+$G(PREV)) S $P(^PS(52.41,+$G(PREV),0),"^",3)="DE"
    123         S PSORPV=1 N PSOMSORR
    124         D EN^PSOHLSN(+$P($G(^PS(52.41,+$G(PREV),0)),"^"),"OC","","A")
    125         K PSORPV
    126         Q
    127 REN     ;Update previous Rx on Cancel/Discontinue
    128         N RPREV,RENOC,RENOCP,RENSTA,PSOMSORR
    129         I $G(PSOHSTAT)'="OC",$G(PSOHSTAT)'="CR",$G(PSOHSTAT)'="DR",$G(PSOHSTAT)'="OD" Q
    130         Q:'$D(^PS(52.41,+$G(PSOPSIEN),0))
    131         S RPREV=$P($G(^PS(52.41,+$G(PSOPSIEN),0)),"^",21) Q:'$G(RPREV)!('$D(^PSRX(+$G(RPREV),0)))
    132         S RENSTA=$P($G(^PSRX(+$G(RPREV),"STA")),"^") Q:$G(RENSTA)=""
    133         S RENOC="SC",RENOCP=$S(RENSTA=0:"CM",(RENSTA=1!(RENSTA=4)):"IP",(RENSTA=3!(RENSTA=16)):"HD",RENSTA=5:"ZS",RENSTA=11:"ZE",RENSTA=15:"RP",1:"DC")
    134         D EN^PSOHLSN1(RPREV,RENOC,RENOCP,"","")
    135         Q
    136         ;
    137 DELP    ;Delete refill requests
    138         I $G(PSODEATH) Q
    139         N DA,PENDDA
    140         S PENDDA=$P($G(^PSRX(+$G(PSRXIEN),"OR1")),"^",2) I 'PENDDA Q
    141         S DA=$O(^PS(52.41,"B",PENDDA,0)) I '$G(DA) Q
    142         I $P($G(^PS(52.41,DA,0)),"^",3)="RF" S DIK="^PS(52.41," D ^DIK K DIK
    143         Q
    144 SEGPARX ;
    145         N PSOFIELD
    146         S COUNT=COUNT+1,CT=1,(PVAR,PVAR1)=""
    147         F MM=0:1:LIMIT I MM'=1 S FIELD(MM)=$S(FIELD(MM)="":"|",1:FIELD(MM)_"|")
    148         F MM=0:0 S MM=$O(FIELD(1,MM)) I '$O(FIELD(1,MM)) S FIELD(1,MM)=$S(FIELD(1,MM)="":"|",1:FIELD(1,MM)_"|") Q
    149         I $L(FIELD(LIMIT))>1 S FIELD(LIMIT)=$E(FIELD(LIMIT),1,($L(FIELD(LIMIT))-1))
    150         F MM=0:1:LIMIT S SEG1=FIELD(MM) D:MM=1 SEGXX I MM'=1 F CC=1:1:$L(SEG1) D  I $L(PVAR)=245 S PSOFIELD(CT)=PVAR,CT=CT+1,PVAR=""
    151         .S PVAR1=$E(SEG1,CC)
    152         .S PLIM=PVAR
    153         .S PVAR=$S(PVAR="":PVAR1,1:PVAR_PVAR1)
    154         I $G(PVAR)'="" S PSOFIELD(CT)=PVAR
    155         S MSG(COUNT)=PSOFIELD(1),SUBCOUNT=1 F GG=2:1 Q:'$D(PSOFIELD(GG))  S MSG(COUNT,SUBCOUNT)=PSOFIELD(GG),SUBCOUNT=SUBCOUNT+1
    156         Q
    157 SEGXX   ;
    158         N MMZ F MMZ=0:0 S MMZ=$O(FIELD(MM,MMZ)) Q:'MMZ  S SEG1=FIELD(MM,MMZ) F CC=1:1:$L(SEG1) D  I $L(PVAR)=245 S PSOFIELD(CT)=PVAR,CT=CT+1,PVAR=""
    159         .S PVAR1=$E(SEG1,CC)
    160         .S PLIM=PVAR
    161         .S PVAR=$S(PVAR="":PVAR1,1:PVAR_PVAR1)
    162         Q
    163 CHKOLDRX        ; when dc a pending renewal - if prior Rx is expired, set piece 19 to 1 so will update CPRS from 'renewed' to 'expired' in PSOHLSN1
    164         N PSOOLD
    165         S PSOOLD=$P($G(^PS(52.41,PSIEN,0)),"^",21)
    166         I PSOOLD'="",$P($G(^PSRX(PSOOLD,"STA")),"^")=11 S $P(^PSRX(PSOOLD,0),"^",19)=1
    167         Q
     1PSOHLSN ;BIR/RTR-Send order information to OERR from file 52.41 ;10/10/94
     2 ;;7.0;OUTPATIENT PHARMACY;**1,7,15,24,27,30,55,46,98,88,121**;DEC 1997
     3 ;Externel reference EN^ORERR supported by DBIA 2187
     4 ;
     5 ; PS EVSEND OR PROTOCOL MUST BE OUR DRIVER RTN, (52 OR 52.41 INDICATOR
     6 ; IS SENT THERE, THEN IT ROUTES, (NO NEED TO SEND FILE NUMBER HERE)
     7EN(PLACER,STAT,COMM,PSNOO) ;
     8 N DA,FIELD,J,JJ,MSG,LIMIT,NULLFLDS,PSIEN,PSOHINST,PSZERO,SEGMENT,NAME,DFN,COUNT,GG,CC,CT,MM,PVAR,PVAR1,PLIM,SEG1,SUBCOUNT,PSOPSTRT,PSOPSTOP,PSODFN,EDUZ,PSNOOTX,PSOHSTAT,PSOPSIEN
     9 S (PSIEN,PSOPSIEN)=$O(^PS(52.41,"B",PLACER,0))
     10 S COUNT=0
     11 ;I '$G(PSIEN) W !!,?5,"PROBLEM WITH ENTRY IN PENDING FILE!",! Q
     12 I '$G(PSIEN) Q
     13 I $G(STAT)="OC"!($G(STAT)="OD")!($G(STAT)="CR")!($G(STAT)="DR") D
     14 .I $D(^PS(52.41,PSIEN,0)) K ^PS(52.41,"AD",$P(^PS(52.41,PSIEN,0),"^",12),+$P($G(^("INI")),"^"),PSIEN),^PS(52.41,"ACL",+$P(^PS(52.41,PSIEN,0),"^",13),+$P(^(0),"^",12),PSIEN),^PS(52.41,"AQ",+$P($G(^PS(52.41,PSIEN,0)),"^",21),PSIEN)
     15 S PSZERO=$G(^PS(52.41,PSIEN,0)),PSOHSTAT=$G(STAT)
     16 S NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)="""""
     17 D INIT
     18 I $G(STAT)="Z@" S COUNT=1 D PID,PV1,ORC,SEND Q
     19 S COUNT=1 D PID,PV1,ORC,RXE,ZRX,SEND,REN Q
     20INIT K ^UTILITY("DIQ1",$J),DIQ S DA=$P($$SITE^VASITE(),"^") I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOHINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIQ,DIC
     21 S MSG(1)="MSH|^~\&|PHARMACY|"_$G(PSOHINST)_"|||||"_$S($G(PSOMSORR):"ORR",1:"ORM")
     22 Q
     23PID S LIMIT=5 X NULLFLDS
     24 S FIELD(0)="PID"
     25 S DFN=+$P(PSZERO,"^",2) D DEM^VADPT S NAME=$G(VADM(1)) K VADM
     26 S FIELD(3)=DFN
     27 S FIELD(5)=NAME
     28 D SEG Q
     29PV1 S LIMIT=19 X NULLFLDS
     30 S FIELD(0)="PV1"
     31 S FIELD(2)="O"
     32 S:$P($G(^PS(52.41,PSIEN,0)),"^",13) FIELD(3)=$P(^(0),"^",13)
     33 D SEG Q
     34ORC S LIMIT=15 X NULLFLDS
     35 S FIELD(0)="ORC"
     36 S FIELD(1)=STAT
     37 S FIELD(2)=PLACER_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"
     38 S FIELD(3)=PSIEN_"S"_"^PS"
     39 I $G(FIELD(5))="" I $G(STAT)="OR"!($G(STAT)="OE") S FIELD(5)="IP"
     40 S:$G(COMM)="IP" FIELD(5)="IP"
     41 I $G(STAT)="SC" S FIELD(5)=$S($G(COMM)="IP":"IP",$G(COMM)="HD":"HD",$G(COMM)="DC":"DC",1:"")
     42 I $G(PSORPV),$G(STAT)="OC" S FIELD(5)="RP"
     43 ;S (PSOPSTRT,PSOPSTOP)="" S X=$P($G(^PS(52.41,PSIEN,0)),"^",6) I X S PSOPSTRT=$$FMTHL7^XLFDT(X)
     44 ;I $G(STAT)="CR"!($G(STAT)="OC") D:'$G(DT)  S X=DT S PSOPSTOP=$$FMTHL7^XLFDT(X)
     45 ;.S DT=$$DT^XLFDT
     46 ;K X S FIELD(7)="^^^"_$G(PSOPSTRT)_"^"_$G(PSOPSTOP)
     47 S EDUZ=$P($G(^PS(52.41,PSIEN,0)),"^",4) I EDUZ D USER^PSOORFI2(EDUZ) S FIELD(10)=EDUZ_"^"_USER1 K USER1
     48 I $G(PSOCANRC),$G(PSOCANRN)'="" I $G(STAT)="OC"!($G(STAT)="OD") S FIELD(12)=$G(PSOCANRC)_"^"_$G(PSOCANRN)
     49 I '$G(FIELD(12)) D USER^PSOORFI2($P(^PS(52.41,PSIEN,0),"^",5))
     50 I '$G(FIELD(12)) S FIELD(12)=$P(^PS(52.41,PSIEN,0),"^",5)_"^"_USER1 K USER1
     51 S FIELD(15)=$G(PSOPSTRT)
     52 D SEG
     53 I $G(COMM)'=""!($G(PSNOO)'="") D
     54 .I $G(PSNOO)="" I $G(COMM)="IP"!($G(COMM)="HD")!($G(COMM)="DC") Q
     55 .I $G(PSNOO)'="" D NOO^PSOHLSN1
     56 .I '$D(COMM) S COMM=""
     57 .I $L($G(COMM))+($L(MSG(COUNT)))+($L($G(PSNOOTX)))+($S($G(PSNOO)'="":11,1:5))<245 S MSG(COUNT)=MSG(COUNT)_"|"_$G(PSNOO)_"^"_$G(PSNOOTX)_"^"_$S($G(PSNOO)'="":"99ORN",1:"")_"^^"_$S(COMM="IP"!(COMM="DC")!(COMM="HD"):"",1:$G(COMM))_"^" Q
     58 .S MSG(COUNT,1)="|"_$G(PSNOO)_"^"_$G(PSNOOTX)_"^"_$S($G(PSNOO)'="":"99ORN",1:"")_"^^"_$S(COMM="IP"!(COMM="DC")!(COMM="HD"):"",1:$G(COMM))_"^" Q
     59 Q
     60RXE S LIMIT=1 X NULLFLDS
     61 S FIELD(0)="RXE"
     62 S (PSOPSTRT,PSOPSTOP)="" S X=$P($G(^PS(52.41,PSIEN,0)),"^",6) I X S PSOPSTRT=$$FMTHL7^XLFDT(X)
     63 I $G(STAT)="CR"!($G(STAT)="OC") D:'$G(DT)  S X=DT S PSOPSTOP=$$FMTHL7^XLFDT(X)
     64 .S DT=$$DT^XLFDT
     65 K X S FIELD(1)="^^^"_$G(PSOPSTRT)_"^"_$G(PSOPSTOP)
     66 D SEG Q
     67 ;
     68ZRX ;
     69 ;Only send if DC is from an external system
     70 I $G(STAT)'="OC",$G(STAT)'="OD" Q
     71 I '$G(PSOHUIOR)!('$G(PSOCANRC)) Q
     72 I $P($G(^PS(52.41,PSIEN,"EXT")),"^")="" Q
     73 S LIMIT=5 X NULLFLDS
     74 S FIELD(0)="ZRX"
     75 S FIELD(5)=PSOCANRC_"^"_$P($G(^VA(200,PSOCANRC,0)),"^")_"^"_"99NP"
     76 D SEG
     77 Q
     78 ;
     79SEG S SEGMENT="" F J=0:1:LIMIT S SEGMENT=$S(SEGMENT="":FIELD(J),1:SEGMENT_"|"_FIELD(J))
     80 S COUNT=COUNT+1,MSG(COUNT)=SEGMENT
     81 Q
     82SEND D MSG^XQOR("PS EVSEND OR",.MSG)
     83 Q
     84 ;
     85SEGPAR ;Parse out fields for sending segments to OERR that can be >245
     86 K PSOFIELD
     87 S COUNT=COUNT+1,CT=1,(PVAR,PVAR1)=""
     88 F MM=0:1:LIMIT S FIELD(MM)=$S(FIELD(MM)="":"|",1:FIELD(MM)_"|")
     89 I $L(FIELD(LIMIT))>1 S FIELD(LIMIT)=$E(FIELD(LIMIT),1,($L(FIELD(LIMIT))-1))
     90 F MM=0:1:LIMIT S SEG1=FIELD(MM) F CC=1:1:$L(SEG1) D  I $L(PVAR)=245 S PSOFIELD(CT)=PVAR,CT=CT+1,PVAR=""
     91 .S PVAR1=$E(SEG1,CC)
     92 .S PLIM=PVAR
     93 .S PVAR=$S(PVAR="":PVAR1,1:PVAR_PVAR1)
     94 I $G(PVAR)'="" S PSOFIELD(CT)=PVAR
     95 S MSG(COUNT)=PSOFIELD(1),SUBCOUNT=1 F GG=2:1 Q:'$D(PSOFIELD(GG))  S MSG(COUNT,SUBCOUNT)=PSOFIELD(GG),SUBCOUNT=SUBCOUNT+1
     96 K PSOFIELD
     97 Q
     98ERROR ;Builds error message from PSOHLNEW, usually means we can't find order
     99 D EN^ORERR(COMM,.MSG)
     100 N MSG,PSOHINST
     101 S PSOMSORR=1 D INIT
     102 S MSG(2)=$G(PSERRPID)
     103 S MSG(3)=$G(PSERRPV1)
     104 S MSG(4)="ORC|"_$S($G(STAT)'="":$G(STAT),1:"DE")_"|"_PLACER_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PSERRORC),"|",4)'="":$P(PSERRORC,"|",4),1:"")
     105 F EER=11,13 I $P($G(PSERRORC),"|",EER)'="" S $P(MSG(4),"|",EER)=$P($G(PSERRORC),"|",EER)
     106 I $G(COMM)'="" S $P(MSG(4),"|",17)="^^^^"_$G(COMM)
     107 D SEND K PSOMSORR Q
     108 ;
     109RERROR ;
     110 F EER=0:0 S EER=$O(MSG(EER)) Q:'EER  S:$P(MSG(EER),"|")="PV1" PSERRPV1=MSG(EER) S:$P(MSG(EER),"|")="PID" PSERRPID=MSG(EER) S:$P(MSG(EER),"|")="ORC"&($G(PSERRORC)="") PSERRORC=MSG(EER)
     111 N MSG
     112 S PSOMSORR=1 D INIT
     113 S MSG(2)=$G(PSERRPID),MSG(3)=$G(PSERRPV1)
     114 S MSG(4)="ORC|"_$S($G(XOFLAGZ):"UX",1:"UA")_"|"_$G(PLACER)_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PSERRORC),"|",4)'="":$P(PSERRORC,"|",4),1:"")
     115 F EER=11,13 I $P($G(PSERRORC),"|",EER)'="" S $P(MSG(4),"|",EER)=$P($G(PSERRORC),"|",EER)
     116 S $P(MSG(4),"|",17)="D^Duplicate^99ORN^^"_$S($G(XOFLAGZ):"Patient mismatch on previous order.",$G(NWFLAG):"Patient Mismatch on new CPRS order",$G(PSOXRP):"Patient mismatch on Renewal.",1:"Duplicate Renewal Request. Order rejected by Pharmacy.")
     117 I $G(PSOCVI) S $P(MSG(4),"|",17)="D^Duplicate^99ORN^^Order mismatch on Renewal."
     118 D SEND K PSOMSORR Q
     119 ;
     120DCP ;
     121 K ^PS(52.41,"AOR",+$G(DFN),+$P($G(^PS(52.41,+$G(PREV),"INI")),"^"),+$G(PREV)) S $P(^PS(52.41,+$G(PREV),0),"^",3)="DE"
     122 S PSORPV=1 N PSOMSORR
     123 D EN^PSOHLSN(+$P($G(^PS(52.41,+$G(PREV),0)),"^"),"OC","","A")
     124 K PSORPV
     125 Q
     126REN ;Update previous Rx on Cancel/Discontinue
     127 N RPREV,RENOC,RENOCP,RENSTA,PSOMSORR
     128 I $G(PSOHSTAT)'="OC",$G(PSOHSTAT)'="CR",$G(PSOHSTAT)'="DR",$G(PSOHSTAT)'="OD" Q
     129 Q:'$D(^PS(52.41,+$G(PSOPSIEN),0))
     130 S RPREV=$P($G(^PS(52.41,+$G(PSOPSIEN),0)),"^",21) Q:'$G(RPREV)!('$D(^PSRX(+$G(RPREV),0)))
     131 S RENSTA=$P($G(^PSRX(+$G(RPREV),"STA")),"^") Q:$G(RENSTA)=""
     132 S RENOC="SC",RENOCP=$S(RENSTA=0:"CM",(RENSTA=1!(RENSTA=4)):"IP",(RENSTA=3!(RENSTA=16)):"HD",RENSTA=5:"ZS",RENSTA=11:"ZE",RENSTA=15:"RP",1:"DC")
     133 D EN^PSOHLSN1(RPREV,RENOC,RENOCP,"","")
     134 Q
     135 ;
     136DELP ;Delete refill requests
     137 I $G(PSODEATH) Q
     138 N DA,PENDDA
     139 S PENDDA=$P($G(^PSRX(+$G(PSRXIEN),"OR1")),"^",2) I 'PENDDA Q
     140 S DA=$O(^PS(52.41,"B",PENDDA,0)) I '$G(DA) Q
     141 I $P($G(^PS(52.41,DA,0)),"^",3)="RF" S DIK="^PS(52.41," D ^DIK K DIK
     142 Q
     143SEGPARX ;
     144 N PSOFIELD
     145 S COUNT=COUNT+1,CT=1,(PVAR,PVAR1)=""
     146 F MM=0:1:LIMIT I MM'=1 S FIELD(MM)=$S(FIELD(MM)="":"|",1:FIELD(MM)_"|")
     147 F MM=0:0 S MM=$O(FIELD(1,MM)) I '$O(FIELD(1,MM)) S FIELD(1,MM)=$S(FIELD(1,MM)="":"|",1:FIELD(1,MM)_"|") Q
     148 I $L(FIELD(LIMIT))>1 S FIELD(LIMIT)=$E(FIELD(LIMIT),1,($L(FIELD(LIMIT))-1))
     149 F MM=0:1:LIMIT S SEG1=FIELD(MM) D:MM=1 SEGXX I MM'=1 F CC=1:1:$L(SEG1) D  I $L(PVAR)=245 S PSOFIELD(CT)=PVAR,CT=CT+1,PVAR=""
     150 .S PVAR1=$E(SEG1,CC)
     151 .S PLIM=PVAR
     152 .S PVAR=$S(PVAR="":PVAR1,1:PVAR_PVAR1)
     153 I $G(PVAR)'="" S PSOFIELD(CT)=PVAR
     154 S MSG(COUNT)=PSOFIELD(1),SUBCOUNT=1 F GG=2:1 Q:'$D(PSOFIELD(GG))  S MSG(COUNT,SUBCOUNT)=PSOFIELD(GG),SUBCOUNT=SUBCOUNT+1
     155 Q
     156SEGXX ;
     157 N MMZ F MMZ=0:0 S MMZ=$O(FIELD(MM,MMZ)) Q:'MMZ  S SEG1=FIELD(MM,MMZ) F CC=1:1:$L(SEG1) D  I $L(PVAR)=245 S PSOFIELD(CT)=PVAR,CT=CT+1,PVAR=""
     158 .S PVAR1=$E(SEG1,CC)
     159 .S PLIM=PVAR
     160 .S PVAR=$S(PVAR="":PVAR1,1:PVAR_PVAR1)
     161 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN1.m

    r613 r623  
    1 PSOHLSN1        ;BIR/RTR - Send order info to OERR from file 52 ;10/10/94
    2         ;;7.0;OUTPATIENT PHARMACY;**1,10,24,27,55,46,71,101,99,121,139,157,181,143,235,239,292,225**;DEC 1997;Build 29
    3         ;Ref #50.606-DBIA 2174
    4         ;#50.607-2221
    5         ;#50.7-2223
    6         ;#51.2-2226
    7         ;#50-221
    8         ;PSNDF-2195
    9         ;EN^PSSUTIL1-3179
    10         ;
    11 EN(PSRXIEN,STAT,PSSTAT,COMM,PSNOO)      ;
    12         N COUNT,DFN,J,LIMIT,NAME,NULLFLDS,PSDIEN,PSFLAG,PSND1,PSND2,PSND3,PRODUCT,UNIT,POIPTR,PSOHINST,PODOSE,PODOSENM,PSROUTE,RTNAME,SEGMENT,CCC,BBB,CSCOUNT,PPTR,MSG,PSOHSTRT,PSOHSTOP,PSOHISSD,PSORTLP,ZRXFLAG,RXE2FLAG,RXE2ONLY,PSODFN,EDUZ
    13         N PSOCDDUZ,DA,FSIG,BSIG,PSHRX,PSHORX,PSNOOTX,ZPRE,PSOZSTAT,CCCX,PSOCPS,PSOICD
    14         K FIELD
    15         I $G(STAT)="" Q
    16         I STAT="CR"!(STAT="DR")!(STAT="HR")!(STAT="OC")!(STAT="OD")!(STAT="OH")!(STAT="Z@")!(STAT="RP") S PSOZSTAT=STAT D DELP^PSOHLSN S STAT=PSOZSTAT G SKIP
    17         I STAT="SC" I $G(PSSTAT)="ZE"!($G(PSSTAT)="HD")!($G(PSSTAT)="DC") S PSOZSTAT=STAT D DELP^PSOHLSN S STAT=PSOZSTAT
    18 SKIP    ;
    19         I $G(STAT)="SC",$G(PSSTAT)="ZE",$P($G(^PSRX(+$G(PSRXIEN),0)),"^",19)=2 Q
    20         I $G(STAT)="RP" S STAT="OD",PSSTAT="RP"
    21         S COUNT=0,NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)="""""
    22         I '$D(^PSRX(PSRXIEN,0)) Q
    23         I ($G(STAT)="SC"&($G(PSSTAT)="ZE"))!($G(STAT)="OC")!($G(STAT)="OD") I $D(^PS(52.41,"AQ",PSRXIEN)) D EN^PSOHDR("PRES",PSRXIEN) Q
    24         I STAT'="SN",STAT'="ZC",'$P($G(^PSRX(PSRXIEN,"OR1")),"^",2) Q
    25         I $G(STAT)="SC",$G(PSSTAT)="ZE" S $P(^PSRX(PSRXIEN,0),"^",19)=2
    26         D INIT
    27         S COUNT=1,(ZRXFLAG,RXE2FLAG,RXE2ONLY)=0 D PID,PV1,ORC
    28         I $G(STAT)="Z@" G NCM
    29         I $G(STAT)="OK"!($G(STAT)="SN")!($G(STAT)="ZC")!($G(STAT)="XX")!($G(STAT)="SC")!($G(STAT)="RO") D RXO,RXE,RXR,ZRX,DG1,ZSC,ZCL G NCM
    30         I $G(STAT)="SC",$G(PSSTAT)="CM" D RXO,RXE,RXR,ZRX,DG1,ZSC,ZCL
    31         I '$G(RXE2FLAG) S RXE2ONLY=1 D RXE,SEGPARX^PSOHLSN
    32         I '$G(ZRXFLAG) D ZRX
    33 NCM     D SEND
    34         K PSRXIEN Q
    35 INIT    K ^UTILITY("DIQ1",$J),DIQ S DA=$P($$SITE^VASITE(),"^") I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOHINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIQ,DIC
    36         S MSG(1)="MSH|^~\&|PHARMACY|"_$G(PSOHINST)_"|||||"_$S($G(PSOMSORR):"ORR",1:"ORM")
    37         Q
    38 PID     S LIMIT=5 X NULLFLDS
    39         S DFN=+$P(^PSRX(PSRXIEN,0),"^",2) D DEM^VADPT S NAME=$G(VADM(1)) K VADM
    40         S FIELD(0)="PID"
    41         S FIELD(3)=DFN
    42         S FIELD(5)=NAME
    43         D SEG Q
    44 DG1     D DG1^PSOHLSN2
    45         Q
    46 PV1     ;
    47         S LIMIT=19 X NULLFLDS
    48         S FIELD(0)="PV1"
    49         S FIELD(2)="O"
    50         S:$P(^PSRX(PSRXIEN,0),"^",5) FIELD(3)=$P(^(0),"^",5)
    51         D SEG Q
    52 ORC     ;
    53         D ORC^PSOHLSN3
    54         Q
    55         ;
    56 RXO     ;
    57         S LIMIT=1 X NULLFLDS
    58         S FIELD(0)="RXO"
    59         S PPTR=+$P($G(^PSRX(PSRXIEN,"OR1")),"^")
    60         S FIELD(1)=$S('PPTR:"^^^^^",1:"^^^"_PPTR_"^"_$P($G(^PS(50.7,PPTR,0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^")_"^99PSP")
    61         D SEG Q
    62         ;
    63 RXE     ;
    64         S RXE2FLAG=1
    65         S LIMIT=$S('$G(RXE2ONLY):26,1:2) X NULLFLDS
    66         S FIELD(0)="RXE"
    67         S (PSOHSTRT,PSOHSTOP)="" S X=$P($G(^PSRX(PSRXIEN,2)),"^",2) I X S PSOHSTRT=$$FMTHL7^XLFDT(X)
    68         I '$G(DT) S DT=$$DT^XLFDT
    69         S X=$S($P($G(^PSRX(PSRXIEN,3)),"^",5):$P($G(^(3)),"^",5),$G(STAT)="OD"!($G(STAT)="OC"):$G(DT),$P($G(^(2)),"^",6):$P($G(^(2)),"^",6),1:$G(DT)) I X S PSOHSTOP=$$FMTHL7^XLFDT(X)
    70         K X N PSOMZT,MMZZ,MMZZT S MMZZT=1 F MMZZ=0:0 S MMZZ=$O(^PSRX(PSRXIEN,6,MMZZ)) Q:'MMZZ  D:$D(^(MMZZ,0))
    71         .S FIELD(1,MMZZT)=$S($P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^",2):$$ESC^ORHLESC($P($G(^(0)),"^"))_"\T\"_$P($G(^PS(50.607,+$P($G(^(0)),"^",3),0)),"^")_"\T\"_$P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^",2)_"\T\"_$P($G(^(0)),"^",4),1:"")
    72         .S FIELD(1,MMZZT)=FIELD(1,MMZZT)_"^"_$$ESC^ORHLESC($P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^",8))
    73         .I $P($G(FIELD(1,MMZZT)),"^")'="" F PSOMZT=1,3 I $E($P(FIELD(1,MMZZT),"\T\",PSOMZT),1)="." S $P(FIELD(1,MMZZT),"\T\",PSOMZT)="0"_$P(FIELD(1,MMZZT),"\T\",PSOMZT)
    74         .S FIELD(1,MMZZT)=$G(FIELD(1,MMZZT))_"^"_$$DUR(PSRXIEN,MMZZ)_"^^^^^"_$S($P($G(FIELD(1,MMZZT)),"^")'="":$P($G(FIELD(1,MMZZT)),"\T\")_$P($G(FIELD(1,MMZZT)),"\T\",2),1:$P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^"))
    75         .S FIELD(1,MMZZT)=$G(FIELD(1,MMZZT))_"^"_$P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^",6)
    76         .I $O(^PSRX(PSRXIEN,6,MMZZ)) S FIELD(1,MMZZT)=$G(FIELD(1,MMZZT))_"~"
    77         .S MMZZT=MMZZT+1
    78         S $P(FIELD(1,1),"^",4)=$G(PSOHSTRT),$P(FIELD(1,1),"^",5)=$G(PSOHSTOP)
    79         S PSFLAG=0,PSDIEN=+$P(^PSRX(PSRXIEN,0),"^",6),PSND1=$P($G(^PSDRUG(PSDIEN,"ND")),"^"),PSND2=$P($G(^("ND")),"^",2),PSND3=$P($G(^("ND")),"^",3) I PSND1,PSND3 S PSFLAG=1
    80         S FIELD(2)=$S(PSFLAG:PSND1_"."_PSND3_"^"_$$ESC^ORHLESC(PSND2)_"^"_"99NDF",1:"^^")_"^"_PSDIEN_"^"_$$ESC^ORHLESC($P($G(^PSDRUG(PSDIEN,0)),"^"))_"^"_"99PSD"
    81         Q:$G(RXE2ONLY)
    82         I PSFLAG D
    83         .I $T(^PSNAPIS)]"" S PSOXN=$$DFSU^PSNAPIS(PSND1,PSND3) S FIELD(5)="^^^"_$P($G(PSOXN),"^",5)_"^"_$$ESC^ORHLESC($P($G(PSOXN),"^",6))_"^"_"99PSU" K PSOXN Q
    84         .S PRODUCT=$G(^PSNDF(PSND1,5,PSND3,0)) S UNIT=$P($G(^PSNDF(PSND1,2,+$P(PRODUCT,"^",2),3,+$P(PRODUCT,"^",3),4,+$P(PRODUCT,"^",4),0)),"^")
    85         .S FIELD(5)="^^^"_UNIT_"^"_$$ESC^ORHLESC($P($G(^PS(50.607,+UNIT,0)),"^"))_"^"_"99PSU"
    86         S POIPTR=$P($G(^PSRX(PSRXIEN,"OR1")),"^") I POIPTR S PODOSE=$P($G(^PS(50.7,POIPTR,0)),"^",2),PODOSENM=$P($G(^PS(50.606,+PODOSE,0)),"^")
    87         I POIPTR S FIELD(6)="^^^"_$G(PODOSE)_"^"_$$ESC^ORHLESC($G(PODOSENM))_"^"_"99PSF"
    88         S FIELD(10)=$P(^PSRX(PSRXIEN,0),"^",7)
    89         S FIELD(12)=$P(^PSRX(PSRXIEN,0),"^",9)
    90         S FIELD(14)=$P(^PSRX(PSRXIEN,0),"^",4)
    91         S FIELD(15)=$P(^PSRX(PSRXIEN,0),"^")
    92         S FIELD(22)=$P(^PSRX(PSRXIEN,0),"^",8)
    93         K MMZZ S MMZZ=$$EN^PSSUTIL1(PSDIEN) S FIELD(25)=$S($E($P(MMZZ,"|"),1)=".":"0",1:"")_$P(MMZZ,"|"),FIELD(26)=$P(MMZZ,"|",2)
    94         N PLIM,PVAR,PVAR1,SUBCOUNT D SEGPARX^PSOHLSN
    95         ;
    96         I $O(^PSRX(PSRXIEN,"PRC",0)) D
    97         .S COUNT=COUNT+1,CCC=$O(^PSRX(PSRXIEN,"PRC",0))
    98         .S MSG(COUNT)="NTE|6||"_$$ESC^ORHLESC($G(^PSRX(PSRXIEN,"PRC",CCC,0)))
    99         .S CSCOUNT=1 F CCC=CCC:0 S CCC=$O(^PSRX(PSRXIEN,"PRC",CCC)) Q:'CCC  S MSG(COUNT,CSCOUNT)=$$ESC^ORHLESC($G(^PSRX(PSRXIEN,"PRC",CCC,0))),CSCOUNT=CSCOUNT+1
    100         I $O(^PSRX(PSRXIEN,"INS1",0)) D
    101         .S COUNT=COUNT+1,CCC=$O(^PSRX(PSRXIEN,"INS1",0))
    102         .S MSG(COUNT)="NTE|7|L|"_$$ESC^ORHLESC($G(^PSRX(PSRXIEN,"INS1",CCC,0)))
    103         .S CCCX=1 F  S CCC=$O(^PSRX(PSRXIEN,"INS1",CCC)) Q:'CCC  I $D(^PSRX(PSRXIEN,"INS1",CCC,0)) S MSG(COUNT,CCCX)=$$ESC^ORHLESC($G(^(0))) S CCCX=CCCX+1
    104         S COUNT=COUNT+1
    105         I $P($G(^PSRX(PSRXIEN,"SIG")),"^",2) D  Q
    106         .D FSIG^PSOUTLA("R",PSRXIEN,238) S MSG(COUNT)="NTE|21||"_$S($G(FSIG(1))'="":$$ESC^ORHLESC($G(FSIG(1))),1:"No SIG available") I $O(FSIG(1)) F CCC=1:0 S CCC=$O(FSIG(CCC)) Q:'CCC  S MSG(COUNT,(CCC-1))=$$ESC^ORHLESC($G(FSIG(CCC)))
    107         I '$P($G(^PSRX(PSRXIEN,"SIG")),"^",2) D  Q
    108         .D EN3^PSOUTLA1(PSRXIEN,238) S MSG(COUNT)="NTE|21||"_$S($G(BSIG(1))'="":$$ESC^ORHLESC($G(BSIG(1))),1:"No SIG available") I $O(BSIG(1)) F CCC=1:0 S CCC=$O(BSIG(CCC)) Q:'CCC  S MSG(COUNT,(CCC-1))=$$ESC^ORHLESC($G(BSIG(CCC)))
    109         Q
    110         ;
    111 RXR     ;
    112         F PSORTLP=0:0 S PSORTLP=$O(^PSRX(PSRXIEN,6,PSORTLP)) Q:'PSORTLP  D
    113         .S LIMIT=1 X NULLFLDS
    114         .S FIELD(0)="RXR"
    115         .S PSROUTE=$P($G(^PSRX(PSRXIEN,6,PSORTLP,0)),"^",7) I PSROUTE,$D(^PS(51.2,PSROUTE,0))  S RTNAME=$P(^PS(51.2,PSROUTE,0),"^")
    116         .S FIELD(1)="^^^"_$G(PSROUTE)_"^"_$G(RTNAME)_"^"_"99PSR"
    117         .D SEG
    118         Q
    119         ;
    120 ZCL     D ZCL^PSOHLSN2
    121         Q
    122 ZSC     D ZSC^PSOHLSN2
    123         Q
    124         ;
    125 ZRX     ;
    126         S ZRXFLAG=1
    127         S LIMIT=6 X NULLFLDS
    128         S FIELD(0)="ZRX"
    129         S ZPRE=$P($G(^PSRX(PSRXIEN,"OR1")),"^",3) I ZPRE S FIELD(1)=$P($G(^PSRX(ZPRE,"OR1")),"^",2)
    130         I '$G(FIELD(1)),$G(PSORDEDT) S FIELD(1)=$P($G(^PS(52.41,$G(PSORDEDT),0)),"^")
    131         S FIELD(2)=$G(PSNOO)
    132         I $G(STAT)="SN"!($G(STAT)="RO") S FIELD(3)=$S($G(STAT)="RO"!($G(PSOEDIT)):"E",$G(PSOOPT)=3:"R",1:"N")
    133         S FIELD(4)=$P(^PSRX(PSRXIEN,0),"^",11)
    134         S PSOCDDUZ=$S($G(PSOROPCH)="PATCH":$P($G(^PSRX(PSRXIEN,"OR1")),"^",5),$G(PSOHUIOR)&($P($G(^PSRX(PSRXIEN,"EXT")),"^")'=""):+$G(PSOCANRC),1:$G(DUZ))
    135         I $G(PSOCDDUZ) S FIELD(5)=PSOCDDUZ_"^"_$P($G(^VA(200,PSOCDDUZ,0)),"^")_"^"_"99NP"
    136         I $G(STAT)="ZD",$G(PSODISPP) S FIELD(6)="P"
    137         D SEG Q
    138 SEG     S SEGMENT="" F J=0:1:LIMIT S SEGMENT=$S(SEGMENT="":FIELD(J),1:SEGMENT_"|"_FIELD(J))
    139         S COUNT=COUNT+1,MSG(COUNT)=SEGMENT
    140         Q
    141 SEND    D:$G(PSRXIEN)&($T(EN^PSOHDR)]"")&($G(PSOSSMES)'="CPRSUP")  K FIELD D MSG^XQOR("PS EVSEND OR",.MSG) Q
    142         .I $G(STAT)="ZC"!($G(STAT)="UC")!($G(STAT)="UD")!($G(STAT)="UH")!($G(STAT)="UR")!($G(STAT)="DE")!($G(STAT)="ZD")!($G(STAT)="SN")!($G(STAT)="Z@") Q
    143         .I $G(STAT)="SC",$G(PSSTAT)="ZZ" Q
    144         .D EN^PSOHDR("PRES",PSRXIEN)
    145         ;
    146 NOO     ;
    147         I $G(PSNOO)="" S PSNOOTX="" Q
    148         S PSNOOTX=$S(PSNOO="W":"Written",PSNOO="V":"Verbal",PSNOO="P":"Telephoned",PSNOO="S":"Service Correction",PSNOO="X":"Rejected",PSNOO="D":"Duplicate",PSNOO="I":"Policy",PSNOO="E":"Physician Entered",PSNOO="A":"Auto DC",1:"") Q
    149         Q
    150         ;
    151 DUR(PSODX1,PSODX2)      ;
    152         N PSODX,PSODX4,PSODX5,PSODX6,PSODX7 S PSODX=$P($G(^PSRX(PSODX1,6,PSODX2,0)),"^",5)
    153         I 'PSODX Q PSODX
    154         S PSODX4=$L(PSODX),PSODX5=$E(PSODX,PSODX4)
    155         S PSODX=$S(PSODX5?1A:PSODX,1:PSODX_"D")
    156         S PSODX6=$L(PSODX)
    157         S PSODX7=$E(PSODX,PSODX6)_$E(PSODX,1,(PSODX6-1))
    158         Q PSODX7
    159         Q
     1PSOHLSN1 ;BIR/RTR - Send order info to OERR from file 52 ;10/10/94
     2 ;;7.0;OUTPATIENT PHARMACY;**1,10,24,27,55,46,71,101,99,121,139,157,181,143,235,239**;DEC 1997
     3 ;Ref #50.606-DBIA 2174
     4 ;#50.607-2221
     5 ;#50.7-2223
     6 ;#51.2-2226
     7 ;#50-221
     8 ;PSNDF-2195
     9 ;EN^PSSUTIL1-3179
     10 ;
     11EN(PSRXIEN,STAT,PSSTAT,COMM,PSNOO) ;
     12 N COUNT,DFN,J,LIMIT,NAME,NULLFLDS,PSDIEN,PSFLAG,PSND1,PSND2,PSND3,PRODUCT,UNIT,POIPTR,PSOHINST,PODOSE,PODOSENM,PSROUTE,RTNAME,SEGMENT,CCC,BBB,CSCOUNT,PPTR,MSG,PSOHSTRT,PSOHSTOP,PSOHISSD,PSORTLP,ZRXFLAG,RXE2FLAG,RXE2ONLY,PSODFN,EDUZ
     13 N PSOCDDUZ,DA,FSIG,BSIG,PSHRX,PSHORX,PSNOOTX,ZPRE,PSOZSTAT,CCCX,PSOCPS,PSOICD
     14 K FIELD
     15 I $G(STAT)="" Q
     16 I STAT="CR"!(STAT="DR")!(STAT="HR")!(STAT="OC")!(STAT="OD")!(STAT="OH")!(STAT="Z@")!(STAT="RP") S PSOZSTAT=STAT D DELP^PSOHLSN S STAT=PSOZSTAT G SKIP
     17 I STAT="SC" I $G(PSSTAT)="ZE"!($G(PSSTAT)="HD")!($G(PSSTAT)="DC") S PSOZSTAT=STAT D DELP^PSOHLSN S STAT=PSOZSTAT
     18SKIP ;
     19 I $G(STAT)="SC",$G(PSSTAT)="ZE",$P($G(^PSRX(+$G(PSRXIEN),0)),"^",19)=2 Q
     20 I $G(STAT)="RP" S STAT="OD",PSSTAT="RP"
     21 S COUNT=0,NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)="""""
     22 I '$D(^PSRX(PSRXIEN,0)) Q
     23 I STAT'="SN",STAT'="ZC",'$P($G(^PSRX(PSRXIEN,"OR1")),"^",2) Q
     24 I $G(STAT)="SC",$G(PSSTAT)="ZE" S $P(^PSRX(PSRXIEN,0),"^",19)=2
     25 D INIT
     26 S COUNT=1,(ZRXFLAG,RXE2FLAG,RXE2ONLY)=0 D PID,PV1,ORC
     27 I $G(STAT)="Z@" G NCM
     28 I $G(STAT)="OK"!($G(STAT)="SN")!($G(STAT)="ZC")!($G(STAT)="XX")!($G(STAT)="SC")!($G(STAT)="RO") D RXO,RXE,RXR,ZRX,DG1,ZSC,ZCL G NCM
     29 I $G(STAT)="SC",$G(PSSTAT)="CM" D RXO,RXE,RXR,ZRX,DG1,ZSC,ZCL
     30 I '$G(RXE2FLAG) S RXE2ONLY=1 D RXE,SEGPARX^PSOHLSN
     31 I '$G(ZRXFLAG) D ZRX
     32NCM D SEND
     33 K PSRXIEN Q
     34INIT K ^UTILITY("DIQ1",$J),DIQ S DA=$P($$SITE^VASITE(),"^") I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOHINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIQ,DIC
     35 S MSG(1)="MSH|^~\&|PHARMACY|"_$G(PSOHINST)_"|||||"_$S($G(PSOMSORR):"ORR",1:"ORM")
     36 Q
     37PID S LIMIT=5 X NULLFLDS
     38 S DFN=+$P(^PSRX(PSRXIEN,0),"^",2) D DEM^VADPT S NAME=$G(VADM(1)) K VADM
     39 S FIELD(0)="PID"
     40 S FIELD(3)=DFN
     41 S FIELD(5)=NAME
     42 D SEG Q
     43DG1 D DG1^PSOHLSN2
     44 Q
     45PV1 ;
     46 S LIMIT=19 X NULLFLDS
     47 S FIELD(0)="PV1"
     48 S FIELD(2)="O"
     49 S:$P(^PSRX(PSRXIEN,0),"^",5) FIELD(3)=$P(^(0),"^",5)
     50 D SEG Q
     51ORC ;
     52 S LIMIT=15 X NULLFLDS
     53 S FIELD(0)="ORC"
     54 S FIELD(1)=$G(STAT)
     55 I $G(STAT)'="SN",$G(STAT)'="ZC" S FIELD(2)=$P($G(^PSRX(PSRXIEN,"OR1")),"^",2)
     56 S:FIELD(2)'="" FIELD(2)=FIELD(2)_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"
     57 S FIELD(3)=PSRXIEN_"^PS"
     58 S FIELD(5)=$G(PSSTAT)
     59 I $G(STAT)="RO",$G(PSOROPCH)'="PATCH" S FIELD(5)="CM"
     60 I $G(FIELD(5))="" I $G(STAT)="OR"!($G(STAT)="OE") S FIELD(5)="CM"
     61 S X=$P($G(^PSRX(PSRXIEN,2)),"^") I X S FIELD(9)=$$FMTHL7^XLFDT(X)
     62 S EDUZ=$P($G(^PSRX(PSRXIEN,0)),"^",16) I EDUZ S FIELD(10)=EDUZ_"^"_$P($G(^VA(200,EDUZ,0)),"^")
     63 I $G(PSOCANRC),$G(PSOCANRN)'="" I $G(STAT)="OD"!($G(STAT)="OC") S FIELD(12)=$G(PSOCANRC)_"^"_$G(PSOCANRN)
     64 I '$G(FIELD(12)) S FIELD(12)=$P($G(^PSRX(PSRXIEN,0)),"^",4)_"^"_$P($G(^VA(200,+$P($G(^PSRX(PSRXIEN,0)),"^",4),0)),"^")
     65 S PSOHISSD="",X=$P($G(^PSRX(PSRXIEN,0)),"^",13) I X S PSOHISSD=$$FMTHL7^XLFDT(X)
     66 S FIELD(15)=$G(PSOHISSD) K X
     67 D SEG
     68 I $G(COMM)'=""!($G(PSNOO)'="") D
     69 .I $G(PSNOO)'="" D NOO
     70 .I $L($G(COMM))+($L(MSG(COUNT)))+($L($G(PSNOOTX)))+($S($G(PSNOO)'="":11,1:5))<245 S MSG(COUNT)=MSG(COUNT)_"|"_$G(PSNOO)_"^"_$G(PSNOOTX)_"^"_$S($G(PSNOO)'="":"99ORN",1:"")_"^^"_$G(COMM)_"^" Q
     71 .S MSG(COUNT,1)="|"_$G(PSNOO)_"^"_$G(PSNOOTX)_"^"_$S($G(PSNOO)'="":"99ORN",1:"")_"^^"_$G(COMM)_"^"
     72 Q
     73 ;
     74RXO ;
     75 S LIMIT=1 X NULLFLDS
     76 S FIELD(0)="RXO"
     77 S PPTR=+$P($G(^PSRX(PSRXIEN,"OR1")),"^")
     78 S FIELD(1)=$S('PPTR:"^^^^^",1:"^^^"_PPTR_"^"_$P($G(^PS(50.7,PPTR,0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^")_"^99PSP")
     79 D SEG Q
     80 ;
     81RXE ;
     82 S RXE2FLAG=1
     83 S LIMIT=$S('$G(RXE2ONLY):26,1:2) X NULLFLDS
     84 S FIELD(0)="RXE"
     85 S (PSOHSTRT,PSOHSTOP)="" S X=$P($G(^PSRX(PSRXIEN,2)),"^",2) I X S PSOHSTRT=$$FMTHL7^XLFDT(X)
     86 I '$G(DT) S DT=$$DT^XLFDT
     87 S X=$S($P($G(^PSRX(PSRXIEN,3)),"^",5):$P($G(^(3)),"^",5),$G(STAT)="OD"!($G(STAT)="OC"):$G(DT),$P($G(^(2)),"^",6):$P($G(^(2)),"^",6),1:$G(DT)) I X S PSOHSTOP=$$FMTHL7^XLFDT(X)
     88 K X N PSOMZT,MMZZ,MMZZT S MMZZT=1 F MMZZ=0:0 S MMZZ=$O(^PSRX(PSRXIEN,6,MMZZ)) Q:'MMZZ  D:$D(^(MMZZ,0))
     89 .S FIELD(1,MMZZT)=$S($P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^",2):$P($G(^(0)),"^")_"&"_$P($G(^PS(50.607,+$P($G(^(0)),"^",3),0)),"^")_"&"_$P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^",2)_"&"_$P($G(^(0)),"^",4),1:"")_"^"_$P($G(^(0)),"^",8)
     90 .I $P($G(FIELD(1,MMZZT)),"^")'="" F PSOMZT=1,3 I $E($P(FIELD(1,MMZZT),"&",PSOMZT),1)="." S $P(FIELD(1,MMZZT),"&",PSOMZT)="0"_$P(FIELD(1,MMZZT),"&",PSOMZT)
     91 .S FIELD(1,MMZZT)=$G(FIELD(1,MMZZT))_"^"_$$DUR(PSRXIEN,MMZZ)_"^^^^^"_$S($P($G(FIELD(1,MMZZT)),"^")'="":$P($G(FIELD(1,MMZZT)),"&")_$P($G(FIELD(1,MMZZT)),"&",2),1:$P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^"))
     92 .S FIELD(1,MMZZT)=$G(FIELD(1,MMZZT))_"^"_$P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^",6)
     93 .I $O(^PSRX(PSRXIEN,6,MMZZ)) S FIELD(1,MMZZT)=$G(FIELD(1,MMZZT))_"~"
     94 .S MMZZT=MMZZT+1
     95 S $P(FIELD(1,1),"^",4)=$G(PSOHSTRT),$P(FIELD(1,1),"^",5)=$G(PSOHSTOP)
     96 S PSFLAG=0,PSDIEN=+$P(^PSRX(PSRXIEN,0),"^",6),PSND1=$P($G(^PSDRUG(PSDIEN,"ND")),"^"),PSND2=$P($G(^("ND")),"^",2),PSND3=$P($G(^("ND")),"^",3) I PSND1,PSND3 S PSFLAG=1
     97 S FIELD(2)=$S(PSFLAG:PSND1_"."_PSND3_"^"_PSND2_"^"_"99NDF",1:"^^")_"^"_PSDIEN_"^"_$P($G(^PSDRUG(PSDIEN,0)),"^")_"^"_"99PSD"
     98 Q:$G(RXE2ONLY)
     99 I PSFLAG D
     100 .I $T(^PSNAPIS)]"" S PSOXN=$$DFSU^PSNAPIS(PSND1,PSND3) S FIELD(5)="^^^"_$P($G(PSOXN),"^",5)_"^"_$P($G(PSOXN),"^",6)_"^"_"99PSU" K PSOXN Q
     101 .S PRODUCT=$G(^PSNDF(PSND1,5,PSND3,0)) S UNIT=$P($G(^PSNDF(PSND1,2,+$P(PRODUCT,"^",2),3,+$P(PRODUCT,"^",3),4,+$P(PRODUCT,"^",4),0)),"^")
     102 .S FIELD(5)="^^^"_UNIT_"^"_$P($G(^PS(50.607,+UNIT,0)),"^")_"^"_"99PSU"
     103 S POIPTR=$P($G(^PSRX(PSRXIEN,"OR1")),"^") I POIPTR S PODOSE=$P($G(^PS(50.7,POIPTR,0)),"^",2),PODOSENM=$P($G(^PS(50.606,+PODOSE,0)),"^")
     104 I POIPTR S FIELD(6)="^^^"_$G(PODOSE)_"^"_$G(PODOSENM)_"^"_"99PSF"
     105 S FIELD(10)=$P(^PSRX(PSRXIEN,0),"^",7)
     106 S FIELD(12)=$P(^PSRX(PSRXIEN,0),"^",9)
     107 S FIELD(14)=$P(^PSRX(PSRXIEN,0),"^",4)
     108 S FIELD(15)=$P(^PSRX(PSRXIEN,0),"^")
     109 S FIELD(22)=$P(^PSRX(PSRXIEN,0),"^",8)
     110 K MMZZ S MMZZ=$$EN^PSSUTIL1(PSDIEN) S FIELD(25)=$S($E($P(MMZZ,"|"),1)=".":"0",1:"")_$P(MMZZ,"|"),FIELD(26)=$P(MMZZ,"|",2)
     111 N PLIM,PVAR,PVAR1,SUBCOUNT D SEGPARX^PSOHLSN
     112 ;
     113 I $O(^PSRX(PSRXIEN,"PRC",0)) D
     114 .S COUNT=COUNT+1,CCC=$O(^PSRX(PSRXIEN,"PRC",0))
     115 .S MSG(COUNT)="NTE|6||"_$G(^PSRX(PSRXIEN,"PRC",CCC,0))
     116 .S CSCOUNT=1 F CCC=CCC:0 S CCC=$O(^PSRX(PSRXIEN,"PRC",CCC)) Q:'CCC  S MSG(COUNT,CSCOUNT)=$G(^PSRX(PSRXIEN,"PRC",CCC,0)),CSCOUNT=CSCOUNT+1
     117 I $O(^PSRX(PSRXIEN,"INS1",0)) D
     118 .S COUNT=COUNT+1,CCC=$O(^PSRX(PSRXIEN,"INS1",0))
     119 .S MSG(COUNT)="NTE|7|L|"_$G(^PSRX(PSRXIEN,"INS1",CCC,0))
     120 .S CCCX=1 F CCC=CCC:0 S CCC=$O(^PSRX(PSRXIEN,"INS1",CCC,0)) Q:'CCC  I $D(^(0)) S MSG(COUNT,CCCX)=$G(^(0)) S CCCX=CCCX+1
     121 S COUNT=COUNT+1
     122 I $P($G(^PSRX(PSRXIEN,"SIG")),"^",2) D  Q
     123 .D FSIG^PSOUTLA("R",PSRXIEN,238) S MSG(COUNT)="NTE|21||"_$S($G(FSIG(1))'="":$G(FSIG(1)),1:"No SIG available") I $O(FSIG(1)) F CCC=1:0 S CCC=$O(FSIG(CCC)) Q:'CCC  S MSG(COUNT,(CCC-1))=$G(FSIG(CCC))
     124 I '$P($G(^PSRX(PSRXIEN,"SIG")),"^",2) D  Q
     125 .D EN3^PSOUTLA1(PSRXIEN,238) S MSG(COUNT)="NTE|21||"_$S($G(BSIG(1))'="":$G(BSIG(1)),1:"No SIG available") I $O(BSIG(1)) F CCC=1:0 S CCC=$O(BSIG(CCC)) Q:'CCC  S MSG(COUNT,(CCC-1))=$G(BSIG(CCC))
     126 Q
     127 ;
     128RXR ;
     129 F PSORTLP=0:0 S PSORTLP=$O(^PSRX(PSRXIEN,6,PSORTLP)) Q:'PSORTLP  D
     130 .S LIMIT=1 X NULLFLDS
     131 .S FIELD(0)="RXR"
     132 .S PSROUTE=$P($G(^PSRX(PSRXIEN,6,PSORTLP,0)),"^",7) I PSROUTE,$D(^PS(51.2,PSROUTE,0))  S RTNAME=$P(^PS(51.2,PSROUTE,0),"^")
     133 .S FIELD(1)="^^^"_$G(PSROUTE)_"^"_$G(RTNAME)_"^"_"99PSR"
     134 .D SEG
     135 Q
     136 ;
     137ZCL D ZCL^PSOHLSN2
     138 Q
     139ZSC D ZSC^PSOHLSN2
     140 Q
     141 ;
     142ZRX ;
     143 S ZRXFLAG=1
     144 S LIMIT=6 X NULLFLDS
     145 S FIELD(0)="ZRX"
     146 S ZPRE=$P($G(^PSRX(PSRXIEN,"OR1")),"^",3) I ZPRE S FIELD(1)=$P($G(^PSRX(ZPRE,"OR1")),"^",2)
     147 I '$G(FIELD(1)),$G(PSORDEDT) S FIELD(1)=$P($G(^PS(52.41,$G(PSORDEDT),0)),"^")
     148 S FIELD(2)=$G(PSNOO)
     149 I $G(STAT)="SN"!($G(STAT)="RO") S FIELD(3)=$S($G(STAT)="RO"!($G(PSOEDIT)):"E",$G(PSOOPT)=3:"R",1:"N")
     150 S FIELD(4)=$P(^PSRX(PSRXIEN,0),"^",11)
     151 S PSOCDDUZ=$S($G(PSOROPCH)="PATCH":$P($G(^PSRX(PSRXIEN,"OR1")),"^",5),$G(PSOHUIOR)&($P($G(^PSRX(PSRXIEN,"EXT")),"^")'=""):+$G(PSOCANRC),1:$G(DUZ))
     152 I $G(PSOCDDUZ) S FIELD(5)=PSOCDDUZ_"^"_$P($G(^VA(200,PSOCDDUZ,0)),"^")_"^"_"99NP"
     153 I $G(STAT)="ZD",$G(PSODISPP) S FIELD(6)="P"
     154 D SEG Q
     155SEG S SEGMENT="" F J=0:1:LIMIT S SEGMENT=$S(SEGMENT="":FIELD(J),1:SEGMENT_"|"_FIELD(J))
     156 S COUNT=COUNT+1,MSG(COUNT)=SEGMENT
     157 Q
     158SEND D:$G(PSRXIEN)&($T(EN^PSOHDR)]"")&($G(PSOSSMES)'="CPRSUP")  K FIELD D MSG^XQOR("PS EVSEND OR",.MSG) Q
     159 .I $G(STAT)="ZC"!($G(STAT)="UC")!($G(STAT)="UD")!($G(STAT)="UH")!($G(STAT)="UR")!($G(STAT)="DE")!($G(STAT)="ZD")!($G(STAT)="SN")!($G(STAT)="Z@") Q
     160 .I $G(STAT)="SC",$G(PSSTAT)="ZZ" Q
     161 .D EN^PSOHDR("PRES",PSRXIEN)
     162 ;
     163NOO ;
     164 I $G(PSNOO)="" S PSNOOTX="" Q
     165 S PSNOOTX=$S(PSNOO="W":"Written",PSNOO="V":"Verbal",PSNOO="P":"Telephoned",PSNOO="S":"Service Correction",PSNOO="X":"Rejected",PSNOO="D":"Duplicate",PSNOO="I":"Policy",PSNOO="E":"Physician Entered",PSNOO="A":"Auto DC",1:"") Q
     166 Q
     167 ;
     168DUR(PSODX1,PSODX2) ;
     169 N PSODX,PSODX4,PSODX5,PSODX6,PSODX7 S PSODX=$P($G(^PSRX(PSODX1,6,PSODX2,0)),"^",5)
     170 I 'PSODX Q PSODX
     171 S PSODX4=$L(PSODX),PSODX5=$E(PSODX,PSODX4)
     172 S PSODX=$S(PSODX5?1A:PSODX,1:PSODX_"D")
     173 S PSODX6=$L(PSODX)
     174 S PSODX7=$E(PSODX,PSODX6)_$E(PSODX,1,(PSODX6-1))
     175 Q PSODX7
     176 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN2.m

    r613 r623  
    1 PSOHLSN2        ;BIR/LE - Utilities for PSOHLSN1 ;02/27/04
    2         ;;7.0;OUTPATIENT PHARMACY;**143,226,239,225**;DEC 1997;Build 29
    3         ;
    4 DG1     ;this section builds both DG1 segments
    5         Q:'$D(^PSRX(PSRXIEN,"ICD",1,0))
    6         N LP,DG,DXDESC,I
    7         S LIMIT=4,FIELD(0)="DG1",FIELD(4)=""
    8         ;I '$D(^PSRX(PSRXIEN,"ICD",1,0)) S FIELD(1)=1,FIELD(2)="",FIELD(3)="^^^^^" D SEG^PSOHLSN1 Q
    9         I $P(^PSRX(PSRXIEN,"ICD",1,0),"^",1)="" Q  ;S FIELD(1)=1,FIELD(2)="",FIELD(3)="^^^^^" D SEG^PSOHLSN1 Q
    10         F I=1:1:8 D
    11         . Q:'$D(^PSRX(PSRXIEN,"ICD",I,0))
    12         . S PSOICD="",PSOICD=^PSRX(PSRXIEN,"ICD",I,0) Q:$P(PSOICD,U,1)=""
    13         . S (DG,DXDESC)=""
    14         . I $P(PSOICD,U,1)'="" D
    15         .. S DXDESC=$$GET1^DIQ(80,$P(PSOICD,U,1)_",",10),FIELD(1)=I,FIELD(2)=""
    16         .. S FIELD(3)=$P(PSOICD,U,1)_U_DXDESC_U_"80"_U_$$GET1^DIQ(80,$P(PSOICD,U,1)_",",.01)_U_DXDESC_U_"ICD9"
    17         .. D SEG^PSOHLSN1
    18         K PSOICD("K")
    19         Q
    20 ZCL     N STOP,IBQ,ICD,I,JJJ,EI
    21         S LIMIT=3,FIELD(0)="ZCL"
    22         I '$D(^PSRX(PSRXIEN,"ICD"))&($D(^PSRX(PSRXIEN,"IBQ"))) D    ;For edits; currently CPRS doesn't update SC/EI for edits, but just in case they start
    23         . S FIELD(1)=1,FIELD(2)=3
    24         . S EI="",EI=^PSRX(PSRXIEN,"IBQ")
    25         . S JJJ=0 F I=3,4,1,5,2,6,7,8 S JJJ=JJJ+1,FIELD(3)=$P(EI,U,I) S FIELD(1)=1,FIELD(2)=JJJ D SEG^PSOHLSN1
    26         E  F I=1:1:8 D
    27         . Q:'$D(^PSRX(PSRXIEN,"ICD",I,0))
    28         . S PSOICD=^PSRX(PSRXIEN,"ICD",I,0),ICD=$P(PSOICD,"^",1)
    29         . Q:ICD=""&(I>1)
    30         . F JJJ=2:1:9 S EI=$P(PSOICD,U,JJJ),FIELD(2)=JJJ-1 D
    31         .. S FIELD(1)=$S(ICD="":1,1:I)
    32         .. ;S FIELD(3)=$S(EI=1:EI,1:0)
    33         .. S FIELD(3)=$S(EI=1:EI,EI=0:EI,1:"")
    34         .. D SEG^PSOHLSN1
    35         K PSOICD
    36         Q
    37         ;CPRS doesn't look at the ZCL segment when their CIDC switch is off.  Always send both ZCL and ZSC for consistency
    38 ZSC     S PSOCPS=$$DT^PSOMLLDT S LIMIT=$S($G(PSOCPS):8,1:1) X NULLFLDS
    39         S FIELD(0)="ZSC" N JJJ,PSOICD
    40         I '$D(^PSRX(PSRXIEN,"ICD",1,0)) D
    41         . I '$G(PSOCPS) S FIELD(1)=$S($P($G(^PSRX(PSRXIEN,"IB")),"^"):"NSC",1:"SC")
    42         . I $G(PSOCPS) D
    43         .. S FIELD(1)=$P($G(^PSRX(PSRXIEN,"IBQ")),"^")
    44         .. F JJJ=2:1:8 S FIELD(JJJ)=$P($G(^PSRX(PSRXIEN,"IBQ")),"^",JJJ)
    45         .D SEG^PSOHLSN1
    46         I $D(^PSRX(PSRXIEN,"ICD",1,0)) D
    47         . S PSOICD=$G(^PSRX(PSRXIEN,"ICD",1,0))
    48         . F JJJ=2:1:9 D
    49         .. I JJJ=2 S FIELD(3)=$P(PSOICD,"^",JJJ)  ;AO
    50         .. I JJJ=3 S FIELD(4)=$P(PSOICD,"^",JJJ)  ;IR
    51         .. I JJJ=4 S FIELD(1)=$P(PSOICD,"^",JJJ)  ;SC
    52         .. I JJJ=5 S FIELD(5)=$P(PSOICD,"^",JJJ)  ;EC
    53         .. I JJJ=6 S FIELD(2)=$P(PSOICD,"^",JJJ)  ;MST
    54         .. I JJJ=7 S FIELD(6)=$P(PSOICD,"^",JJJ)  ;HNC
    55         .. I JJJ=8 S FIELD(7)=$P(PSOICD,"^",JJJ)  ;CV
    56         .. I JJJ=9 S FIELD(8)=$P(PSOICD,"^",JJJ)  ;SHAD
    57         . D SEG^PSOHLSN1
    58         Q
     1PSOHLSN2 ;BIR/LE - Utilities for PSOHLSN1 ;02/27/04
     2 ;;7.0;OUTPATIENT PHARMACY;**143,226,239**;DEC 1997
     3 ;
     4DG1 ;this section builds both DG1 segments
     5 Q:'$D(^PSRX(PSRXIEN,"ICD",1,0))
     6 N LP,DG,DXDESC,I
     7 S LIMIT=4,FIELD(0)="DG1",FIELD(4)=""
     8 ;I '$D(^PSRX(PSRXIEN,"ICD",1,0)) S FIELD(1)=1,FIELD(2)="",FIELD(3)="^^^^^" D SEG^PSOHLSN1 Q
     9 I $P(^PSRX(PSRXIEN,"ICD",1,0),"^",1)="" Q  ;S FIELD(1)=1,FIELD(2)="",FIELD(3)="^^^^^" D SEG^PSOHLSN1 Q
     10 F I=1:1:8 D
     11 . Q:'$D(^PSRX(PSRXIEN,"ICD",I,0))
     12 . S PSOICD="",PSOICD=^PSRX(PSRXIEN,"ICD",I,0) Q:$P(PSOICD,U,1)=""
     13 . S (DG,DXDESC)=""
     14 . I $P(PSOICD,U,1)'="" D
     15 .. S DXDESC=$$GET1^DIQ(80,$P(PSOICD,U,1)_",",10),FIELD(1)=I,FIELD(2)=""
     16 .. S FIELD(3)=$P(PSOICD,U,1)_U_DXDESC_U_"80"_U_$$GET1^DIQ(80,$P(PSOICD,U,1)_",",.01)_U_DXDESC_U_"ICD9"
     17 .. D SEG^PSOHLSN1
     18 K PSOICD("K")
     19 Q
     20ZCL N STOP,IBQ,ICD,I,JJJ,EI
     21 S LIMIT=3,FIELD(0)="ZCL"
     22 I '$D(^PSRX(PSRXIEN,"ICD"))&($D(^PSRX(PSRXIEN,"IBQ"))) D    ;For edits; currently CPRS doesn't update SC/EI for edits, but just in case they start
     23 . S FIELD(1)=1,FIELD(2)=3
     24 . S EI="",EI=^PSRX(PSRXIEN,"IBQ")
     25 . S JJJ=0 F I=3,4,1,5,2,6,7 S JJJ=JJJ+1,FIELD(3)=$P(EI,U,I) S FIELD(1)=1,FIELD(2)=JJJ D SEG^PSOHLSN1
     26 E  F I=1:1:8 D
     27 . Q:'$D(^PSRX(PSRXIEN,"ICD",I,0))
     28 . S PSOICD=^PSRX(PSRXIEN,"ICD",I,0),ICD=$P(PSOICD,"^",1)
     29 . Q:ICD=""&(I>1)
     30 . F JJJ=2:1:8 S EI=$P(PSOICD,U,JJJ),FIELD(2)=JJJ-1 D
     31 .. S FIELD(1)=$S(ICD="":1,1:I)
     32 .. ;S FIELD(3)=$S(EI=1:EI,1:0)
     33 .. S FIELD(3)=$S(EI=1:EI,EI=0:EI,1:"")
     34 .. D SEG^PSOHLSN1
     35 K PSOICD
     36 Q
     37 ;CPRS doesn't look at the ZCL segment when thier CIDC switch is off.  Always send both ZCL and ZSC for consistency
     38ZSC S PSOCPS=$$DT^PSOMLLDT S LIMIT=$S($G(PSOCPS):7,1:1) X NULLFLDS
     39 S FIELD(0)="ZSC"
     40 I '$D(^PSRX(PSRXIEN,"ICD",1,0)) D
     41 . I '$G(PSOCPS) S FIELD(1)=$S($P($G(^PSRX(PSRXIEN,"IB")),"^"):"NSC",1:"SC")
     42 . I $G(PSOCPS) D
     43 .. S FIELD(1)=$P($G(^PSRX(PSRXIEN,"IBQ")),"^"),FIELD(2)=$P($G(^("IBQ")),"^",2),FIELD(3)=$P($G(^("IBQ")),"^",3),FIELD(4)=$P($G(^("IBQ")),"^",4),FIELD(5)=$P($G(^("IBQ")),"^",5),FIELD(6)=$P($G(^("IBQ")),"^",6),FIELD(7)=$P($G(^("IBQ")),"^",7)
     44 .D SEG^PSOHLSN1
     45 N JJJ,PSOICD
     46 I $D(^PSRX(PSRXIEN,"ICD",1,0)) D
     47 . S PSOICD=$G(^PSRX(PSRXIEN,"ICD",1,0))
     48 . F JJJ=2:1:8 D
     49 .. I JJJ=2 S FIELD(3)=$P(PSOICD,"^",JJJ)  ;AO
     50 .. I JJJ=3 S FIELD(4)=$P(PSOICD,"^",JJJ)  ;IR
     51 .. I JJJ=4 S FIELD(1)=$P(PSOICD,"^",JJJ)  ;SC
     52 .. I JJJ=5 S FIELD(5)=$P(PSOICD,"^",JJJ)  ;EC
     53 .. I JJJ=6 S FIELD(2)=$P(PSOICD,"^",JJJ)  ;MST
     54 .. I JJJ=7 S FIELD(6)=$P(PSOICD,"^",JJJ)  ;HNC
     55 .. I JJJ=8 S FIELD(7)=$P(PSOICD,"^",JJJ)  ;CV
     56 . D SEG^PSOHLSN1
     57 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSNC.m

    r613 r623  
    1 PSOHLSNC        ;BIR/RTR - Send CHCS message to CPRS ;07/03/02
    2         ;;7.0;OUTPATIENT PHARMACY;**111,157,143,225**;DEC 1997;Build 29
    3         ;External reference to ^PS(50.7 supported by DBIA 2223
    4         ;External reference to ^PS(51.2 supported by DBIA 2226
    5         ;External reference to ^PSDRUG( supported by DBIA 221
    6         ;External reference to ^PS(50.607 supported by DBIA 2221
    7         ;External reference to ^PS(50.606 supported by DBIA 2174
    8         ;External reference to EN^PSSUTIL1 supported by DBIA 3179
    9         ;
    10         ;PSOPND=Internal number from 52.41
    11         ;PSOPNDST=Order Control Code Status
    12         ;PSOPNDPT=Pharmacy Status
    13         ;
    14 EN(PSOPND,PSOPNDST,PSOPNDPT)    ;
    15         N MSG,PSOHLIP,PSOHLIPX,PSOHLIPC,PSOHLTTL,PSOHUTL,PSOHND,PSOHNDD,PSOHNDU,PSONFLD,PSOXFLD,PSOLIMIT,PSONJJ,PSOHJJ,PSOHCT,PSOSEGMT,PSOHENT,PSOHPRO,PSOHIM,PSOHPC,PSOHPCTX,PSOHRT,PSOHRTE,PSOHRTEN,PSOHRTX,Y,DA,DIQ,DR
    16         I $G(PSOPND)=""!($G(PSOPNDST)="") Q
    17         I '$D(^PS(52.41,+$G(PSOPND),0)) Q
    18         S PSONFLD="F PSONJJ=0:1:PSOLIMIT S PSOXFLD(PSONJJ)="""""
    19         S PSOHCT=1
    20         D INIT^PSOHLSN
    21         D PID,PV1,ORC,RXO,RXE,RXR,ZRX,DG1,ZCL
    22         D MSG^XQOR("PS EVSEND OR",.MSG)
    23         Q
    24 PID     ;Build PID segment
    25         S PSOLIMIT=5 X PSONFLD
    26         ;What about this ICN number?
    27         S PSOXFLD(0)="PID"
    28         S PSOXFLD(3)=$P($G(^PS(52.41,PSOPND,0)),"^",2)
    29         D SEG
    30         Q
    31 PV1     ;Build PV1 segment
    32         S PSOLIMIT=19 X PSONFLD
    33         S PSOXFLD(0)="PV1"
    34         S PSOXFLD(2)="O"
    35         I $P($G(^PS(52.41,PSOPND,0)),"^",13) S PSOXFLD(3)=$P(^(0),"^",13)
    36         D SEG
    37         Q
    38 DG1     ;Build DG1 segment
    39         ;future use; chcs does not send ICD-9 codes.
    40         Q:'$D(^PS(52.41,PSOPND,"ICD"))
    41         S PSOLIMIT=4 X PSONFLD
    42         S PSOXFLD(0)="DG1"
    43         N LP,VDG,FLAG,DXDESC,DG
    44         S FLAG="",PSOXFLD(4)="",PSOXFLD(2)=""
    45         F LP=1:1:8 Q:'$D(^PS(52.41,PSOPND,"ICD",LP,0))  D
    46         . S VDG="",VDG=^PS(52.41,PSOPND,"ICD",LP,0) Q:$P(VDG,U,1)=""
    47         . S (DG,DXDESC)=""
    48         . S DXDESC=$$GET1^DIQ(80,$P(VDG,U,1)_",",10),PSOXFLD(1)=LP
    49         . S PSOXFLD(3)=$P(VDG,U,1)_U_DXDESC_U_"80"_U_$$GET1^DIQ(80,$P(VDG,U,1)_",",.01)_U_DXDESC_U_"ICD9"
    50         . D SEG
    51         Q
    52 ORC     ;Build ORC segment
    53         S PSOLIMIT=15 X PSONFLD
    54         S PSOXFLD(0)="ORC"
    55         S PSOXFLD(1)=$G(PSOPNDST)
    56         S PSOXFLD(3)=PSOPND_"S^PS"
    57         S PSOXFLD(5)=$G(PSOPNDPT)
    58         S X=$P($G(^PS(52.41,PSOPND,0)),"^",6) I X S PSOXFLD(9)=$$FMTHL7^XLFDT(X)
    59         S PSOHENT=$P($G(^PS(52.41,PSOPND,0)),"^",4) I PSOHENT K ^UTILITY("DIQ1",$J) S DIC=200,DR=.01,DA=PSOHENT,DIQ(0)="E" D EN^DIQ1 S PSOXFLD(10)=PSOHENT_"^"_$P($G(^UTILITY("DIQ1",$J,200,PSOHENT,.01,"E")),"^")
    60         S PSOHPRO=$P($G(^PS(52.41,PSOPND,0)),"^",5) I PSOHPRO K ^UTILITY("DIQ1",$J) S DIC=200,DR=.01,DA=PSOHPRO,DIQ(0)="E" D EN^DIQ1 S PSOXFLD(12)=PSOHPRO_"^"_$P($G(^UTILITY("DIQ1",$J,200,PSOHPRO,.01,"E")),"^")
    61         K ^UTILITY("DIQ1",$J)
    62         S X=$P($G(^PS(52.41,PSOPND,0)),"^",12) I X S PSOXFLD(15)=$$FMTHL7^XLFDT(X)
    63         D SEG
    64         Q
    65 RXO     ;Build RXO segment
    66         S PSOLIMIT=1 X PSONFLD
    67         S PSOXFLD(0)="RXO"
    68         S PSOHITM=$P($G(^PS(52.41,PSOPND,0)),"^",8)
    69         S PSOXFLD(1)=$S($G(PSOHITM):"^^^"_PSOHITM_"^"_$P($G(^PS(50.7,+$G(PSOHITM),0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^")_"^99PSP",1:"^^^^^")
    70         D SEG
    71         Q
    72 RXE     ;Build RXE segment
    73         K PSOXFLD S PSOLIMIT=26 X PSONFLD
    74         S PSOXFLD(0)="RXE"
    75         ;No Quantity Timing, since the Sig is entered as free text
    76         S PSOHNDD=$P($G(^PS(52.41,PSOPND,0)),"^",9)
    77         S PSOHND="" I PSOHNDD S PSOHND=$G(^PSDRUG(PSOHNDD,"ND"))
    78         S PSOXFLD(2)=$S($P(PSOHND,"^")&($P(PSOHND,"^",3)):$P(PSOHND,"^")_"."_$P(PSOHND,"^",3)_"^"_$P(PSOHND,"^",2)_"^"_"99NDF",1:"^^")_"^"_$G(PSOHNDD)_"^"_$S($G(PSOHNDD):$P($G(^PSDRUG(PSOHNDD,0)),"^"),1:"")_"^"_"99PSD"
    79         I $P(PSOHND,"^"),$P(PSOHND,"^",3) D
    80         .I $T(^PSNAPIS)]"" S PSOHNDU=$$DFSU^PSNAPIS($P(PSOHND,"^"),$P(PSOHND,"^",3)) S PSOXFLD(5)="^^^"_$P($G(PSOHNDU),"^",5)_"^"_$P($G(PSOHNDU),"^",6)_"^"_"99PSU"
    81         I $G(PSOHITM) S PSOXFLD(6)="^^^"_$P($G(^PS(50.7,$G(PSOHITM),0)),"^",2)_"^"_$P($G(^PS(50.606,+$P($G(^PS(50.7,$G(PSOHITM),0)),"^",2),0)),"^")_"^"_"99PSF"
    82         S PSOXFLD(10)=$P(^PS(52.41,PSOPND,0),"^",10)
    83         S PSOXFLD(12)=$P(^PS(52.41,PSOPND,0),"^",11)
    84         S PSOXFLD(22)=$P(^PS(52.41,PSOPND,0),"^",22)
    85         I $G(PSOHNDD) S PSOHUTL=$$EN^PSSUTIL1(PSOHNDD) S PSOXFLD(25)=$S($E($P(PSOHUTL,"|"),1)=".":"0",1:"")_$P(PSOHUTL,"|"),PSOXFLD(26)=$P(PSOHUTL,"|",2)
    86         ;Create RXE segment, can possibly go over 245 in length
    87         S PSOHCT=PSOHCT+1
    88         S (PSOHLIPX,PSOHLIPC,PSOHLTTL)=0,PSOHLIP="" F  S PSOHLIP=$O(PSOXFLD(PSOHLIP)) Q:PSOHLIP=""  D
    89         .I PSOHLIP S PSOXFLD(PSOHLIP)="|"_PSOXFLD(PSOHLIP)
    90         .I PSOHLTTL+$L(PSOXFLD(PSOHLIP))<246 D  S PSOHLTTL=PSOHLTTL+$L(PSOXFLD(PSOHLIP)) Q
    91         ..I 'PSOHLIPX S MSG(PSOHCT)=$G(MSG(PSOHCT))_PSOXFLD(PSOHLIP) Q
    92         ..S MSG(PSOHCT,PSOHLIPX)=$G(MSG(PSOHCT,PSOHLIPX))_PSOXFLD(PSOHLIP)
    93         .S PSOHLICP=245-PSOHLTTL
    94         .I 'PSOHLIPX D  S PSOHLTTL=$L(MSG(PSOHCT,PSOHLIPX)) Q
    95         ..S MSG(PSOHCT)=$G(MSG(PSOHCT))_$E(PSOXFLD(PSOHLIP),1,PSOHLICP)
    96         ..S PSOHLIPX=1,MSG(PSOHCT,PSOHLIPX)=$E(PSOXFLD(PSOHLIP),(PSOHLICP+1),999)
    97         .S MSG(PSOHCT,PSOHLIPX)=$G(MSG(PSOHCT,PSOHLIPX))_$E(PSOXFLD(PSOHLIP),1,PSOHLICP)
    98         .S PSOHLIPX=PSOHLIPX+1,MSG(PSOHCT,PSOHLIPX)=$E(PSOXFLD(PSOHLIP),(PSOHLICP+1),999)
    99         .S PSOHLTTL=$L(MSG(PSOHCT,PSOHLIPX))
    100         ;Set NTE segments
    101         S PSOHPCT=0,PSOHCT=PSOHCT+1 I $O(^PS(52.41,PSOPND,3,0)) F PSOHPC=0:0 S PSOHPC=$O(^PS(52.41,PSOPND,3,PSOHPC)) Q:'PSOHPC  D
    102         .I $G(^PS(52.41,PSOPND,3,PSOHPC,0))="" Q
    103         .I 'PSOHPCT S MSG(PSOHCT)="NTE|6||"_$G(^PS(52.41,PSOPND,3,PSOHPC,0)) S PSOHPCT=1 Q
    104         .S MSG(PSOHCT,PSOHPCT)=$G(^PS(52.41,PSOPND,3,PSOHPC,0)),PSOHPCT=PSOHPCT+1
    105         I 'PSOHPCT S PSOHCT=PSOHCT-1
    106         S PSOHCT=PSOHCT+1,PSOHPCT=0 I $O(^PS(52.41,PSOPND,"SIG",0)) F PSOHPC=0:0 S PSOHPC=$O(^PS(52.41,PSOPND,"SIG",PSOHPC)) Q:'PSOHPC  D
    107         .I $G(^PS(52.41,PSOPND,"SIG",PSOHPC,0))="" Q
    108         .I 'PSOHPCT S MSG(PSOHCT)="NTE|21||"_$G(^PS(52.41,PSOPND,"SIG",PSOHPC,0)) S PSOHPCT=1 Q
    109         .S MSG(PSOHCT,PSOHPCT)=$G(^PS(52.41,PSOPND,"SIG",PSOHPC,0)),PSOHPCT=PSOHPCT+1
    110         I 'PSOHPCT S MSG(PSOHCT)="NTE|21||"_"No SIG available"
    111         Q
    112 RXR     ;Build RXR segment
    113         S PSOHRTX="" F PSOHRT=0:0 S PSOHRT=$O(^PS(52.41,PSOPND,1,PSOHRT)) Q:'PSOHRT  D
    114         .S PSOHRTX=1
    115         .S PSOLIMIT=1 X PSONFLD
    116         .S PSOXFLD(0)="RXR"
    117         .S PSOHRTEN=""
    118         .S PSOHRTE=$P($G(^PS(52.41,PSOPND,1,PSOHRT,1)),"^",8) I PSOHRTE,$D(^PS(51.2,PSOHRTE,0)) S PSOHRTEN=$P($G(^(0)),"^")
    119         .S PSOXFLD(1)="^^^"_$G(PSOHRTE)_"^"_$G(PSOHRTEN)_"^"_"99PSR"
    120         .D SEG
    121         I '$G(PSOHRTX) S PSOLIMIT=1 X PSONFLD S PSOXFLD(0)="RXR",PSOXFLD(1)="^^^^^99PSR" D SEG
    122         Q
    123 ZRX     ;Build ZRX segment
    124         S PSOLIMIT=6 X PSONFLD
    125         S PSOXFLD(0)="ZRX"
    126         S PSOXFLD(3)="N"
    127         S PSOXFLD(4)=$P($G(^PS(52.41,PSOPND,0)),"^",17)
    128         D SEG
    129         Q
    130 ZCL     ;Build ZCL segment
    131         N I,JJJ,INODE,EI
    132         S PSOXFLD(0)="ZCL",PSOLIMIT=3 X PSONFLD
    133         I $D(^PS(52.41,PSOPND,"ICD")) D
    134         .F I=1:1:8 D
    135         ..Q:'$D(^PS(52.41,PSOPND,"ICD",I,0))
    136         ..S INODE="",INODE=^PS(52.41,PSOPND,"ICD",I,0)
    137         ..F JJJ=2:1:9 S EI=$P(INODE,U,JJJ) D
    138         ...S PSOXFLD(1)=I,PSOXFLD(2)=JJJ-1,PSOXFLD(3)=EI
    139         ...;I JJJ=4 S EI=$S(EI=1:"SC",EI=0:"NSC",1:"") S PSOXFLD(3)=EI
    140         ...D SEG
    141         E  D  ;if no ICD node, send one ZCL segment
    142         .S PSOXFLD(0)="ZCL",PSOXFLD(1)=1,PSOXFLD(2)=3
    143         .S PSOXFLD(3)=$S($P(^PS(52.41,PSOPND,0),"^",16)="SC":1,$P(^(0),"^",16)="NSC":0,1:"")
    144         .D SEG
    145         .Q:'$D(^PS(52.41,PSOPND,"IBQ"))
    146         .S EI=^PS(52.41,PSOPND,"IBQ")
    147         .F I=2,3,4,1,5,6,7 S PSOXFLD(3)=$P(EI,U,I) D
    148         .. S PSOXFLD(2)=$S(I=2:1,I=3:2,I=4:4,I=1:5,I=5:6,I=6:7,I=7:8,1:"") D SEG
    149         Q
    150 ZSC     ;Build ZSC segment
    151         S PSOLIMIT=6 X PSONFLD
    152         S PSOXFLD(0)="ZSC"
    153         S PSOXFLD(1)=$S($P(^PS(52.41,PSOPND,0),"^",16)="SC":1,$P(^(0),"^",16)="NSC":0,1:"")
    154         S PSOXFLD(2)=$P($G(^PS(52.41,PSOPND,"IBQ")),"^"),PSOXFLD(3)=$P($G(^("IBQ")),"^",2),PSOXFLD(4)=$P($G(^("IBQ")),"^",3),PSOXFLD(5)=$P($G(^("IBQ")),"^",4),PSOXFLD(6)=$P($G(^("IBQ")),"^",5),PSOXFLD(7)=$P($G(^("IBQ")),"^",6)
    155         D SEG
    156         Q
    157 SEG     ;
    158         S PSOSEGMT="" F PSOHJJ=0:1:PSOLIMIT S PSOSEGMT=$S(PSOSEGMT="":PSOXFLD(PSOHJJ),1:PSOSEGMT_"|"_PSOXFLD(PSOHJJ))
    159         S PSOHCT=PSOHCT+1,MSG(PSOHCT)=PSOSEGMT
    160         Q
     1PSOHLSNC ;BIR/RTR - Send CHCS message to CPRS ;07/03/02
     2 ;;7.0;OUTPATIENT PHARMACY;**111,157,143**;DEC 1997
     3 ;External reference to ^PS(50.7 supported by DBIA 2223
     4 ;External reference to ^PS(51.2 supported by DBIA 2226
     5 ;External reference to ^PSDRUG( supported by DBIA 221
     6 ;External reference to ^PS(50.607 supported by DBIA 2221
     7 ;External reference to ^PS(50.606 supported by DBIA 2174
     8 ;External reference to EN^PSSUTIL1 supported by DBIA 3179
     9 ;
     10 ;PSOPND=Internal number from 52.41
     11 ;PSOPNDST=Order Control Code Status
     12 ;PSOPNDPT=Pharmacy Status
     13 ;
     14EN(PSOPND,PSOPNDST,PSOPNDPT) ;
     15 N MSG,PSOHLIP,PSOHLIPX,PSOHLIPC,PSOHLTTL,PSOHUTL,PSOHND,PSOHNDD,PSOHNDU,PSONFLD,PSOXFLD,PSOLIMIT,PSONJJ,PSOHJJ,PSOHCT,PSOSEGMT,PSOHENT,PSOHPRO,PSOHIM,PSOHPC,PSOHPCTX,PSOHRT,PSOHRTE,PSOHRTEN,PSOHRTX,Y,DA,DIQ,DR
     16 I $G(PSOPND)=""!($G(PSOPNDST)="") Q
     17 I '$D(^PS(52.41,+$G(PSOPND),0)) Q
     18 S PSONFLD="F PSONJJ=0:1:PSOLIMIT S PSOXFLD(PSONJJ)="""""
     19 S PSOHCT=1
     20 D INIT^PSOHLSN
     21 D PID,PV1,ORC,RXO,RXE,RXR,ZRX,DG1,ZCL
     22 D MSG^XQOR("PS EVSEND OR",.MSG)
     23 Q
     24PID ;Build PID segment
     25 S PSOLIMIT=5 X PSONFLD
     26 ;What about this ICN number?
     27 S PSOXFLD(0)="PID"
     28 S PSOXFLD(3)=$P($G(^PS(52.41,PSOPND,0)),"^",2)
     29 D SEG
     30 Q
     31PV1 ;Build PV1 segment
     32 S PSOLIMIT=19 X PSONFLD
     33 S PSOXFLD(0)="PV1"
     34 S PSOXFLD(2)="O"
     35 I $P($G(^PS(52.41,PSOPND,0)),"^",13) S PSOXFLD(3)=$P(^(0),"^",13)
     36 D SEG
     37 Q
     38DG1 ;Build DG1 segment
     39 ;future use; chcs does not send ICD-9 codes.
     40 Q:'$D(^PS(52.41,PSOPND,"ICD"))
     41 S PSOLIMIT=4 X PSONFLD
     42 S PSOXFLD(0)="DG1"
     43 N LP,VDG,FLAG,DXDESC,DG
     44 S FLAG="",PSOXFLD(4)="",PSOXFLD(2)=""
     45 F LP=1:1:8 Q:'$D(^PS(52.41,PSOPND,"ICD",LP,0))  D
     46 . S VDG="",VDG=^PS(52.41,PSOPND,"ICD",LP,0) Q:$P(VDG,U,1)=""
     47 . S (DG,DXDESC)=""
     48 . S DXDESC=$$GET1^DIQ(80,$P(VDG,U,1)_",",10),PSOXFLD(1)=LP
     49 . S PSOXFLD(3)=$P(VDG,U,1)_U_DXDESC_U_"80"_U_$$GET1^DIQ(80,$P(VDG,U,1)_",",.01)_U_DXDESC_U_"ICD9"
     50 . D SEG
     51 Q
     52ORC ;Build ORC segment
     53 S PSOLIMIT=15 X PSONFLD
     54 S PSOXFLD(0)="ORC"
     55 S PSOXFLD(1)=$G(PSOPNDST)
     56 S PSOXFLD(3)=PSOPND_"S^PS"
     57 S PSOXFLD(5)=$G(PSOPNDPT)
     58 S X=$P($G(^PS(52.41,PSOPND,0)),"^",6) I X S PSOXFLD(9)=$$FMTHL7^XLFDT(X)
     59 S PSOHENT=$P($G(^PS(52.41,PSOPND,0)),"^",4) I PSOHENT K ^UTILITY("DIQ1",$J) S DIC=200,DR=.01,DA=PSOHENT,DIQ(0)="E" D EN^DIQ1 S PSOXFLD(10)=PSOHENT_"^"_$P($G(^UTILITY("DIQ1",$J,200,PSOHENT,.01,"E")),"^")
     60 S PSOHPRO=$P($G(^PS(52.41,PSOPND,0)),"^",5) I PSOHPRO K ^UTILITY("DIQ1",$J) S DIC=200,DR=.01,DA=PSOHPRO,DIQ(0)="E" D EN^DIQ1 S PSOXFLD(12)=PSOHPRO_"^"_$P($G(^UTILITY("DIQ1",$J,200,PSOHPRO,.01,"E")),"^")
     61 K ^UTILITY("DIQ1",$J)
     62 S X=$P($G(^PS(52.41,PSOPND,0)),"^",12) I X S PSOXFLD(15)=$$FMTHL7^XLFDT(X)
     63 D SEG
     64 Q
     65RXO ;Build RXO segment
     66 S PSOLIMIT=1 X PSONFLD
     67 S PSOXFLD(0)="RXO"
     68 S PSOHITM=$P($G(^PS(52.41,PSOPND,0)),"^",8)
     69 S PSOXFLD(1)=$S($G(PSOHITM):"^^^"_PSOHITM_"^"_$P($G(^PS(50.7,+$G(PSOHITM),0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^")_"^99PSP",1:"^^^^^")
     70 D SEG
     71 Q
     72RXE ;Build RXE segment
     73 K PSOXFLD S PSOLIMIT=26 X PSONFLD
     74 S PSOXFLD(0)="RXE"
     75 ;No Quantity Timing, since the Sig is entered as free text
     76 S PSOHNDD=$P($G(^PS(52.41,PSOPND,0)),"^",9)
     77 S PSOHND="" I PSOHNDD S PSOHND=$G(^PSDRUG(PSOHNDD,"ND"))
     78 S PSOXFLD(2)=$S($P(PSOHND,"^")&($P(PSOHND,"^",3)):$P(PSOHND,"^")_"."_$P(PSOHND,"^",3)_"^"_$P(PSOHND,"^",2)_"^"_"99NDF",1:"^^")_"^"_$G(PSOHNDD)_"^"_$S($G(PSOHNDD):$P($G(^PSDRUG(PSOHNDD,0)),"^"),1:"")_"^"_"99PSD"
     79 I $P(PSOHND,"^"),$P(PSOHND,"^",3) D
     80 .I $T(^PSNAPIS)]"" S PSOHNDU=$$DFSU^PSNAPIS($P(PSOHND,"^"),$P(PSOHND,"^",3)) S PSOXFLD(5)="^^^"_$P($G(PSOHNDU),"^",5)_"^"_$P($G(PSOHNDU),"^",6)_"^"_"99PSU"
     81 I $G(PSOHITM) S PSOXFLD(6)="^^^"_$P($G(^PS(50.7,$G(PSOHITM),0)),"^",2)_"^"_$P($G(^PS(50.606,+$P($G(^PS(50.7,$G(PSOHITM),0)),"^",2),0)),"^")_"^"_"99PSF"
     82 S PSOXFLD(10)=$P(^PS(52.41,PSOPND,0),"^",10)
     83 S PSOXFLD(12)=$P(^PS(52.41,PSOPND,0),"^",11)
     84 S PSOXFLD(22)=$P(^PS(52.41,PSOPND,0),"^",22)
     85 I $G(PSOHNDD) S PSOHUTL=$$EN^PSSUTIL1(PSOHNDD) S PSOXFLD(25)=$S($E($P(PSOHUTL,"|"),1)=".":"0",1:"")_$P(PSOHUTL,"|"),PSOXFLD(26)=$P(PSOHUTL,"|",2)
     86 ;Create RXE segment, can possibly go over 245 in length
     87 S PSOHCT=PSOHCT+1
     88 S (PSOHLIPX,PSOHLIPC,PSOHLTTL)=0,PSOHLIP="" F  S PSOHLIP=$O(PSOXFLD(PSOHLIP)) Q:PSOHLIP=""  D
     89 .I PSOHLIP S PSOXFLD(PSOHLIP)="|"_PSOXFLD(PSOHLIP)
     90 .I PSOHLTTL+$L(PSOXFLD(PSOHLIP))<246 D  S PSOHLTTL=PSOHLTTL+$L(PSOXFLD(PSOHLIP)) Q
     91 ..I 'PSOHLIPX S MSG(PSOHCT)=$G(MSG(PSOHCT))_PSOXFLD(PSOHLIP) Q
     92 ..S MSG(PSOHCT,PSOHLIPX)=$G(MSG(PSOHCT,PSOHLIPX))_PSOXFLD(PSOHLIP)
     93 .S PSOHLICP=245-PSOHLTTL
     94 .I 'PSOHLIPX D  S PSOHLTTL=$L(MSG(PSOHCT,PSOHLIPX)) Q
     95 ..S MSG(PSOHCT)=$G(MSG(PSOHCT))_$E(PSOXFLD(PSOHLIP),1,PSOHLICP)
     96 ..S PSOHLIPX=1,MSG(PSOHCT,PSOHLIPX)=$E(PSOXFLD(PSOHLIP),(PSOHLICP+1),999)
     97 .S MSG(PSOHCT,PSOHLIPX)=$G(MSG(PSOHCT,PSOHLIPX))_$E(PSOXFLD(PSOHLIP),1,PSOHLICP)
     98 .S PSOHLIPX=PSOHLIPX+1,MSG(PSOHCT,PSOHLIPX)=$E(PSOXFLD(PSOHLIP),(PSOHLICP+1),999)
     99 .S PSOHLTTL=$L(MSG(PSOHCT,PSOHLIPX))
     100 ;Set NTE segments
     101 S PSOHPCT=0,PSOHCT=PSOHCT+1 I $O(^PS(52.41,PSOPND,3,0)) F PSOHPC=0:0 S PSOHPC=$O(^PS(52.41,PSOPND,3,PSOHPC)) Q:'PSOHPC  D
     102 .I $G(^PS(52.41,PSOPND,3,PSOHPC,0))="" Q
     103 .I 'PSOHPCT S MSG(PSOHCT)="NTE|6||"_$G(^PS(52.41,PSOPND,3,PSOHPC,0)) S PSOHPCT=1 Q
     104 .S MSG(PSOHCT,PSOHPCT)=$G(^PS(52.41,PSOPND,3,PSOHPC,0)),PSOHPCT=PSOHPCT+1
     105 I 'PSOHPCT S PSOHCT=PSOHCT-1
     106 S PSOHCT=PSOHCT+1,PSOHPCT=0 I $O(^PS(52.41,PSOPND,"SIG",0)) F PSOHPC=0:0 S PSOHPC=$O(^PS(52.41,PSOPND,"SIG",PSOHPC)) Q:'PSOHPC  D
     107 .I $G(^PS(52.41,PSOPND,"SIG",PSOHPC,0))="" Q
     108 .I 'PSOHPCT S MSG(PSOHCT)="NTE|21||"_$G(^PS(52.41,PSOPND,"SIG",PSOHPC,0)) S PSOHPCT=1 Q
     109 .S MSG(PSOHCT,PSOHPCT)=$G(^PS(52.41,PSOPND,"SIG",PSOHPC,0)),PSOHPCT=PSOHPCT+1
     110 I 'PSOHPCT S MSG(PSOHCT)="NTE|21||"_"No SIG available"
     111 Q
     112RXR ;Build RXR segment
     113 S PSOHRTX="" F PSOHRT=0:0 S PSOHRT=$O(^PS(52.41,PSOPND,1,PSOHRT)) Q:'PSOHRT  D
     114 .S PSOHRTX=1
     115 .S PSOLIMIT=1 X PSONFLD
     116 .S PSOXFLD(0)="RXR"
     117 .S PSOHRTEN=""
     118 .S PSOHRTE=$P($G(^PS(52.41,PSOPND,1,PSOHRT,1)),"^",8) I PSOHRTE,$D(^PS(51.2,PSOHRTE,0)) S PSOHRTEN=$P($G(^(0)),"^")
     119 .S PSOXFLD(1)="^^^"_$G(PSOHRTE)_"^"_$G(PSOHRTEN)_"^"_"99PSR"
     120 .D SEG
     121 I '$G(PSOHRTX) S PSOLIMIT=1 X PSONFLD S PSOXFLD(0)="RXR",PSOXFLD(1)="^^^^^99PSR" D SEG
     122 Q
     123ZRX ;Build ZRX segment
     124 S PSOLIMIT=6 X PSONFLD
     125 S PSOXFLD(0)="ZRX"
     126 S PSOXFLD(3)="N"
     127 S PSOXFLD(4)=$P($G(^PS(52.41,PSOPND,0)),"^",17)
     128 D SEG
     129 Q
     130ZCL ;Build ZCL segment
     131 N I,JJJ,INODE,EI
     132 S PSOXFLD(0)="ZCL",PSOLIMIT=3 X PSONFLD
     133 I $D(^PS(52.41,PSOPND,"ICD")) D
     134 .F I=1:1:8 D
     135 ..Q:'$D(^PS(52.41,PSOPND,"ICD",I,0))
     136 ..S INODE="",INODE=^PS(52.41,PSOPND,"ICD",I,0)
     137 ..F JJJ=2:1:8 S EI=$P(INODE,U,JJJ) D
     138 ...S PSOXFLD(1)=I,PSOXFLD(2)=JJJ-1,PSOXFLD(3)=EI
     139 ...;I JJJ=4 S EI=$S(EI=1:"SC",EI=0:"NSC",1:"") S PSOXFLD(3)=EI
     140 ...D SEG
     141 E  D  ;if no ICD node, send one ZCL segment
     142 .S PSOXFLD(0)="ZCL",PSOXFLD(1)=1,PSOXFLD(2)=3
     143 .S PSOXFLD(3)=$S($P(^PS(52.41,PSOPND,0),"^",16)="SC":1,$P(^(0),"^",16)="NSC":0,1:"")
     144 .D SEG
     145 .Q:'$D(^PS(52.41,PSOPND,"IBQ"))
     146 .S EI=^PS(52.41,PSOPND,"IBQ")
     147 .F I=2,3,4,1,5,6 S PSOXFLD(3)=$P(EI,U,I) D
     148 .. S PSOXFLD(2)=$S(I=2:1,I=3:2,I=4:4,I=1:5,I=5:6,I=6:7,1:"") D SEG
     149 Q
     150ZSC ;Build ZSC segment
     151 S PSOLIMIT=6 X PSONFLD
     152 S PSOXFLD(0)="ZSC"
     153 S PSOXFLD(1)=$S($P(^PS(52.41,PSOPND,0),"^",16)="SC":1,$P(^(0),"^",16)="NSC":0,1:"")
     154 S PSOXFLD(2)=$P($G(^PS(52.41,PSOPND,"IBQ")),"^"),PSOXFLD(3)=$P($G(^("IBQ")),"^",2),PSOXFLD(4)=$P($G(^("IBQ")),"^",3),PSOXFLD(5)=$P($G(^("IBQ")),"^",4),PSOXFLD(6)=$P($G(^("IBQ")),"^",5),PSOXFLD(7)=$P($G(^("IBQ")),"^",6)
     155 D SEG
     156 Q
     157SEG ;
     158 S PSOSEGMT="" F PSOHJJ=0:1:PSOLIMIT S PSOSEGMT=$S(PSOSEGMT="":PSOXFLD(PSOHJJ),1:PSOSEGMT_"|"_PSOXFLD(PSOHJJ))
     159 S PSOHCT=PSOHCT+1,MSG(PSOHCT)=PSOSEGMT
     160 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLUP.m

    r613 r623  
    1 PSOHLUP ;BIR/RTR-Backfill OERR from Pharmacy ;7/20/96
    2         ;;7.0;OUTPATIENT PHARMACY;**5,225**;DEC 1997;Build 29
    3         ;
    4         ;Pass in patient DFN
    5 EN(PSOEDFN)     ;
    6 INPT    N PSOC
    7         ;S PSOSHH=$$OTF^OR3CONV(PSOEDFN,$S($G(PSOLOUD):0,1:1))
    8         Q
    9 EN2     ;
    10         I '$P($G(^PS(55,PSOEDFN,0)),"^",6) D UPD S $P(^PS(55,PSOEDFN,0),"^",6)=1
    11         Q:'$D(^PS(55,+PSOEDFN,0))!('$G(PSOEDFN))
    12         Q:$P($G(^PS(55,PSOEDFN,0)),"^",6)=2
    13         N C,Y,DA,IFN,RXP,DFN,PAT,PSODFN,PSOPPQ,PSOPPQR,PSOYEAR,PSOEST,PSOERSTA,PSOPHSTA,X,T,PRU,PSOCV,PTFLAG,III
    14         ;W:$G(PSOEWRT) !!,"Please wait. Updating CPRS with patient's Outpatient Meds."
    15         ;F PSOCV=0:0 S PSOCV=$O(^PS(55,PSOEDFN,"P","A",PSOCV)) Q:'PSOCV  F PSOPPQR=0:0 S PSOPPQR=$O(^PS(55,PSOEDFN,"P","A",PSOCV,PSOPPQR)) Q:'PSOPPQR  D UPD
    16         S X1=DT,X2=-121 D C^%DTC S PSOYEAR=X
    17         F PSOPPQ=PSOYEAR:0 S PSOPPQ=$O(^PS(55,PSOEDFN,"P","A",PSOPPQ)) Q:'PSOPPQ  F PSOPPQR=0:0 S PSOPPQR=$O(^PS(55,PSOEDFN,"P","A",PSOPPQ,PSOPPQR)) Q:'PSOPPQR  D PAT D:$D(^PSRX(PSOPPQR,0))&('$P($G(^PSRX(PSOPPQR,"OR1")),"^",2))&('$G(PTFLAG))
    18         .Q:'$P($G(^PSRX(PSOPPQR,0)),"^",2)
    19         .S PSOEST=$S($D(^PSRX(PSOPPQR,"STA")):$P($G(^PSRX(PSOPPQR,"STA")),"^"),1:$P($G(^PSRX(PSOPPQR,0)),"^",15)) Q:PSOEST=10!(PSOEST=13)!(PSOEST=16)!(PSOEST=14)
    20         .D:'$P($G(^PSRX(PSOPPQR,0)),"^",19)
    21         ..D:'$P($G(^PSRX(PSOPPQR,"SIG")),"^",2) POP^PSOSIGNO(PSOPPQR)
    22         ..I $P($G(^PSRX(PSOPPQR,"OR1")),"^")']"",+$G(^PSDRUG(+$P(^PSRX(PSOPPQR,0),"^",6),2)) S $P(^PSRX(PSOPPQR,"OR1"),"^")=+$G(^PSDRUG($P(^PSRX(PSOPPQR,0),"^",6),2))
    23         ..I $G(^PSRX(PSOPPQR,"SIG"))']"" S ^PSRX(PSOPPQR,"SIG")=$P($G(^PSRX(PSOPPQR,0)),"^",10)_"^"_0 S $P(^PSRX(PSOPPQR,0),"^",10)=""
    24         ..S ^PSRX(PSOPPQR,"STA")=$P($G(^PSRX(PSOPPQR,0)),"^",15) S $P(^PSRX(PSOPPQR,0),"^",15)=""
    25         ..S PR=0 F  S PR=$O(^PSRX(PSOPPQR,"P",PR)) Q:'PR  D
    26         ...I '$P($G(^PSRX(PSOPPQR,"P",PR,0)),"^") K ^PSRX(PSOPPQR,"P",PR,0) Q
    27         ...S ^PSRX("ADP",$E($P(^PSRX(PSOPPQR,"P",PR,0),"^"),1,7),PSOPPQR,PR)=""
    28         ..S $P(^PSRX(PSOPPQR,0),"^",19)=1
    29         .W:$G(PSOEWRT) "." D EN^PSOHLSN1(PSOPPQR,"ZC","")
    30         .Q:'$P($G(^PSRX(PSOPPQR,"OR1")),"^",2)
    31         .S PSOEST=$P($G(^PSRX(PSOPPQR,"STA")),"^")
    32         .I +$P($G(^PSRX(PSOPPQR,2)),"^",6),$P($G(^(2)),"^",6)<DT S $P(^PSRX(PSOPPQR,"STA"),"^")=11 D ECAN^PSOUTL(PSOPPQR) S PSOEST=11
    33         .S PSOERSTA=$S(PSOEST=3:"OH",PSOEST=12:"OD",PSOEST=15:"OD",1:"SC"),PSOPHSTA=$S(PSOEST=0:"CM",PSOEST=1:"IP",PSOEST=4:"IP",PSOEST=5:"ZS",PSOEST=11:"ZE",1:"")
    34         .D EN^PSOHLSN1(PSOPPQR,PSOERSTA,PSOPHSTA,"")
    35         S $P(^PS(55,PSOEDFN,0),"^",6)=2
    36         ;W !,"Finished backfilling!",!
    37         Q
    38 EN1(PSOEDFN,PSOEWRT)    N PSOBCK
    39         Q:'$G(PSOEDFN)
    40         S X1=DT,X2=-121 D C^%DTC S PSOYEAR=X
    41         I $O(^PS(55,PSOEDFN,"P","A",PSOYEAR)) D:'$D(^PS(55,PSOEDFN,0)) ADD(PSOEDFN) D EN2 G INPAT
    42         D:'$D(^PS(55,PSOEDFN,0))&($D(^PS(55,PSOEDFN))) ADD(PSOEDFN) S:$D(^PS(55,PSOEDFN,0)) $P(^PS(55,PSOEDFN,0),"^",6)=2
    43 INPAT   S X="PSJUTL1" X ^%ZOSF("TEST") I $T D CONVERT^PSJUTL1(PSOEDFN,PSOEWRT)
    44         Q
    45 UPD     ;Update OERR if not done yet
    46         N PSLOOP,PSOPPQR
    47         F PSLOOP=0:0 S PSLOOP=$O(^PS(55,PSOEDFN,"P","A",PSLOOP)) Q:'PSLOOP  F PSOPPQR=0:0 S PSOPPQR=$O(^PS(55,PSOEDFN,"P","A",PSLOOP,PSOPPQR)) Q:'PSOPPQR  D
    48         .Q:$G(^PSRX(PSOPPQR,0))=""!('$P($G(^PSRX(PSOPPQR,0)),"^",2))
    49         .Q:$P(^PSRX(PSOPPQR,0),"^",19)
    50         .D:'$P($G(^PSRX(PSOPPQR,"SIG")),"^",2) POP^PSOSIGNO(PSOPPQR)
    51         .I $P($G(^PSRX(PSOPPQR,"OR1")),"^")']"",+$G(^PSDRUG(+$P(^PSRX(PSOPPQR,0),"^",6),2)) S $P(^PSRX(PSOPPQR,"OR1"),"^")=+$G(^PSDRUG($P(^PSRX(PSOPPQR,0),"^",6),2))
    52         .I $G(^PSRX(PSOPPQR,"SIG"))']"" S ^PSRX(PSOPPQR,"SIG")=$P($G(^PSRX(PSOPPQR,0)),"^",10)_"^"_0 S $P(^PSRX(PSOPPQR,0),"^",10)=""
    53         .I $G(^PSRX(PSOPPQR,"STA"))']"" S ^PSRX(PSOPPQR,"STA")=$P($G(^PSRX(PSOPPQR,0)),"^",15) S $P(^PSRX(PSOPPQR,0),"^",15)=""
    54         .S PRU=0 F  S PRU=$O(^PSRX(PSOPPQR,"P",PRU)) Q:'PRU  D
    55         ..I '$P($G(^PSRX(PSOPPQR,"P",PRU,0)),"^") K ^PSRX(PSOPPQR,"P",PRU,0) Q
    56         ..S ^PSRX("ADP",$E($P(^PSRX(PSOPPQR,"P",PRU,0),"^"),1,7),PSOPPQR,PRU)=""
    57         .S $P(^PSRX(PSOPPQR,0),"^",19)=1
    58         Q
    59 PAT     ;Check for correct patient
    60         S PTFLAG=0
    61         Q:PSOEDFN=$P($G(^PSRX(PSOPPQR,0)),"^",2)
    62         S PTFLAG=1
    63         K ^PS(55,PSOEDFN,"P","A",PSOPPQ,PSOPPQR)
    64         F III=0:0 S III=$O(^PS(55,PSOEDFN,"P",III)) Q:'III  I $G(^PS(55,PSOEDFN,"P",III,0))=PSOPPQR K ^PS(55,PSOEDFN,"P",III,0)
    65         Q
    66 ADD(PATIEN)     ;Add patient to 55 (0 node)
    67         Q:$D(^PS(55,PATIEN,0))
    68         N X,Y,DA,DIK
    69         S ^PS(55,PATIEN,0)=PATIEN K DIK S DA=PATIEN,DIK="^PS(55,",DIK(1)=.01 D EN^DIK
    70         Q
     1PSOHLUP ;BIR/RTR-Backfill OERR from Pharmacy ; 7/20/96
     2 ;;7.0;OUTPATIENT PHARMACY;**5**;DEC 1997
     3 ;
     4 ;Pass in patient DFN
     5EN(PSOEDFN) ;
     6INPT N PSOC S PSOSHH=$$OTF^OR3CONV(PSOEDFN,$S($G(PSOLOUD):0,1:1))
     7 Q
     8EN2 ;
     9 I '$P($G(^PS(55,PSOEDFN,0)),"^",6) D UPD S $P(^PS(55,PSOEDFN,0),"^",6)=1
     10 Q:'$D(^PS(55,+PSOEDFN,0))!('$G(PSOEDFN))
     11 Q:$P($G(^PS(55,PSOEDFN,0)),"^",6)=2
     12 N C,Y,DA,IFN,RXP,DFN,PAT,PSODFN,PSOPPQ,PSOPPQR,PSOYEAR,PSOEST,PSOERSTA,PSOPHSTA,X,T,PRU,PSOCV,PTFLAG,III
     13 ;W:$G(PSOEWRT) !!,"Please wait. Updating CPRS with patient's Outpatient Meds."
     14 ;F PSOCV=0:0 S PSOCV=$O(^PS(55,PSOEDFN,"P","A",PSOCV)) Q:'PSOCV  F PSOPPQR=0:0 S PSOPPQR=$O(^PS(55,PSOEDFN,"P","A",PSOCV,PSOPPQR)) Q:'PSOPPQR  D UPD
     15 S X1=DT,X2=-121 D C^%DTC S PSOYEAR=X
     16 F PSOPPQ=PSOYEAR:0 S PSOPPQ=$O(^PS(55,PSOEDFN,"P","A",PSOPPQ)) Q:'PSOPPQ  F PSOPPQR=0:0 S PSOPPQR=$O(^PS(55,PSOEDFN,"P","A",PSOPPQ,PSOPPQR)) Q:'PSOPPQR  D PAT D:$D(^PSRX(PSOPPQR,0))&('$P($G(^PSRX(PSOPPQR,"OR1")),"^",2))&('$G(PTFLAG))
     17 .Q:'$P($G(^PSRX(PSOPPQR,0)),"^",2)
     18 .S PSOEST=$S($D(^PSRX(PSOPPQR,"STA")):$P($G(^PSRX(PSOPPQR,"STA")),"^"),1:$P($G(^PSRX(PSOPPQR,0)),"^",15)) Q:PSOEST=10!(PSOEST=13)!(PSOEST=16)!(PSOEST=14)
     19 .D:'$P($G(^PSRX(PSOPPQR,0)),"^",19)
     20 ..D:'$P($G(^PSRX(PSOPPQR,"SIG")),"^",2) POP^PSOSIGNO(PSOPPQR)
     21 ..I $P($G(^PSRX(PSOPPQR,"OR1")),"^")']"",+$G(^PSDRUG(+$P(^PSRX(PSOPPQR,0),"^",6),2)) S $P(^PSRX(PSOPPQR,"OR1"),"^")=+$G(^PSDRUG($P(^PSRX(PSOPPQR,0),"^",6),2))
     22 ..I $G(^PSRX(PSOPPQR,"SIG"))']"" S ^PSRX(PSOPPQR,"SIG")=$P($G(^PSRX(PSOPPQR,0)),"^",10)_"^"_0 S $P(^PSRX(PSOPPQR,0),"^",10)=""
     23 ..S ^PSRX(PSOPPQR,"STA")=$P($G(^PSRX(PSOPPQR,0)),"^",15) S $P(^PSRX(PSOPPQR,0),"^",15)=""
     24 ..S PR=0 F  S PR=$O(^PSRX(PSOPPQR,"P",PR)) Q:'PR  D
     25 ...I '$P($G(^PSRX(PSOPPQR,"P",PR,0)),"^") K ^PSRX(PSOPPQR,"P",PR,0) Q
     26 ...S ^PSRX("ADP",$E($P(^PSRX(PSOPPQR,"P",PR,0),"^"),1,7),PSOPPQR,PR)=""
     27 ..S $P(^PSRX(PSOPPQR,0),"^",19)=1
     28 .W:$G(PSOEWRT) "." D EN^PSOHLSN1(PSOPPQR,"ZC","")
     29 .Q:'$P($G(^PSRX(PSOPPQR,"OR1")),"^",2)
     30 .S PSOEST=$P($G(^PSRX(PSOPPQR,"STA")),"^")
     31 .I +$P($G(^PSRX(PSOPPQR,2)),"^",6),$P($G(^(2)),"^",6)<DT S $P(^PSRX(PSOPPQR,"STA"),"^")=11 D ECAN^PSOUTL(PSOPPQR) S PSOEST=11
     32 .S PSOERSTA=$S(PSOEST=3:"OH",PSOEST=12:"OD",PSOEST=15:"OD",1:"SC"),PSOPHSTA=$S(PSOEST=0:"CM",PSOEST=1:"IP",PSOEST=4:"IP",PSOEST=5:"ZS",PSOEST=11:"ZE",1:"")
     33 .D EN^PSOHLSN1(PSOPPQR,PSOERSTA,PSOPHSTA,"")
     34 S $P(^PS(55,PSOEDFN,0),"^",6)=2
     35 ;W !,"Finished backfilling!",!
     36 Q
     37EN1(PSOEDFN,PSOEWRT) N PSOBCK
     38 Q:'$G(PSOEDFN)
     39 S X1=DT,X2=-121 D C^%DTC S PSOYEAR=X
     40 I $O(^PS(55,PSOEDFN,"P","A",PSOYEAR)) D:'$D(^PS(55,PSOEDFN,0)) ADD(PSOEDFN) D EN2 G INPAT
     41 D:'$D(^PS(55,PSOEDFN,0))&($D(^PS(55,PSOEDFN))) ADD(PSOEDFN) S:$D(^PS(55,PSOEDFN,0)) $P(^PS(55,PSOEDFN,0),"^",6)=2
     42INPAT S X="PSJUTL1" X ^%ZOSF("TEST") I $T D CONVERT^PSJUTL1(PSOEDFN,PSOEWRT)
     43 Q
     44UPD ;Update OERR if not done yet
     45 N PSLOOP,PSOPPQR
     46 F PSLOOP=0:0 S PSLOOP=$O(^PS(55,PSOEDFN,"P","A",PSLOOP)) Q:'PSLOOP  F PSOPPQR=0:0 S PSOPPQR=$O(^PS(55,PSOEDFN,"P","A",PSLOOP,PSOPPQR)) Q:'PSOPPQR  D
     47 .Q:$G(^PSRX(PSOPPQR,0))=""!('$P($G(^PSRX(PSOPPQR,0)),"^",2))
     48 .Q:$P(^PSRX(PSOPPQR,0),"^",19)
     49 .D:'$P($G(^PSRX(PSOPPQR,"SIG")),"^",2) POP^PSOSIGNO(PSOPPQR)
     50 .I $P($G(^PSRX(PSOPPQR,"OR1")),"^")']"",+$G(^PSDRUG(+$P(^PSRX(PSOPPQR,0),"^",6),2)) S $P(^PSRX(PSOPPQR,"OR1"),"^")=+$G(^PSDRUG($P(^PSRX(PSOPPQR,0),"^",6),2))
     51 .I $G(^PSRX(PSOPPQR,"SIG"))']"" S ^PSRX(PSOPPQR,"SIG")=$P($G(^PSRX(PSOPPQR,0)),"^",10)_"^"_0 S $P(^PSRX(PSOPPQR,0),"^",10)=""
     52 .I $G(^PSRX(PSOPPQR,"STA"))']"" S ^PSRX(PSOPPQR,"STA")=$P($G(^PSRX(PSOPPQR,0)),"^",15) S $P(^PSRX(PSOPPQR,0),"^",15)=""
     53 .S PRU=0 F  S PRU=$O(^PSRX(PSOPPQR,"P",PRU)) Q:'PRU  D
     54 ..I '$P($G(^PSRX(PSOPPQR,"P",PRU,0)),"^") K ^PSRX(PSOPPQR,"P",PRU,0) Q
     55 ..S ^PSRX("ADP",$E($P(^PSRX(PSOPPQR,"P",PRU,0),"^"),1,7),PSOPPQR,PRU)=""
     56 .S $P(^PSRX(PSOPPQR,0),"^",19)=1
     57 Q
     58PAT ;Check for correct patient
     59 S PTFLAG=0
     60 Q:PSOEDFN=$P($G(^PSRX(PSOPPQR,0)),"^",2)
     61 S PTFLAG=1
     62 K ^PS(55,PSOEDFN,"P","A",PSOPPQ,PSOPPQR)
     63 F III=0:0 S III=$O(^PS(55,PSOEDFN,"P",III)) Q:'III  I $G(^PS(55,PSOEDFN,"P",III,0))=PSOPPQR K ^PS(55,PSOEDFN,"P",III,0)
     64 Q
     65ADD(PATIEN) ;Add patient to 55 (0 node)
     66 Q:$D(^PS(55,PATIEN,0))
     67 N X,Y,DA,DIK
     68 S ^PS(55,PATIEN,0)=PATIEN K DIK S DA=PATIEN,DIK="^PS(55,",DIK(1)=.01 D EN^DIK
     69 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL.m

    r613 r623  
    1 PSOLBL  ;BIR/SAB/RTR-BOTTLE LABEL ;5/9/07 8:57am
    2         ;;7.0;OUTPATIENT PHARMACY;**8,19,30,36,47,71,92,120,157,244,206,225**;DEC 1997;Build 29
    3         ;DBIAs PSDRUG-221, PS(55-2228, IBARX-125, PSXSRP-2201, %ZIS-3435, DPT-3097
    4         ;
    5         ;*244 rem test for part fill when testing status > 11
    6         ;
    7 DQ      I $D(PSOIOS),PSOIOS]"" D DEVBAR^PSOBMST
    8         I $G(PSOBAR0)]"",$G(PSOBAR1)]"",$D(^PS(59,PSOSITE,1)) S PSOBARS=1
    9 DQ1     D ^PSOLBL4
    10         I $G(IOST(0)),$D(^%ZIS(2,IOST(0),55,"B","LL")) G ^PSOLLLI
    11         G:'$D(PPL) HLEX G:($P($G(PSOPAR),"^",30)=2)&('$G(PSOEXREP)) HLEX K RXFLX S PSOCKHN=","_$G(PPL) S PSRESOLV=+PPL D CHECK F PI=1:1  D  S RX=$P(PPL,",",PI) D C Q:$G(PSOLAPPL)  D:$G(PSDFNFLG) TRAIL^PSOLBL2 K RXP,REPRINT
    12         .S (PSDFNFLG,PSOLAPPL)=0 S NEXTRX=$P(PPL,",",(PI+1)) I NEXTRX=""!(NEXTRX=",") S PSOLAPPL=1 Q
    13         .I PSOPDFN'=$P(^PSRX(NEXTRX,0),"^",2) S PSDFNFLG=1,PSOPDFN=$P(^PSRX(NEXTRX,0),"^",2) Q
    14         I $P(^PS(59,PSOSITE,1),"^",28) D ^PSOLBLN2
    15         D:'$P(^PS(59,PSOSITE,1),"^",28) ^PSOLBLS
    16 DQ5     I $D(^TMP($J,"PSOCP",DFN)),'$P(^PS(59,PSOSITE,1),"^",28) D INV^PSOCPE
    17 HLEX    K RXPI,PSORX,RXP,PSOIOS,PSOLAPPL,XXX,COPAYVAR,TECH,PHYS,MFG,NURSE,STATE,SIDE,COPIES,EXDT,ISD,PSOINST,RXN,RXY,VADT,DEA,WARN,FDT,QTY,PATST,PDA,PS,PS1,PS2,PSL,PSNP,INRX,RR,XTYPE,SSNP,SSNPN,PNM,ADDR,PSODBQ,PSOLASTF,PSRESOLV,PSOEXREP,PSOSXQ
    18         K ^TMP($J,"PSOCP",+$G(PSOCPN)),PSOCPN,PSOLBLDR,PSOLBLPS,PSOLBLCP,RXPR,RXRP,RXRS,PSOCKHN,RXFLX,PSOLAPPL,PSOPDFN,PSDFNFLG,PSOZERO,NEXTRX,PSOBLALL,STA S:'$G(PSOSUREP)&('$G(PSOSUSPR)) ZTREQ="@" Q
    19 C       I $G(IOST(0)),$D(^%ZIS(2,IOST(0),55,"B","LL")) G C^PSOLLLI
    20         U IO S X=$S('$P(^PS(59,PSOSITE,1),"^",28):132,1:158) X ^%ZOSF("RM") Q:'$D(^PSRX(RX,0))
    21         S:$G(PSOBLALL) PSOBLRX=RX
    22         S:$D(RXRP(RX)) REPRINT=1 S:$D(RXPR(RX)) RXP=RXPR(RX)
    23         I $G(PSOSUREP)!($G(PSOEXREP)) S REPRINT=1 S:'$G(RXRP(RX)) RXRP(RX)=1
    24         S RXY=^PSRX(RX,0),RXSTA=$P(^PSRX(RX,"STA"),"^") I RXSTA>11 D AL("QT") K RXY,RXP,REPRINT Q         ;*244
    25         I RXSTA=3 D AL("QT") K RXY,RXP,REPRINT Q
    26         I $G(RXPR(RX)),'$D(^PSRX(RX,"P",RXP,0)) K RXY,RXP,REPRINT Q
    27         I $P($G(RXFL(RX)),"^"),'$D(^PSRX(RX,1,$P($G(RXFL(RX)),"^"),0)) K RXY,RXP,REPRINT Q
    28         I $G(PSODBQ)!($G(RXRS(RX))) S RR=$O(^PS(52.5,"B",RX,0)) Q:'RR  I $G(^PS(52.5,RR,"P"))=1 K RXY,RXP,REPRINT Q
    29         I $G(RXRS(RX))!($G(PSOPULL)) S PSOSXQ=0 N DR,DA,DIE D  I $G(PSOSXQ) K RXY,RXP,REPRINT Q
    30         .S DA=$O(^PS(52.5,"B",RX,0)) Q:'DA  S A=$P($G(^PS(52.5,DA,0)),"^",7) Q:A=""
    31         .I A="Q" S DIE="^PS(52.5,",DR="3////P" D ^DIE Q
    32         .K RXRS(RX) S PSOSXQ=1
    33         I $G(PSRESOLV)=RX D ENLBL^PSOBSET K PSRESOLV
    34         I RXSTA'=4 D:$G(PSOSUSPR) AREC^PSOSUTL D:$G(PSOPULL)!($G(RXRS(RX))) AREC1^PSOSUTL D:$G(PSOSUREP) AREC^PSOSUSRP D:$G(PSXREP) AREC^PSXSRP
    35         K ^UTILITY("DIQ1",$J) S DA=$P($$SITE^VASITE(),"^") I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIC
    36         S RXN=$P(RXY,"^"),ISD=$P(RXY,"^",13),RXF=0,DFN=+$P(RXY,"^",2),SIG=$P($G(^PSRX(RX,"SIG")),"^"),ISD=$E(ISD,4,5)_"/"_$E(ISD,6,7)_"/"_($E(ISD,1,3)+1700),ZY=0,$P(LINE,"_",28)="_"
    37         S PSOLBLPS=+$P(RXY,"^",3),PSOLBLDR=+$P(RXY,"^",6)
    38         S NURSE=$S($P($G(^DPT(DFN,"NHC")),"^")="Y":1,$P($G(^PS(55,DFN,40)),"^"):1,1:0) S FDT=$P(^PSRX(RX,2),"^",2),PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:""),PS1=$S($D(^(1)):^(1),1:""),PSOSITE7=$P(^("IB"),"^")
    39         S PS2=$P(PS,"^")_"^"_$P(PS,"^",6)
    40         S (EXPDT,EXDT)=$P(^PSRX(RX,2),"^",6),EXDT=$S('EXDT:"",1:$E(EXDT,4,5)_"/"_$E(EXDT,6,7)_"/"_($E(EXDT,1,3)+1700))
    41         S COPIES=$S($P($G(RXRP(RX)),"^",2):$P($G(RXRP(RX)),"^",2),$P(RXY,"^",18)]"":$P(RXY,"^",18),1:1)
    42         K PSOCKHNX S PSOCKHL=$L(RX),PSOCKHN=$E($G(PSOCKHN),(PSOCKHL+2),999) D  K PSOCKHNX,PSOCKHL,PSOCKHA
    43         .S PSOCKHA=","_RX_","
    44         .I PSOCKHN'[PSOCKHA Q
    45         .S PSOCKHA=$E(PSOCKHA,1,($L(PSOCKHA)-1))
    46         .S PSOCKHNX=$L(PSOCKHN,PSOCKHA)-1
    47         .I +$G(PSOCKHNX)>0 D DOUB
    48         I $O(^PSRX(RX,1,0)),$G(RXFL(RX))'=0 S $P(^PSRX(RX,3),"^",6)="" K ^PSRX(RX,"DAI"),^PSRX(RX,"DRI")
    49         I '$G(RXP),'$O(^PSRX(RX,1,0)) S RXFL(RX)=0
    50         I '$G(RXP) D OSET I '$O(^PSRX(RX,1,0))!($G(RXFL(RX))=0) G ORIG
    51         I $O(^PSRX(RX,1,0)),'$G(RXP),'$G(RXFL(RX)) S XTYPE=1 D REF G STA
    52         I $O(^PSRX(RX,1,0)),'$G(RXP),$G(RXFL(RX)) G STA
    53         I $G(RXP) S XTYPE="P" D REF G STA
    54 ORIG    S TECH=$P($G(^VA(200,+$P(^PSRX(RX,0),"^",16),0)),"^"),QTY=$P(^PSRX(RX,0),"^",7),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UKN") D 6^VADPT,PID^VADPT S SSNPN=$E($G(VA("PID")),5,12)
    55         S DAYS=$P(^PSRX(RX,0),"^",8),MFG="________",LOT="________"
    56 STA     S STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UKN")
    57         S DRUG=$$ZZ^PSOSUTL(RX),DEA=$P($G(^PSDRUG(+$P(RXY,"^",6),0)),"^",3),WARN=$P($G(^(0)),"^",8)
    58         S SIDE=$S($P($G(RXRP(RX)),"^",3):1,1:0)
    59         I $G(^PSRX(RX,"P",+$G(RXP),0))]"" S RXPI=RXP D
    60         .S RXP=^PSRX(RX,"P",RXP,0)
    61         .S RXY=$P(RXP,"^")_"^"_$P(RXY,"^",2,6)_"^"_$P(RXP,"^",4)_"^"_$P(RXP,"^",10)_"^"_$P(RXY,"^",9)_"^"_$P($G(^PSRX(RX,"SIG")),"^",2)_"^"_$P(RXP,"^",2)_"^"_$P(RXY,"^",12,14)_"^"_$P(^PSRX(RX,"STA"),"^")_"^"_$P(RXP,"^",7)_"^"_$P(RXY,"^",17,99)
    62         .S FDT=$P(RXP,"^")
    63         S MW=$P(RXY,"^",11) I $G(RXFL(RX))'=0 D:$G(RXFL(RX))  I '$G(RXFL(RX)) F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I  S RXF=RXF+1 S:'$G(RXP) MW=$P(^PSRX(RX,1,I,0),"^",2) I +^PSRX(RX,1,I,0)'<FDT S FDT=+^(0)
    64         .I $G(RXFL(RX)),'$D(^PSRX(RX,1,RXFL(RX),0)) K RXFL(RX) Q
    65         .S RXF=RXFL(RX) S:'$G(RXP) MW=$P($G(^PSRX(RX,1,RXF,0)),"^",2) I +^PSRX(RX,1,RXF,0)'<FDT S FDT=+^(0)
    66         I MW="W" S PSMP=$G(^PSRX(RX,"MP")) I PSMP]"" D
    67         .S PSJ=0 F PSI=1:1:$L(PSMP) S PSMP(PSI)="",PSJ=PSJ+1 F PSJ=PSJ:1 S PSMP(PSI)=PSMP(PSI)_$P(PSMP," ",PSJ)_" " Q:($L(PSMP(PSI))+$L($P(PSMP," ",PSJ+1))>30)
    68         .K PSMP(PSI)
    69         S X=$S($D(^PS(55,DFN,0)):^(0),1:""),PSCAP=$P(X,"^",2),PS55=$P($G(X),"^",3),PS55X=$P($G(X),"^",5)
    70         I (($G(PS55X)]"")&(PS55>1)&(PS55X<DT)) S PS55=0
    71         S:MW="M" MW=$S((PS55=1!(PS55=4)):"R",1:MW)
    72         S MW=$S(MW="M":"REGULAR",MW="R":"CERTIFIED",1:"WINDOW")
    73         I ($G(PSMP(1))']""&($G(PS55)=2)) S PSMP(1)=$G(SSNPN)
    74         ;S X=$S($D(^PS(55,DFN,0)):^(0),1:""),PSCAP=$P(X,"^",2) S:MW="M" MW=$S(+$P(X,"^",3):"R",1:MW) S MW=$S(MW="M":"REGULAR",MW="R":"CERTIFIED",1:"WINDOW")
    75         S DATE=$E(FDT,1,7),REF=$P(RXY,"^",9)-RXF S:'$G(RXP) $P(^PSRX(RX,3),"^")=FDT S:REF<1 REF=0 D ^PSOLBL2 S II=RX D ^PSORFL,RFLDT^PSORFL
    76         S PATST=$G(^PS(53,+$P(RXY,"^",3),0)) S PRTFL=1 I REF=0 S:('$P(PATST,"^",5))!(DEA["W")!(DEA[1)!(DEA[2) PRTFL=0
    77         S VRPH=$P(^PSRX(RX,2),"^",10),PSCLN=+$P(RXY,"^",5),PSCLN=$S($D(^SC(PSCLN,0)):$P(^(0),"^",2),1:"UNKNOWN")
    78         S PATST=$P(PATST,"^",2),X1=DT,X2=$P(RXY,"^",8)-10 D C^%DTC:REF I $D(^PSRX(RX,2)),$P(^(2),"^",6),REF,X'<$P(^(2),"^",6) S REF=0,VRPH=$P(^(2),"^",10)
    79         I $G(PSOCHAMP),$G(PSOTRAMT) S COPAYVAR="CHAMPUS" G LBL
    80         I $G(RXP) S COPAYVAR="" G LBL
    81         I $P($G(^PS(53,+$G(PSOLBLPS),0)),"^",7) D SNO G LBL
    82         I $P($G(^PSDRUG(+$G(PSOLBLDR),0)),"^",3)["I"!($P($G(^(0)),"^",3)["S") D SNO G LBL
    83         I $P(^PSRX(RX,"STA"),"^")>0,$P(^("STA"),"^")'=2,'$G(PSODBQ) D SNO G LBL
    84         I $G(PSOLBLCP)="" D IBCP
    85         N PSOQI S PSOQI=$G(^PSRX(RX,"IBQ")) I $G(PSOLBLCP)=0 D SNO G LBL
    86         I $G(PSOLBLCP)=1 I $P(PSOQI,"^",2)!($P(PSOQI,"^",3))!($P(PSOQI,"^",4))!($P(PSOQI,"^",5))!($P(PSOQI,"^",6))!($P(PSOQI,"^",7))!($P(PSOQI,"^",8)) D SNO G LBL
    87         I $G(PSOLBLCP)=2 I $P(PSOQI,"^")!($P(PSOQI,"^",2))!($P(PSOQI,"^",3))!($P(PSOQI,"^",4))!($P(PSOQI,"^",5))!($P(PSOQI,"^",6))!($P(PSOQI,"^",7))!($P(PSOQI,"^",8)) D SNO G LBL
    88         I $G(PSOLBLCP)=2,'$P($G(^PSRX(RX,"IB")),"^") D SNO G LBL
    89         S PSOCPN=$P(^PSRX(RX,0),"^",2),INRX=$P(^(0),"^") I $G(^TMP($J,"PSOCP",PSOCPN))="" S ^(PSOCPN)=PSOCPN
    90         S ^TMP($J,"PSOCP",PSOCPN,INRX)=INRX_"^"_$$ZZ^PSOSUTL(RX)_"^"_+$G(DAYS) S COPAYVAR="COPAY" K ZDRUG
    91 LBL     G ^PSOLBLD:$P(^PSRX(RX,"STA"),"^")=4 D ^PSOLBLD:$D(^PSRX(RX,"DRI"))&('$G(RXF))&('$G(RXP)) D:$P($G(^PSRX(RX,3)),"^",6)&('$G(RXF))&('$G(RXP)) ^PSOLBLD1 G ^PSOLBL1:'$P(^PS(59,PSOSITE,1),"^",28)
    92         G ^PSOLBLN
    93 REF     F XXX=0:0 S XXX=$O(^PSRX(RX,XTYPE,XXX)) Q:+XXX'>0  D
    94         .S TECH=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",7),0)):$P(^(0),"^"),1:"UNKNOWN")
    95         .S QTY=$P(^PSRX(RX,XTYPE,XXX,0),"^",4),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",17),0)):$P(^(0),"^"),$D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT S SSNPN=$E($G(VA("PID")),5,12)
    96         .S DAYS=$P(^PSRX(RX,XTYPE,XXX,0),"^",10),LOT="________",MFG="________"
    97         Q
    98 CHECK   S PSDFNFLG=0,PSOZERO=$P(PPL,","),PSOPDFN=$P(^PSRX(PSOZERO,0),"^",2)
    99         Q
    100 OSET    D OSET^PSOLBL1
    101         Q
    102 DOUB    Q:'$D(RXFL(RX))  I +$G(RXFL(RX))-PSOCKHNX<0 Q
    103         S RXFLX(RX)=$G(RXFL(RX)),RXFL(RX)=$G(RXFL(RX))-PSOCKHNX
    104         Q
    105 AL(T)   N I,IR,RF,USR,TY,DES S USR=""
    106         I T="UT" D
    107         .N J,RX S USR=$G(DUZ),TY="B",DES="Label never queued to print by User"
    108         .F J=1:1  S RX=+$P(PPL,",",J) Q:'RX  D AL1
    109         I T="QT" D
    110         .S I=+$P(^PSRX(RX,"STA"),"^"),TY=$S((I=3)!(I=16):"H",I=13:"D",1:"C")
    111         .S DES=I_" "_$S((I=3)!(I=16):"HOLD"_$S(I=16:"(PROVIDER)",1:""),(I=12)!(I=14)!(I=15):"DISCONTINUED"_$S(I=14:"(PROVIDER)",I=15:"(EDIT)",1:""),I=13:"DELETED",1:"")
    112         .S DES="Queued label terminated - "_DES D AL1
    113         K %,%H,%I Q
    114 AL1     S (IR,I,RF)=0 F  S I=$O(^PSRX(RX,1,I)) Q:'I  S RF=I S:I>5 RF=I+1
    115         S I=0 F  S I=$O(^PSRX(RX,"A",I)) Q:'I  S IR=I
    116         S IR=IR+1,^PSRX(RX,"A",0)="^52.3DA^"_IR_"^"_IR
    117         D NOW^%DTC S ^PSRX(RX,"A",IR,0)=%_"^"_TY_"^"_USR_"^"_$S($G(RXPR(RX)):6,1:RF)_"^"_DES
    118         Q
    119 IBCP    N X,Y,PSOJJ,PSOLL
    120         S PSOLBLCP="",X=$P($G(^PS(59,+$G(PSOSITE),"IB")),"^")_"^"_$G(DFN) D XTYPE^IBARX
    121         S PSOJJ="" F  S PSOJJ=$O(Y(PSOJJ)) Q:'PSOJJ  S PSOLL="" F  S PSOLL=$O(Y(PSOJJ,PSOLL)) Q:PSOLL=""  S:PSOLL>0 PSOLBLCP=PSOLL
    122         I '$G(PSOLBLCP) S PSOLBLCP=0
    123         Q
    124 SNO     S COPAYVAR="NO COPAY" Q
     1PSOLBL ;BIR/SAB/RTR-BOTTLE LABEL ;6/29/06 11:39am
     2 ;;7.0;OUTPATIENT PHARMACY;**8,19,30,36,47,71,92,120,157,244**;DEC 1997
     3 ;DBIAs PSDRUG-221, PS(55-2228, IBARX-125, PSXSRP-2201, %ZIS-3435, DPT-3097
     4 ;
     5 ;*244 remove test for partial fill when testing status > 11
     6 ;
     7DQ I $D(PSOIOS),PSOIOS]"" D DEVBAR^PSOBMST
     8 I $G(PSOBAR0)]"",$G(PSOBAR1)]"",$D(^PS(59,PSOSITE,1)) S PSOBARS=1
     9DQ1 D ^PSOLBL4
     10 I $G(IOST(0)),$D(^%ZIS(2,IOST(0),55,"B","LL")) G ^PSOLLLI
     11 G:'$D(PPL) HLEX G:($P($G(PSOPAR),"^",30)=2)&('$G(PSOEXREP)) HLEX K RXFLX S PSOCKHN=","_$G(PPL) S PSRESOLV=+PPL D CHECK F PI=1:1  D  S RX=$P(PPL,",",PI) D C Q:$G(PSOLAPPL)  D:$G(PSDFNFLG) TRAIL^PSOLBL2 K RXP,REPRINT
     12 .S (PSDFNFLG,PSOLAPPL)=0 S NEXTRX=$P(PPL,",",(PI+1)) I NEXTRX=""!(NEXTRX=",") S PSOLAPPL=1 Q
     13 .I PSOPDFN'=$P(^PSRX(NEXTRX,0),"^",2) S PSDFNFLG=1,PSOPDFN=$P(^PSRX(NEXTRX,0),"^",2) Q
     14 I $P(^PS(59,PSOSITE,1),"^",28) D ^PSOLBLN2
     15 D:'$P(^PS(59,PSOSITE,1),"^",28) ^PSOLBLS
     16DQ5 I $D(^TMP($J,"PSOCP",DFN)),'$P(^PS(59,PSOSITE,1),"^",28) D INV^PSOCPE
     17HLEX K RXPI,PSORX,RXP,PSOIOS,PSOLAPPL,XXX,COPAYVAR,TECH,PHYS,MFG,NURSE,STATE,SIDE,COPIES,EXDT,ISD,PSOINST,RXN,RXY,VADT,DEA,WARN,FDT,QTY,PATST,PDA,PS,PS1,PS2,PSL,PSNP,INRX,RR,XTYPE,SSNP,SSNPN,PNM,ADDR,PSODBQ,PSOLASTF,PSRESOLV,PSOEXREP,PSOSXQ
     18 K ^TMP($J,"PSOCP",+$G(PSOCPN)),PSOCPN,PSOLBLDR,PSOLBLPS,PSOLBLCP,RXPR,RXRP,RXRS,PSOCKHN,RXFLX,PSOLAPPL,PSOPDFN,PSDFNFLG,PSOZERO,NEXTRX,PSOBLALL,STA S:'$G(PSOSUREP)&('$G(PSOSUSPR)) ZTREQ="@" Q
     19C I $G(IOST(0)),$D(^%ZIS(2,IOST(0),55,"B","LL")) G C^PSOLLLI
     20 U IO S X=$S('$P(^PS(59,PSOSITE,1),"^",28):132,1:158) X ^%ZOSF("RM") Q:'$D(^PSRX(RX,0))
     21 S:$G(PSOBLALL) PSOBLRX=RX
     22 S:$D(RXRP(RX)) REPRINT=1 S:$D(RXPR(RX)) RXP=RXPR(RX)
     23 I $G(PSOSUREP)!($G(PSOEXREP)) S REPRINT=1 S:'$G(RXRP(RX)) RXRP(RX)=1
     24 S RXY=^PSRX(RX,0),RXSTA=$P(^PSRX(RX,"STA"),"^") I RXSTA>11 D AL("QT") K RXY,RXP,REPRINT Q         ;*244
     25 I RXSTA=3 D AL("QT") K RXY,RXP,REPRINT Q
     26 I $G(RXPR(RX)),'$D(^PSRX(RX,"P",RXP,0)) K RXY,RXP,REPRINT Q
     27 I $P($G(RXFL(RX)),"^"),'$D(^PSRX(RX,1,$P($G(RXFL(RX)),"^"),0)) K RXY,RXP,REPRINT Q
     28 I $G(PSODBQ)!($G(RXRS(RX))) S RR=$O(^PS(52.5,"B",RX,0)) Q:'RR  I $G(^PS(52.5,RR,"P"))=1 K RXY,RXP,REPRINT Q
     29 I $G(RXRS(RX))!($G(PSOPULL)) S PSOSXQ=0 N DR,DA,DIE D  I $G(PSOSXQ) K RXY,RXP,REPRINT Q
     30 .S DA=$O(^PS(52.5,"B",RX,0)) Q:'DA  S A=$P($G(^PS(52.5,DA,0)),"^",7) Q:A=""
     31 .I A="Q" S DIE="^PS(52.5,",DR="3////P" D ^DIE Q
     32 .K RXRS(RX) S PSOSXQ=1
     33 I $G(PSRESOLV)=RX D ENLBL^PSOBSET K PSRESOLV
     34 I RXSTA'=4 D:$G(PSOSUSPR) AREC^PSOSUTL D:$G(PSOPULL)!($G(RXRS(RX))) AREC1^PSOSUTL D:$G(PSOSUREP) AREC^PSOSUSRP D:$G(PSXREP) AREC^PSXSRP
     35 K ^UTILITY("DIQ1",$J) S DA=$P($$SITE^VASITE(),"^") I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIC
     36 S RXN=$P(RXY,"^"),ISD=$P(RXY,"^",13),RXF=0,DFN=+$P(RXY,"^",2),SIG=$P($G(^PSRX(RX,"SIG")),"^"),ISD=$E(ISD,4,5)_"/"_$E(ISD,6,7)_"/"_($E(ISD,1,3)+1700),ZY=0,$P(LINE,"_",28)="_"
     37 S PSOLBLPS=+$P(RXY,"^",3),PSOLBLDR=+$P(RXY,"^",6)
     38 S NURSE=$S($P($G(^DPT(DFN,"NHC")),"^")="Y":1,$P($G(^PS(55,DFN,40)),"^"):1,1:0) S FDT=$P(^PSRX(RX,2),"^",2),PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:""),PS1=$S($D(^(1)):^(1),1:""),PSOSITE7=$P(^("IB"),"^")
     39 S PS2=$P(PS,"^")_"^"_$P(PS,"^",6)
     40 S (EXPDT,EXDT)=$P(^PSRX(RX,2),"^",6),EXDT=$S('EXDT:"",1:$E(EXDT,4,5)_"/"_$E(EXDT,6,7)_"/"_($E(EXDT,1,3)+1700))
     41 S COPIES=$S($P($G(RXRP(RX)),"^",2):$P($G(RXRP(RX)),"^",2),$P(RXY,"^",18)]"":$P(RXY,"^",18),1:1)
     42 K PSOCKHNX S PSOCKHL=$L(RX),PSOCKHN=$E($G(PSOCKHN),(PSOCKHL+2),999) D  K PSOCKHNX,PSOCKHL,PSOCKHA
     43 .S PSOCKHA=","_RX_","
     44 .I PSOCKHN'[PSOCKHA Q
     45 .S PSOCKHA=$E(PSOCKHA,1,($L(PSOCKHA)-1))
     46 .S PSOCKHNX=$L(PSOCKHN,PSOCKHA)-1
     47 .I +$G(PSOCKHNX)>0 D DOUB
     48 I $O(^PSRX(RX,1,0)),$G(RXFL(RX))'=0 S $P(^PSRX(RX,3),"^",6)="" K ^PSRX(RX,"DAI"),^PSRX(RX,"DRI")
     49 I '$G(RXP),'$O(^PSRX(RX,1,0)) S RXFL(RX)=0
     50 I '$G(RXP) D OSET I '$O(^PSRX(RX,1,0))!($G(RXFL(RX))=0) G ORIG
     51 I $O(^PSRX(RX,1,0)),'$G(RXP),'$G(RXFL(RX)) S XTYPE=1 D REF G STA
     52 I $O(^PSRX(RX,1,0)),'$G(RXP),$G(RXFL(RX)) G STA
     53 I $G(RXP) S XTYPE="P" D REF G STA
     54ORIG S TECH=$P($G(^VA(200,+$P(^PSRX(RX,0),"^",16),0)),"^"),QTY=$P(^PSRX(RX,0),"^",7),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UKN") D 6^VADPT,PID^VADPT S SSNPN=$E($G(VA("PID")),5,12)
     55 S DAYS=$P(^PSRX(RX,0),"^",8),MFG="________",LOT="________"
     56STA S STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UKN")
     57 S DRUG=$$ZZ^PSOSUTL(RX),DEA=$P($G(^PSDRUG(+$P(RXY,"^",6),0)),"^",3),WARN=$P($G(^(0)),"^",8)
     58 S SIDE=$S($P($G(RXRP(RX)),"^",3):1,1:0)
     59 I $G(^PSRX(RX,"P",+$G(RXP),0))]"" S RXPI=RXP D
     60 .S RXP=^PSRX(RX,"P",RXP,0)
     61 .S RXY=$P(RXP,"^")_"^"_$P(RXY,"^",2,6)_"^"_$P(RXP,"^",4)_"^"_$P(RXP,"^",10)_"^"_$P(RXY,"^",9)_"^"_$P($G(^PSRX(RX,"SIG")),"^",2)_"^"_$P(RXP,"^",2)_"^"_$P(RXY,"^",12,14)_"^"_$P(^PSRX(RX,"STA"),"^")_"^"_$P(RXP,"^",7)_"^"_$P(RXY,"^",17,99)
     62 .S FDT=$P(RXP,"^")
     63 S MW=$P(RXY,"^",11) I $G(RXFL(RX))'=0 D:$G(RXFL(RX))  I '$G(RXFL(RX)) F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I  S RXF=RXF+1 S:'$G(RXP) MW=$P(^PSRX(RX,1,I,0),"^",2) I +^PSRX(RX,1,I,0)'<FDT S FDT=+^(0)
     64 .I $G(RXFL(RX)),'$D(^PSRX(RX,1,RXFL(RX),0)) K RXFL(RX) Q
     65 .S RXF=RXFL(RX) S:'$G(RXP) MW=$P($G(^PSRX(RX,1,RXF,0)),"^",2) I +^PSRX(RX,1,RXF,0)'<FDT S FDT=+^(0)
     66 I MW="W" S PSMP=$G(^PSRX(RX,"MP")) I PSMP]"" D
     67 .S PSJ=0 F PSI=1:1:$L(PSMP) S PSMP(PSI)="",PSJ=PSJ+1 F PSJ=PSJ:1 S PSMP(PSI)=PSMP(PSI)_$P(PSMP," ",PSJ)_" " Q:($L(PSMP(PSI))+$L($P(PSMP," ",PSJ+1))>30)
     68 .K PSMP(PSI)
     69 S X=$S($D(^PS(55,DFN,0)):^(0),1:""),PSCAP=$P(X,"^",2),PS55=$P($G(X),"^",3),PS55X=$P($G(X),"^",5)
     70 I (($G(PS55X)]"")&(PS55>1)&(PS55X<DT)) S PS55=1
     71 S:MW="M" MW=$S((PS55=1!(PS55=4)):"R",1:MW)
     72 S MW=$S(MW="M":"REGULAR",MW="R":"CERTIFIED",1:"WINDOW")
     73 I ($G(PSMP(1))']""&($G(PS55)=2)) S PSMP(1)=$G(SSNPN)
     74 ;S X=$S($D(^PS(55,DFN,0)):^(0),1:""),PSCAP=$P(X,"^",2) S:MW="M" MW=$S(+$P(X,"^",3):"R",1:MW) S MW=$S(MW="M":"REGULAR",MW="R":"CERTIFIED",1:"WINDOW")
     75 S DATE=$E(FDT,1,7),REF=$P(RXY,"^",9)-RXF S:'$G(RXP) $P(^PSRX(RX,3),"^")=FDT S:REF<1 REF=0 D ^PSOLBL2 S II=RX D ^PSORFL,RFLDT^PSORFL
     76 S PATST=$G(^PS(53,+$P(RXY,"^",3),0)) S PRTFL=1 I REF=0 S:('$P(PATST,"^",5))!(DEA["A"&(DEA'["B"))!(DEA["W") PRTFL=0
     77 S VRPH=$P(^PSRX(RX,2),"^",10),PSCLN=+$P(RXY,"^",5),PSCLN=$S($D(^SC(PSCLN,0)):$P(^(0),"^",2),1:"UNKNOWN")
     78 S PATST=$P(PATST,"^",2),X1=DT,X2=$P(RXY,"^",8)-10 D C^%DTC:REF I $D(^PSRX(RX,2)),$P(^(2),"^",6),REF,X'<$P(^(2),"^",6) S REF=0,VRPH=$P(^(2),"^",10)
     79 I $G(PSOCHAMP),$G(PSOTRAMT) S COPAYVAR="CHAMPUS" G LBL
     80 I $G(RXP) S COPAYVAR="" G LBL
     81 I $P($G(^PS(53,+$G(PSOLBLPS),0)),"^",7) D SNO G LBL
     82 I $P($G(^PSDRUG(+$G(PSOLBLDR),0)),"^",3)["I"!($P($G(^(0)),"^",3)["S") D SNO G LBL
     83 I $P(^PSRX(RX,"STA"),"^")>0,$P(^("STA"),"^")'=2,'$G(PSODBQ) D SNO G LBL
     84 I $G(PSOLBLCP)="" D IBCP
     85 N PSOQI S PSOQI=$G(^PSRX(RX,"IBQ")) I $G(PSOLBLCP)=0 D SNO G LBL
     86 I $G(PSOLBLCP)=1 I $P(PSOQI,"^",2)!($P(PSOQI,"^",3))!($P(PSOQI,"^",4))!($P(PSOQI,"^",5))!($P(PSOQI,"^",6))!($P(PSOQI,"^",7)) D SNO G LBL
     87 I $G(PSOLBLCP)=2 I $P(PSOQI,"^")!($P(PSOQI,"^",2))!($P(PSOQI,"^",3))!($P(PSOQI,"^",4))!($P(PSOQI,"^",5))!($P(PSOQI,"^",6))!($P(PSOQI,"^",7)) D SNO G LBL
     88 I $G(PSOLBLCP)=2,'$P($G(^PSRX(RX,"IB")),"^") D SNO G LBL
     89 S PSOCPN=$P(^PSRX(RX,0),"^",2),INRX=$P(^(0),"^") I $G(^TMP($J,"PSOCP",PSOCPN))="" S ^(PSOCPN)=PSOCPN
     90 S ^TMP($J,"PSOCP",PSOCPN,INRX)=INRX_"^"_$$ZZ^PSOSUTL(RX)_"^"_+$G(DAYS) S COPAYVAR="COPAY" K ZDRUG
     91LBL G ^PSOLBLD:$P(^PSRX(RX,"STA"),"^")=4 D ^PSOLBLD:$D(^PSRX(RX,"DRI"))&('$G(RXF))&('$G(RXP)) D:$P($G(^PSRX(RX,3)),"^",6)&('$G(RXF))&('$G(RXP)) ^PSOLBLD1 G ^PSOLBL1:'$P(^PS(59,PSOSITE,1),"^",28)
     92 G ^PSOLBLN
     93REF F XXX=0:0 S XXX=$O(^PSRX(RX,XTYPE,XXX)) Q:+XXX'>0  D
     94 .S TECH=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",7),0)):$P(^(0),"^"),1:"UNKNOWN")
     95 .S QTY=$P(^PSRX(RX,XTYPE,XXX,0),"^",4),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",17),0)):$P(^(0),"^"),$D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT S SSNPN=$E($G(VA("PID")),5,12)
     96 .S DAYS=$P(^PSRX(RX,XTYPE,XXX,0),"^",10),LOT="________",MFG="________"
     97 Q
     98CHECK S PSDFNFLG=0,PSOZERO=$P(PPL,","),PSOPDFN=$P(^PSRX(PSOZERO,0),"^",2)
     99 Q
     100OSET I $G(RXFL(RX))']""!($G(RXFL(RX))=0) D  Q
     101 .S TECH=$P($G(^VA(200,+$P(^PSRX(RX,0),"^",16),0)),"^"),QTY=$P(^PSRX(RX,0),"^",7),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UKN") D 6^VADPT,PID^VADPT S SSNPN=$E($G(VA("PID")),5,12)
     102 .S DAYS=$P(^PSRX(RX,0),"^",8),MFG="________",LOT="________"
     103 I '$D(^PSRX(RX,1,RXFL(RX),0)) K RXFL(RX) Q
     104 S TECH=$S($D(^VA(200,+$P(^PSRX(RX,1,RXFL(RX),0),"^",7),0)):$P(^(0),"^"),1:"UNKNOWN")
     105 S QTY=$P(^PSRX(RX,1,RXFL(RX),0),"^",4),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,1,RXFL(RX),0),"^",17),0)):$P(^(0),"^"),$D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT S SSNPN=$E($G(VA("PID")),5,12)
     106 S DAYS=$P(^PSRX(RX,1,RXFL(RX),0),"^",10),LOT="________",MFG="________"
     107 Q
     108DOUB Q:'$D(RXFL(RX))  I +$G(RXFL(RX))-PSOCKHNX<0 Q
     109 S RXFLX(RX)=$G(RXFL(RX)),RXFL(RX)=$G(RXFL(RX))-PSOCKHNX
     110 Q
     111AL(T) N I,IR,RF,USR,TY,DES S USR=""
     112 I T="UT" D
     113 .N J,RX S USR=$G(DUZ),TY="B",DES="Label never queued to print by User"
     114 .F J=1:1  S RX=+$P(PPL,",",J) Q:'RX  D AL1
     115 I T="QT" D
     116 .S I=+$P(^PSRX(RX,"STA"),"^"),TY=$S((I=3)!(I=16):"H",I=13:"D",1:"C")
     117 .S DES=I_" "_$S((I=3)!(I=16):"HOLD"_$S(I=16:"(PROVIDER)",1:""),(I=12)!(I=14)!(I=15):"DISCONTINUED"_$S(I=14:"(PROVIDER)",I=15:"(EDIT)",1:""),I=13:"DELETED",1:"")
     118 .S DES="Queued label terminated - "_DES D AL1
     119 K %,%H,%I Q
     120AL1 S (IR,I,RF)=0 F  S I=$O(^PSRX(RX,1,I)) Q:'I  S RF=I S:I>5 RF=I+1
     121 S I=0 F  S I=$O(^PSRX(RX,"A",I)) Q:'I  S IR=I
     122 S IR=IR+1,^PSRX(RX,"A",0)="^52.3DA^"_IR_"^"_IR
     123 D NOW^%DTC S ^PSRX(RX,"A",IR,0)=%_"^"_TY_"^"_USR_"^"_$S($G(RXPR(RX)):6,1:RF)_"^"_DES
     124 Q
     125IBCP N X,Y,PSOJJ,PSOLL
     126 S PSOLBLCP="",X=$P($G(^PS(59,+$G(PSOSITE),"IB")),"^")_"^"_$G(DFN) D XTYPE^IBARX
     127 S PSOJJ="" F  S PSOJJ=$O(Y(PSOJJ)) Q:'PSOJJ  S PSOLL="" F  S PSOLL=$O(Y(PSOJJ,PSOLL)) Q:PSOLL=""  S:PSOLL>0 PSOLBLCP=PSOLL
     128 I '$G(PSOLBLCP) S PSOLBLCP=0
     129 Q
     130SNO S COPAYVAR="NO COPAY" Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL1.m

    r613 r623  
    1 PSOLBL1 ;BHAM ISC/SAB - PRINTS LABEL ;1/20/93 14:25
    2         ;;7.0;OUTPATIENT PHARMACY;**107,110,225**;DEC 1997;Build 29
    3 START   S COPIES=COPIES-1
    4         W $C(13) S $X=0 W "VA (119)",?10,$E(DT,4,5),"/",$E(DT,6,7),"/",$E(DT,2,3) W:('SIDE)&(PRTFL) ?40,"PLEASE REFER ONLY TO '",$S(REF:"1. REFILL REQUEST",1:"2. RENEWAL ORDER"),"'" W:+$G(RXP) ?100,"(PARTIAL)" W:$D(REPRINT) ?110,"(REPRINT)"
    5         W !,$P(PS,"^",2) W:('SIDE)&(PRTFL) ?40,"INSTRUCTION ON REVERSE SIDE OF THIS FORM" W:'SIDE ?102,"(Filled at ",$P(PS2,"^",2),")"
    6         W !,$P(PS,"^",7),", ",STATE,"  ",$P(PS,"^",5) W:'SIDE ?83,"*** ",$P(PS2,"^")," ***"
    7         W !,?22,$S(MW["C":"CERTIFIED MAIL",1:"") W:'SIDE ?38,SSNP,?69,"RX: ",RXN
    8         W !,?2,PNM W:'SIDE ?38,PNM,?64,"EXPIRES: ",EXDT W:('SIDE)&(PRTFL) ?83,"INDICATE ANY ADDRESS CHANGES"
    9         W !,?2,$S($D(PSMP(1)):PSMP(1),1:VAPA(1)) W:'SIDE ?38,$E(VAPA(1),1,25),?64,"REFILLS: ",REF ;W:('SIDE)&(PRTFL) ?83,LINE
    10         W:('SIDE)&(PRTFL) ?83,"_____PERM.   _____TEMP." W:'PRTFL ?83,"* A 'NEW' RX IS REQUIRED.        *"
    11         S ADDR(3)=VAPA(4)_", "_$P($G(^DIC(5,+$P(VAPA(5),"^"),0)),"^",2)_"  "_VAPA(6),ADDR(2)="" S:VAPA(2)]"" ADDR(2)=VAPA(2)_" "_VAPA(3)
    12         I ADDR(2)="" S ADDR(2)=ADDR(3),ADDR(3)=""
    13         S ADDR(5)=$E(VAPA(4),1,13)_", "_$P($G(^DIC(5,+$P(VAPA(5),"^"),0)),"^",2)_"  "_VAPA(6)
    14         W !,?2,$S($D(PSMP(2)):PSMP(2),$D(PSMP(1)):"",1:$E(ADDR(2),1,35)) W:'SIDE ?38,$S($G(ADDR(3))="":ADDR(5),1:$E(ADDR(2),1,24)),?62,$S(RFLMSG]"":"*",1:" "),"LST FILL: "
    15         W:'SIDE $G(PSOLASTF)
    16         I 'SIDE W:PRTFL ?83,"ADDRESS: ",$E(LINE,1,23) W:'PRTFL ?83,"********** PLEASE NOTE ***********"
    17         W !,?2,$S($D(PSMP(3)):PSMP(3),$D(PSMP(1)):"",1:ADDR(3)) I 'SIDE W ?38,$S(ADDR(3)'="":ADDR(5),1:""),?64,"ROUTING: ",$S(MW="REGULAR":"MAIL",1:MW) W:PRTFL ?83,"CITY/STATE/ZIP: ",$E(LINE,1,16) W:'PRTFL ?83,"* THIS RX CAN NOT BE 'RENEWED'.  *"
    18         ;NEW LABEL WHITE SPACE
    19         I +$G(PSOBARS),'SIDE,$P(PSOPAR,"^",19)'=1 S X="S",X2=PSOINST_"-"_RX W !,?40 S X1=$X W @PSOBAR1,X2,@PSOBAR0,$C(13),!,$S($G(PS55)=2:"***DO NOT MAIL***",1:"**CRITICAL MEDICAL SHIPMENT**"),!
    20         E  F NLWS=1:1:6 W ! W:NLWS=5 $S($G(PS55)=2:"***DO NOT MAIL***",1:"**CRITICAL MEDICAL SHIPMENT**")
    21         W !,?8,"VA Medical Center" I 'SIDE W ?38,INT(1)
    22         W !,$P(PS,"^"),"  ",$P(PS,"^",3),"-",$P(PS,"^",4) W:'SIDE ?38,INT(2) I 'SIDE W:PRTFL ?83 W:'PRTFL ?83,"* PLEASE CONTACT YOUR PHYSICIAN. *"
    23         W !,?4,RXN,?15,$E(DATE,4,5),"/",$E(DATE,6,7),"/",$E(DATE,2,3),"   (",RXF+1," OF ",1+$P(RXY,"^",9),")" I 'SIDE W ?38,INT(3) W:(PRTFL)&('REF) ?83,"***** FOR PHYSICIAN USE ONLY *****" W:'PRTFL ?83,"**********************************"
    24         W !,PNM,?29,"#",$P(RXY,"^",7)
    25         W:'SIDE ?38,"CAP: ",$S(PSCAP:"**NON-SFTY**",1:"SAFETY")," WARN:",WARN,?68,$E(DATE,4,5),"/",$E(DATE,6,7),"/",$E(DATE,2,3)," " S I1=$P($H,",",2)\60 W:'SIDE I1\60,":",(I1#60\10)_(I1#10) W:('SIDE)&(PRTFL) ?83,"SIGNATURE : ",$E(LINE,1,20)
    26 SIG     F DR=1:1:$S(SGC<5:4,1:6) D SIG1
    27         I SGC>4 F I=1:1:22 W ! I I>22-SGC S DR=DR+1,X=$S($D(SGY(DR)):SGY(DR),1:"") W X W:'SIDE ?38,X
    28         ;I SGC>4 F I=1:1:$S($P($G(PSOPAR),"^",10):22,1:16) W ! I I>($S($P($G(PSOPAR),"^",10):28,1:22)-SGC) S DR=DR+1,X=$S($D(SGY(DR)):SGY(DR),1:"") W X W:'SIDE ?38,X
    29         W !?3,$E(PHYS,1,14),?25,"(",$P(RXY,"^",16),"/",$S($D(VRPH):VRPH,1:" "),")" W:'SIDE ?38,DRUG,?38+$L(DRUG)," (QTY:",$P(RXY,"^",7)," DAYS:",$P(RXY,"^",8)," FILL: ",RXF+1," OF ",1+$P(RXY,"^",9)," ISD:",ISD,")"
    30         W !,DRUG W:'SIDE ?38,PHYS,?62,RFLMSG,?100,PATST,"  ",PSCLN
    31         I $D(PSOBARS),PSOBARS W $C(13),# S $X=0
    32         E  W !
    33         I COPIES>0 S SIDE=1 G START
    34         ;STORE LABEL PRINT NODE
    35         D NOW^%DTC S NOW=% K %,%H,%I S RXF=0 F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I  S RXF=I
    36         S IR=0 F FDA=0:0 S FDA=$O(^PSRX(RX,"L",FDA)) Q:'FDA  S IR=FDA
    37         S IR=IR+1,^PSRX(RX,"L",0)="^52.032DA^"_IR_"^"_IR
    38         S ^PSRX(RX,"L",IR,0)=NOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_$S($G(PCOMX)]"":$G(PCOMX),1:"From RX number "_$P(^PSRX(RX,0),"^"))_$S($G(RXP):" (Partial)",1:"")_$S($D(REPRINT):" (Reprint)",1:"")_"^"_PDUZ
    39         S ^PSRX(RX,"TYPE")=0 K RXF,IR,FDA,NOW,I
    40         I '$D(PSSPND),$P(PSOPAR,"^",18) D CHCK2^PSOTRLBL
    41 END     K PSCLN,%DT,ADDR,DATE,DEA,DR,DR1,DRX,DRUG,FDT,SGY,RXY,RXZ,RYY,RFLMSG,RFL,%H,COPIES,DOB,DRUG,LIM,LMI,LINE,PS,PS1,PS2,INT,ISD,I1,MW,MAIL,STATE,SIDE,SSNP,SS,ST,ST1,PATST,PRTFL,PHYS,PNM,S,SL,SGC,PSMP,PSI,PSJ,VRPH,REPRINT,PS55,PS55X Q
    42         Q
    43         ;
    44 SIG1    S X=$S($D(SGY(DR)):SGY(DR),1:"") W !,X
    45         I 'SIDE W ?38,X I PRTFL W ?83 W:DR=1 ?83,$S('REF:"PRINT NAME: "_$E(LINE,1,25),1:"") W:DR=2 "DATE: ",$E(LINE,1,10) W:(DR=2)&('REF) " DEA# ",$E(LINE,1,6) W:(DR=3)&('REF) "Refills: 0 1 2 3 4 5 6 7 8 9 10 11"
    46         Q
    47         ;
    48 OSET    I $G(RXFL(RX))']""!($G(RXFL(RX))=0) D  Q
    49         .S TECH=$P($G(^VA(200,+$P(^PSRX(RX,0),"^",16),0)),"^"),QTY=$P(^PSRX(RX,0),"^",7),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UKN") D 6^VADPT,PID^VADPT S SSNPN=$E($G(VA("PID")),5,12)
    50         .S DAYS=$P(^PSRX(RX,0),"^",8),MFG="________",LOT="________"
    51         I '$D(^PSRX(RX,1,RXFL(RX),0)) K RXFL(RX) Q
    52         S TECH=$S($D(^VA(200,+$P(^PSRX(RX,1,RXFL(RX),0),"^",7),0)):$P(^(0),"^"),1:"UNKNOWN")
    53         S QTY=$P(^PSRX(RX,1,RXFL(RX),0),"^",4),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,1,RXFL(RX),0),"^",17),0)):$P(^(0),"^"),$D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT S SSNPN=$E($G(VA("PID")),5,12)
    54         S DAYS=$P(^PSRX(RX,1,RXFL(RX),0),"^",10),LOT="________",MFG="________"
    55         Q
     1PSOLBL1 ;BHAM ISC/SAB - PRINTS LABEL ;1/20/93 14:25
     2 ;;7.0;OUTPATIENT PHARMACY;**107,110**;DEC 1997
     3START S COPIES=COPIES-1
     4 W $C(13) S $X=0 W "VA (119)",?10,$E(DT,4,5),"/",$E(DT,6,7),"/",$E(DT,2,3) W:('SIDE)&(PRTFL) ?40,"PLEASE REFER ONLY TO '",$S(REF:"1. REFILL REQUEST",1:"2. RENEWAL ORDER"),"'" W:+$G(RXP) ?100,"(PARTIAL)" W:$D(REPRINT) ?110,"(REPRINT)"
     5 W !,$P(PS,"^",2) W:('SIDE)&(PRTFL) ?40,"INSTRUCTION ON REVERSE SIDE OF THIS FORM" W:'SIDE ?102,"(Filled at ",$P(PS2,"^",2),")"
     6 W !,$P(PS,"^",7),", ",STATE,"  ",$P(PS,"^",5) W:'SIDE ?83,"*** ",$P(PS2,"^")," ***"
     7 W !,?22,$S(MW["C":"CERTIFIED MAIL",1:"") W:'SIDE ?38,SSNP,?69,"RX: ",RXN
     8 W !,?2,PNM W:'SIDE ?38,PNM,?64,"EXPIRES: ",EXDT W:('SIDE)&(PRTFL) ?83,"INDICATE ANY ADDRESS CHANGES"
     9 W !,?2,$S($D(PSMP(1)):PSMP(1),1:VAPA(1)) W:'SIDE ?38,$E(VAPA(1),1,25),?64,"REFILLS: ",REF ;W:('SIDE)&(PRTFL) ?83,LINE
     10 W:('SIDE)&(PRTFL) ?83,"_____PERM.   _____TEMP." W:'PRTFL ?83,"* A 'NEW' RX IS REQUIRED.        *"
     11 S ADDR(3)=VAPA(4)_", "_$P($G(^DIC(5,+$P(VAPA(5),"^"),0)),"^",2)_"  "_VAPA(6),ADDR(2)="" S:VAPA(2)]"" ADDR(2)=VAPA(2)_" "_VAPA(3)
     12 I ADDR(2)="" S ADDR(2)=ADDR(3),ADDR(3)=""
     13 S ADDR(5)=$E(VAPA(4),1,13)_", "_$P($G(^DIC(5,+$P(VAPA(5),"^"),0)),"^",2)_"  "_VAPA(6)
     14 W !,?2,$S($D(PSMP(2)):PSMP(2),$D(PSMP(1)):"",1:$E(ADDR(2),1,35)) W:'SIDE ?38,$S($G(ADDR(3))="":ADDR(5),1:$E(ADDR(2),1,24)),?62,$S(RFLMSG]"":"*",1:" "),"LST FILL: "
     15 W:'SIDE $G(PSOLASTF)
     16 I 'SIDE W:PRTFL ?83,"ADDRESS: ",$E(LINE,1,23) W:'PRTFL ?83,"********** PLEASE NOTE ***********"
     17 W !,?2,$S($D(PSMP(3)):PSMP(3),$D(PSMP(1)):"",1:ADDR(3)) I 'SIDE W ?38,$S(ADDR(3)'="":ADDR(5),1:""),?64,"ROUTING: ",$S(MW="REGULAR":"MAIL",1:MW) W:PRTFL ?83,"CITY/STATE/ZIP: ",$E(LINE,1,16) W:'PRTFL ?83,"* THIS RX CAN NOT BE 'RENEWED'.  *"
     18 ;NEW LABEL WHITE SPACE
     19 I +$G(PSOBARS),'SIDE,$P(PSOPAR,"^",19)'=1 S X="S",X2=PSOINST_"-"_RX W !,?40 S X1=$X W @PSOBAR1,X2,@PSOBAR0,$C(13),!,$S($G(PS55)=2:"***DO NOT MAIL***",1:"**CRITICAL MEDICAL SHIPMENT**"),!
     20 E  F NLWS=1:1:6 W ! W:NLWS=5 $S($G(PS55)=2:"***DO NOT MAIL***",1:"**CRITICAL MEDICAL SHIPMENT**")
     21 W !,?8,"VA Medical Center" I 'SIDE W ?38,INT(1)
     22 W !,$P(PS,"^"),"  ",$P(PS,"^",3),"-",$P(PS,"^",4) W:'SIDE ?38,INT(2) I 'SIDE W:PRTFL ?83 W:'PRTFL ?83,"* PLEASE CONTACT YOUR PHYSICIAN. *"
     23 W !,?4,RXN,?15,$E(DATE,4,5),"/",$E(DATE,6,7),"/",$E(DATE,2,3),"   (",RXF+1," OF ",1+$P(RXY,"^",9),")" I 'SIDE W ?38,INT(3) W:(PRTFL)&('REF) ?83,"***** FOR PHYSICIAN USE ONLY *****" W:'PRTFL ?83,"**********************************"
     24 W !,PNM,?29,"#",$P(RXY,"^",7)
     25 W:'SIDE ?38,"CAP: ",$S(PSCAP:"**NON-SFTY**",1:"SAFETY")," WARN:",WARN,?68,$E(DATE,4,5),"/",$E(DATE,6,7),"/",$E(DATE,2,3)," " S I1=$P($H,",",2)\60 W:'SIDE I1\60,":",(I1#60\10)_(I1#10) W:('SIDE)&(PRTFL) ?83,"SIGNATURE : ",$E(LINE,1,20)
     26SIG F DR=1:1:$S(SGC<5:4,1:6) D SIG1
     27 I SGC>4 F I=1:1:22 W ! I I>22-SGC S DR=DR+1,X=$S($D(SGY(DR)):SGY(DR),1:"") W X W:'SIDE ?38,X
     28 ;I SGC>4 F I=1:1:$S($P($G(PSOPAR),"^",10):22,1:16) W ! I I>($S($P($G(PSOPAR),"^",10):28,1:22)-SGC) S DR=DR+1,X=$S($D(SGY(DR)):SGY(DR),1:"") W X W:'SIDE ?38,X
     29 W !?3,$E(PHYS,1,14),?25,"(",$P(RXY,"^",16),"/",$S($D(VRPH):VRPH,1:" "),")" W:'SIDE ?38,DRUG,?38+$L(DRUG)," (QTY:",$P(RXY,"^",7)," DAYS:",$P(RXY,"^",8)," FILL: ",RXF+1," OF ",1+$P(RXY,"^",9)," ISD:",ISD,")"
     30 W !,DRUG W:'SIDE ?38,PHYS,?62,RFLMSG,?100,PATST,"  ",PSCLN
     31 I $D(PSOBARS),PSOBARS W $C(13),# S $X=0
     32 E  W !
     33 I COPIES>0 S SIDE=1 G START
     34 ;STORE LABEL PRINT NODE
     35 D NOW^%DTC S NOW=% K %,%H,%I S RXF=0 F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I  S RXF=I
     36 S IR=0 F FDA=0:0 S FDA=$O(^PSRX(RX,"L",FDA)) Q:'FDA  S IR=FDA
     37 S IR=IR+1,^PSRX(RX,"L",0)="^52.032DA^"_IR_"^"_IR
     38 S ^PSRX(RX,"L",IR,0)=NOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_$S($G(PCOMX)]"":$G(PCOMX),1:"From RX number "_$P(^PSRX(RX,0),"^"))_$S($G(RXP):" (Partial)",1:"")_$S($D(REPRINT):" (Reprint)",1:"")_"^"_PDUZ
     39 S ^PSRX(RX,"TYPE")=0 K RXF,IR,FDA,NOW,I
     40 I '$D(PSSPND),$P(PSOPAR,"^",18) D CHCK2^PSOTRLBL
     41END K PSCLN,%DT,ADDR,DATE,DEA,DR,DR1,DRX,DRUG,FDT,SGY,RXY,RXZ,RYY,RFLMSG,RFL,%H,COPIES,DOB,DRUG,LIM,LMI,LINE,PS,PS1,PS2,INT,ISD,I1,MW,MAIL,STATE,SIDE,SSNP,SS,ST,ST1,PATST,PRTFL,PHYS,PNM,S,SL,SGC,PSMP,PSI,PSJ,VRPH,REPRINT,PS55,PS55X Q
     42 Q
     43 ;
     44SIG1 S X=$S($D(SGY(DR)):SGY(DR),1:"") W !,X
     45 I 'SIDE W ?38,X I PRTFL W ?83 W:DR=1 ?83,$S('REF:"PRINT NAME: "_$E(LINE,1,25),1:"") W:DR=2 "DATE: ",$E(LINE,1,10) W:(DR=2)&('REF) " DEA# ",$E(LINE,1,6) W:(DR=3)&('REF) "Refills: 0 1 2 3 4 5 6 7 8 9 10 11"

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL4.m

    r613 r623  
    1 PSOLBL4 ;BIR/RTR-Set up routine for HL7 interface ;12/19/06 10:45am
    2         ;;7.0;OUTPATIENT PHARMACY;**26,70,156,244,233,246**;DEC 1997;Build 12
    3         ;External reference to ^PSDRUG supported by DBIA 221
    4         ;
    5         ;*244 - ignore RX's with a status > 11
    6         ;*246 - send marked drugs & print label (option 4) now working
    7         ;
    8         N DIC,AP,X,Y,DPRT,QPRT
    9         I $G(ZTIO)]"" D
    10         .Q:'$O(^PS(59,PSOSITE,"P",0))
    11         .S DIC=3.5,DIC(0)="",X=ZTIO D ^DIC K DIC,X Q:Y=-1
    12         .S DPRT=+Y
    13         .F AP=0:0 S AP=$O(^PS(59,PSOSITE,"P",AP)) Q:'AP  I +$P(^PS(59,PSOSITE,"P",AP,0),"^")=DPRT S QPRT=1
    14         .I '$G(QPRT) S $P(PSOPAR,"^",30)=0
    15         Q:'$P($G(PSOPAR),"^",30)                ;HL7 interface turned off
    16         Q:$G(PSOEXREP)
    17 HL      N PSODTM,HHHH,PSOQUE,HLFLAG,HLFOUR,HLINGF,HLINRX,HLINRX0,II,HLNEXT,HLRR,HLRX,HLRXY,LL,PPLHL,PSHALP,HDFN,HLDFN,HNEWDFN,HLDAI,HLOSITE,HLJUST,HLRXYZ,PSOLLN,PSOLLL,PSFLG,HDFN1,NOTMD
    18         S HLOSITE=$P($G(PSOPAR),"^",30)
    19         K ^UTILITY($J,"PSOHL"),^UTILITY($J,"PSOHLL"),HLRXY
    20         S PPLHL=PPL
    21         S HLFLAG=0 F II=1:1 S HLRX=$P(PPLHL,",",II) D  Q:$G(HLFLAG)
    22         .S HLNEXT=$P(PPLHL,",",(II+1)) I HLNEXT=""!(HLNEXT=",") S HLFLAG=1
    23         .Q:'$G(HLRX)
    24         .Q:'$D(^PSRX(HLRX,0))
    25         .Q:$P($G(^PSRX(HLRX,"STA")),"^")=4
    26         .Q:$G(RXRP(HLRX,"RP"))
    27         .I $P($G(^PSRX(HLRX,"STA")),"^")>11!('$P(^PSRX(HLRX,0),"^",2)) Q
    28         .I $G(PSODBQ) S HLRR=$O(^PS(52.5,"B",HLRX,0)) Q:'HLRR  I $G(^PS(52.5,+HLRR,"P"))=1 Q
    29         .;   marked drug options 3 & 4
    30         .I (HLOSITE=3)!(HLOSITE=4) S NOTMD=0 D  Q:NOTMD     ;quit, not marked
    31         ..S HLJUST=+$P($G(^PSRX(HLRX,0)),"^",6)
    32         ..S:'$P($G(^PSDRUG(HLJUST,6)),"^") NOTMD=1
    33         .S HLRXY(II,HLRX)=""                                ;Valid Rx for HL7
    34         .S:HLOSITE=3 HLRXYZ(HLRX)=""
    35         ;
    36         I $G(HLOSITE)=3,$D(HLRXY) D                 ;rebuild PPL print string
    37         .K PPL F II=1:1 S HLRX=$P(PPLHL,",",II) Q:'HLRX  D
    38         ..Q:$D(HLRXYZ(HLRX))
    39         ..S PPL=$G(PPL)_HLRX_","
    40         ;
    41 SOMDQ   S (II,PSOQUE)=0 F  S II=$O(HLRXY(II)) Q:'II  S ^UTILITY($J,"PSOHLL",II)=$O(HLRXY(II,0)),PSOQUE=II
    42         I PSOQUE=0 G ENDHL                ;Nothing set, bypass Call to Queue
    43         F II=0:0 S II=$O(^UTILITY($J,"PSOHLL",II)) Q:'II  S HLINRX=^(II),HLINRX0=$G(^PSRX(HLINRX,0)) D
    44         .S ^UTILITY($J,"PSOHLL",II)=HLINRX_"^"_+$P(HLINRX0,"^",6)_"^"_$S($G(RXPR(HLINRX)):"P",1:"F")
    45         .I '$G(RXPR(HLINRX)) S HLFOUR=0 F HHHH=0:0 S HHHH=$O(^PSRX(HLINRX,1,HHHH)) Q:'HHHH  I +^(HHHH,0) S HLFOUR=HHHH
    46         .I '$G(RXPR(HLINRX)),$G(RXFL(HLINRX))'="" S HLFOUR=$S($G(RXFL(HLINRX))=0:0,$D(^PSRX(HLINRX,1,+$G(RXFL(HLINRX)),0)):+$G(RXFL(HLINRX)),1:$G(HLFOUR))
    47         .S ^UTILITY($J,"PSOHLL",II)=^UTILITY($J,"PSOHLL",II)_"^"_$S($G(RXPR(HLINRX)):RXPR(HLINRX),1:HLFOUR)_"^"_$S($P($G(^PSRX(HLINRX,3)),"^",6)&('$G(RXPR(HLINRX)))&('$G(RXFL(HLINRX))):1,1:0) D ACLOG
    48         .S HLINGF=0 I $P(^UTILITY($J,"PSOHLL",II),"^",5),$O(^PSRX(HLINRX,"DAI",0)) S HLINGF=1 D
    49         ..F LL=0:0 S LL=$O(^PSRX(HLINRX,"DAI",LL)) Q:'LL  S ^UTILITY($J,"PSOHLL",II,HLINGF)=$G(^PSRX(HLINRX,"DAI",LL,0)),HLINGF=HLINGF+1
    50         .S $P(^UTILITY($J,"PSOHLL",II),"^",6)=$S($G(HLINGF):1,1:0)
    51         .I $D(^PSRX(HLINRX,"DRI")),'$G(RXPR(HLINRX)),'$G(RXFL(HLINRX)) S ^UTILITY($J,"PSOHLL",II,"DRI")=^PSRX(HLINRX,"DRI"),$P(^UTILITY($J,"PSOHLL",II),"^",7)=1
    52         .E  S $P(^UTILITY($J,"PSOHLL",II),"^",7)=0
    53         .S $P(^UTILITY($J,"PSOHLL",II),"^",8)=0 D RPT Q:'$G(^PSRX(HLINRX,"IB"))
    54         .I $P(^PSRX(HLINRX,"STA"),"^")>0,$P(^("STA"),"^")'=2,'$G(PSODBQ) Q
    55         .S $P(^UTILITY($J,"PSOHLL",II),"^",8)=1
    56         ;
    57 AAA     D STRT^PSOHLSG5
    58         S (HDFN,HDFN1)=$O(^UTILITY($J,"PSOHLL",0)),HDFN=$P(^PSRX($P(^(HDFN),"^"),0),"^",2),PSOLLL=$P(^UTILITY($J,"PSOHLL",HDFN1),"^",12)
    59         F HLDFN=0:0 S HLDFN=$O(^UTILITY($J,"PSOHLL",HLDFN)) Q:'HLDFN  D  S ^UTILITY($J,"PSOHL",HLDFN)=^UTILITY($J,"PSOHLL",HLDFN) D OTHER
    60         .S PSFLG=0,PSOLLN=$P(^UTILITY($J,"PSOHLL",HLDFN),"^",12),HNEWDFN=$P(^PSRX($P(^UTILITY($J,"PSOHLL",HLDFN),"^"),0),"^",2) D
    61         ..I HDFN'=HNEWDFN S HDFN=HNEWDFN,PSFLG=1
    62         ..I PSOLLL'=PSOLLN S PSOLLL=PSOLLN,PSFLG=1
    63         ..I PSFLG=1 D SETZ
    64         I '$D(^UTILITY($J,"PSOHL")) G ENDHL
    65 CALL    D SETZ
    66 ENDHL   K ^UTILITY($J,"PSOHL"),^UTILITY($J,"PSOHLL"),HLRXY
    67         Q
    68 OTHER   I $G(^UTILITY($J,"PSOHLL",HLDFN,"DRI"))'="" S ^UTILITY($J,"PSOHL",HLDFN,"DRI")=^UTILITY($J,"PSOHLL",HLDFN,"DRI")
    69         F HLDAI=0:0 S HLDAI=$O(^UTILITY($J,"PSOHLL",HLDFN,HLDAI)) Q:'HLDAI  S ^UTILITY($J,"PSOHL",HLDFN,HLDAI)=^UTILITY($J,"PSOHLL",HLDFN,HLDAI)
    70         Q
    71 ACLOG   ;Activity log (sending to Hl7 interface)
    72         N DTTM,HCOM,HCNT,HJJ
    73         D NOW^%DTC S DTTM=%,HCOM="Prescription"_$S($G(RXPR(HLINRX)):" (Partial)",1:"")_$S($G(PSOSUREP)!($G(RXRP(HLINRX))):" (Reprint)",1:"")_" sent to external interface."
    74         S HCNT=0 F HJJ=0:0 S HJJ=$O(^PSRX(HLINRX,"A",HJJ)) Q:'HJJ  S HCNT=HJJ
    75         S HCNT=HCNT+1,^PSRX(HLINRX,"A",0)="^52.3DA^"_HCNT_"^"_HCNT S ^PSRX(HLINRX,"A",HCNT,0)=DTTM_"^X^"_$G(PDUZ)_"^"_$S($G(RXPR(HLINRX)):6,$G(HLFOUR)<6:$G(HLFOUR),1:(HLFOUR+1))_"^"_HCOM
    76         Q
    77 SUS(HSREX,HSFL,HSFILL,HSRP)     ;
    78         N DA,DIK,DTTM,HSCOM,HSCNT,HSJJ,HSLDUZ,PSHLCPRS
    79         I $P($G(^PSRX(HSREX,"STA")),"^")=5 S $P(^PSRX(HSREX,"STA"),"^")=0 S PSHLCPRS="Removed from Suspense, External Interface." D EN^PSOHLSN1(HSREX,"SC","ZU",PSHLCPRS)
    80         S DA=$O(^PS(52.5,"B",HSREX,0)) I DA K DIK S DIK="^PS(52.5," D ^DIK
    81         I $G(HSFL)="P" S HSLDUZ=+$P($G(^PSRX(HSREX,"P",HSFILL,0)),"^",7)
    82         E  S HSLDUZ=$S('HSFILL:+$P($G(^PSRX(HSREX,0)),"^",16),1:+$P($G(^PSRX(HSREX,1,HSFILL,0)),"^",7))
    83         D NOW^%DTC S DTTM=%,HSCOM="Removed from Suspense"_$S($G(HSFL)="P":" (Partial)",1:"")_$S($G(HSRP):" (Reprint)",1:"")_" (External Interface)"
    84         S HSCNT=0 F HSJJ=0:0 S HSJJ=$O(^PSRX(HSREX,"A",HSJJ)) Q:'HSJJ  S HSCNT=HSJJ
    85         S HSCNT=HSCNT+1,^PSRX(HSREX,"A",0)="^52.3DA^"_HSCNT_"^"_HSCNT S ^PSRX(HSREX,"A",HSCNT,0)=DTTM_"^X^"_$G(HSLDUZ)_"^"_$S($G(HSFL)="P":6,$G(HSFILL)<6:$G(HSFILL),1:(HSFILL+1))_"^"_$G(HSCOM)
    86         Q
    87 LAB(HLREX,HLFL,HLFILL,HLREPT)   ;
    88         N HLDUZ,NOW,DA,HCT,HFF
    89         D NOW^%DTC S NOW=% S HCT=0 F HFF=0:0 S HFF=$O(^PSRX(HLREX,"L",HFF)) Q:'HFF  S HCT=HFF
    90         I HLFL="F" S HLDUZ=$S('HLFILL:+$P($G(^PSRX(HLREX,0)),"^",16),1:+$P($G(^PSRX(HLREX,1,HLFILL,0)),"^",7))
    91         I HLFL="P" S HLDUZ=+$P($G(^PSRX(HLREX,"P",HLFILL,0)),"^",7)
    92         S HCT=HCT+1,^PSRX(HLREX,"L",0)="^52.032DA^"_HCT_"^"_HCT
    93         S ^PSRX(HLREX,"L",HCT,0)=NOW_"^"_$S($G(HLFL)="F":HLFILL,1:(99-HLFILL))_"^"_"From Rx number "_$P(^PSRX(HLREX,0),"^")_$S($G(HLFL)="P":" (Partial)",1:"")_$S($G(HLREPT):" (Reprint)",1:"")_" (External Interface)"_"^"_$G(HLDUZ)
    94         N PSOBADR,PSOTEMP
    95         S PSOBADR=$$CHKRX^PSOBAI(HLREX)
    96         I $G(PSOBADR) S PSOTEMP=$P(PSOBADR,"^",2),PSOBADR=$P(PSOBADR,"^")
    97         I $G(PSOBADR),'$G(PSOTEMP) D
    98         .S HCT=HCT+1,^PSRX(HLREX,"L",0)="^52.032DA^"_HCT_"^"_HCT
    99         .S ^PSRX(HLREX,"L",HCT,0)=NOW_"^"_$S($G(HLFL)="F":HLFILL,1:(99-HLFILL))_"^"_"ROUTING="_$G(MW)_" (BAD ADDRESS)"_"^"_$G(HLDUZ)
    100         Q
    101 RPT     ;
    102         S $P(^UTILITY($J,"PSOHLL",II),"^",9)=$S($G(PSOSUREP)!($G(RXRP(HLINRX))):1,1:0)
    103         S $P(^UTILITY($J,"PSOHLL",II),"^",10)=+$G(PDUZ)
    104         Q
    105 SETZ    ;
    106         D NOW^%DTC S PSODTM=%
    107         S ZTRTN=$S($$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4:"INIT^PSOHLDS",1:"INIT^PSOHLSG")
    108         S ZTIO="",ZTDTH=$H,ZTSAVE("^UTILITY($J,""PSOHL"",")="",ZTSAVE("PSOPAR")="",ZTSAVE("PSOSITE")="",ZTSAVE("PSODTM")="",ZTSAVE("PSOLAP")=""
    109         S ZTSAVE("RXRP(")="",ZTSAVE("RXPR(")="",ZTSAVE("RXFL(")="",ZTSAVE("RXRS(")=""
    110         S ZTDESC=$S($$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4:"Outpatient Automation External Interface",1:"GENERIC INTERFACE LABEL INFORMATION")
    111         D ^%ZTLOAD
    112         Q
     1PSOLBL4 ;BIR/RTR-Set up routine for HL7 interface ;10/20/96
     2 ;;7.0;OUTPATIENT PHARMACY;**26,70,156,244,233**;DEC 1997;Build 8
     3 ;External reference to ^PSDRUG supported by DBIA 221
     4 ;
     5 ;*244 - ignore RX's with a status > 11
     6 ;
     7 N DIC,AP,X,Y,DPRT,QPRT
     8 I $G(ZTIO)]"" D
     9 .Q:'$O(^PS(59,PSOSITE,"P",0))
     10 .S DIC=3.5,DIC(0)="",X=ZTIO D ^DIC K DIC,X Q:Y=-1
     11 .S DPRT=+Y
     12 .F AP=0:0 S AP=$O(^PS(59,PSOSITE,"P",AP)) Q:'AP  I +$P(^PS(59,PSOSITE,"P",AP,0),"^")=DPRT S QPRT=1
     13 .I '$G(QPRT) S $P(PSOPAR,"^",30)=0
     14 Q:'$P($G(PSOPAR),"^",30)
     15 Q:$G(PSOEXREP)
     16HL N PSODTM,HHHH,HLCOT,HLFLAG,HLFOUR,HLINGF,HLINRX,HLINRX0,HLLOOP,HLNEXT,HLRR,HLRX,HLRXY,LL,PPLHL,PSHALP,HDFN,HLDFN,HNEWDFN,HLDAI,HLOSITE,HLJUST,HLRXYZ,PSOLLN,PSOLLL,PSFLG,HDFN1
     17 S HLOSITE=$P($G(PSOPAR),"^",30)
     18 K ^UTILITY($J,"PSOHL"),^UTILITY($J,"PSOHLL"),HLRXY
     19 S PPLHL=PPL G:HLOSITE=4 SOMD
     20 S HLFLAG=0 F HLLOOP=1:1 S HLRX=$P(PPLHL,",",HLLOOP) D  Q:$G(HLFLAG)
     21 .S HLNEXT=$P(PPLHL,",",(HLLOOP+1)) I HLNEXT=""!(HLNEXT=",") S HLFLAG=1
     22 .Q:'$G(HLRX)
     23 .Q:'$D(^PSRX(HLRX,0))
     24 .Q:$P($G(^PSRX(HLRX,"STA")),"^")=4
     25 .Q:$G(RXRP(HLRX,"RP"))
     26 .I $P($G(^PSRX(HLRX,"STA")),"^")>11!('$P(^PSRX(HLRX,0),"^",2)) Q
     27 .I $G(PSODBQ) S HLRR=$O(^PS(52.5,"B",HLRX,0)) Q:'HLRR  I $G(^PS(52.5,+HLRR,"P"))=1 Q
     28 .;Here, if Site Parameter is 3, check entry in Drug File for National Id
     29 .I $G(HLOSITE)=3 S HLJUST=+$P($G(^PSRX(HLRX,0)),"^",6) I '$P($G(^PSDRUG(HLJUST,6)),"^") Q
     30 .S HLRXY(HLLOOP,HLRX)="" ; VALID RXS
     31 .S:$G(HLOSITE)=3 HLRXYZ(HLRX)=""
     32 I $G(HLOSITE)=3,$D(HLRXY) D
     33 .N HLZFLAG,HLZ,HLZRX,HLZNEXT
     34 .S HLZFLAG=0 K PPL F HLZ=1:1 S HLZRX=$P(PPLHL,",",HLZ) D  Q:$G(HLZFLAG)
     35 ..S HLZNEXT=$P(PPLHL,",",(HLZ+1)) I HLZNEXT=""!(HLZNEXT=",") S HLZFLAG=1
     36 ..Q:'$G(HLZRX)
     37 ..Q:$D(HLRXYZ(HLZRX))
     38 ..I $G(RXRP(HLZRX,"RP")) D  Q
     39 ...I $G(PPL)="" S PPL=HLZRX_"," Q
     40 ...S PPL=PPL_HLZRX_","
     41 ..I $G(PPL)="" S PPL=HLZRX_"," Q
     42 ..S PPL=PPL_HLZRX_","
     43SOMDQ S HLCOT=1,PSHALP="" F  S PSHALP=$O(HLRXY(PSHALP)) Q:PSHALP=""  S ^UTILITY($J,"PSOHLL",HLCOT)=$O(HLRXY(PSHALP,0)),HLCOT=HLCOT+1
     44 I HLCOT=1 G ENDHL ; NOTHING SET, BYPASS CALL TO QUEUE
     45 F HLCOT=0:0 S HLCOT=$O(^UTILITY($J,"PSOHLL",HLCOT)) Q:'HLCOT  S HLINRX=^(HLCOT),HLINRX0=$G(^PSRX(HLINRX,0)) D
     46 .S ^UTILITY($J,"PSOHLL",HLCOT)=HLINRX_"^"_+$P(HLINRX0,"^",6)_"^"_$S($G(RXPR(HLINRX)):"P",1:"F")
     47 .I '$G(RXPR(HLINRX)) S HLFOUR=0 F HHHH=0:0 S HHHH=$O(^PSRX(HLINRX,1,HHHH)) Q:'HHHH  I +^(HHHH,0) S HLFOUR=HHHH
     48 .I '$G(RXPR(HLINRX)),$G(RXFL(HLINRX))'="" S HLFOUR=$S($G(RXFL(HLINRX))=0:0,$D(^PSRX(HLINRX,1,+$G(RXFL(HLINRX)),0)):+$G(RXFL(HLINRX)),1:$G(HLFOUR))
     49 .S ^UTILITY($J,"PSOHLL",HLCOT)=^UTILITY($J,"PSOHLL",HLCOT)_"^"_$S($G(RXPR(HLINRX)):RXPR(HLINRX),1:HLFOUR)_"^"_$S($P($G(^PSRX(HLINRX,3)),"^",6)&('$G(RXPR(HLINRX)))&('$G(RXFL(HLINRX))):1,1:0) D ACLOG
     50 .S HLINGF=0 I $P(^UTILITY($J,"PSOHLL",HLCOT),"^",5),$O(^PSRX(HLINRX,"DAI",0)) S HLINGF=1 D
     51 ..F LL=0:0 S LL=$O(^PSRX(HLINRX,"DAI",LL)) Q:'LL  S ^UTILITY($J,"PSOHLL",HLCOT,HLINGF)=$G(^PSRX(HLINRX,"DAI",LL,0)),HLINGF=HLINGF+1
     52 .S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",6)=$S($G(HLINGF):1,1:0)
     53 .I $D(^PSRX(HLINRX,"DRI")),'$G(RXPR(HLINRX)),'$G(RXFL(HLINRX)) S ^UTILITY($J,"PSOHLL",HLCOT,"DRI")=^PSRX(HLINRX,"DRI"),$P(^UTILITY($J,"PSOHLL",HLCOT),"^",7)=1
     54 .E  S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",7)=0
     55 .S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",8)=0 D RPT Q:'$G(^PSRX(HLINRX,"IB"))
     56 .I $P(^PSRX(HLINRX,"STA"),"^")>0,$P(^("STA"),"^")'=2,'$G(PSODBQ) Q
     57 .S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",8)=1
     58 ;
     59AAA D STRT^PSOHLSG5
     60 S (HDFN,HDFN1)=$O(^UTILITY($J,"PSOHLL",0)),HDFN=$P(^PSRX($P(^(HDFN),"^"),0),"^",2),PSOLLL=$P(^UTILITY($J,"PSOHLL",HDFN1),"^",12)
     61 F HLDFN=0:0 S HLDFN=$O(^UTILITY($J,"PSOHLL",HLDFN)) Q:'HLDFN  D  S ^UTILITY($J,"PSOHL",HLDFN)=^UTILITY($J,"PSOHLL",HLDFN) D OTHER
     62 .S PSFLG=0,PSOLLN=$P(^UTILITY($J,"PSOHLL",HLDFN),"^",12),HNEWDFN=$P(^PSRX($P(^UTILITY($J,"PSOHLL",HLDFN),"^"),0),"^",2) D
     63 ..I HDFN'=HNEWDFN S HDFN=HNEWDFN,PSFLG=1
     64 ..I PSOLLL'=PSOLLN S PSOLLL=PSOLLN,PSFLG=1
     65 ..I PSFLG=1 D SETZ
     66 I '$D(^UTILITY($J,"PSOHL")) G ENDHL
     67CALL D SETZ
     68ENDHL K ^UTILITY($J,"PSOHL"),^UTILITY($J,"PSOHLL"),HLRXY
     69 Q
     70OTHER I $G(^UTILITY($J,"PSOHLL",HLDFN,"DRI"))'="" S ^UTILITY($J,"PSOHL",HLDFN,"DRI")=^UTILITY($J,"PSOHLL",HLDFN,"DRI")
     71 F HLDAI=0:0 S HLDAI=$O(^UTILITY($J,"PSOHLL",HLDFN,HLDAI)) Q:'HLDAI  S ^UTILITY($J,"PSOHL",HLDFN,HLDAI)=^UTILITY($J,"PSOHLL",HLDFN,HLDAI)
     72 Q
     73ACLOG ;Activity log (sending to Hl7 interface)
     74 N DTTM,HCOM,HCNT,HJJ
     75 D NOW^%DTC S DTTM=%,HCOM="Prescription"_$S($G(RXPR(HLINRX)):" (Partial)",1:"")_$S($G(PSOSUREP)!($G(RXRP(HLINRX))):" (Reprint)",1:"")_" sent to external interface."
     76 S HCNT=0 F HJJ=0:0 S HJJ=$O(^PSRX(HLINRX,"A",HJJ)) Q:'HJJ  S HCNT=HJJ
     77 S HCNT=HCNT+1,^PSRX(HLINRX,"A",0)="^52.3DA^"_HCNT_"^"_HCNT S ^PSRX(HLINRX,"A",HCNT,0)=DTTM_"^X^"_$G(PDUZ)_"^"_$S($G(RXPR(HLINRX)):6,$G(HLFOUR)<6:$G(HLFOUR),1:(HLFOUR+1))_"^"_HCOM
     78 Q
     79SUS(HSREX,HSFL,HSFILL,HSRP) ;
     80 N DA,DIK,DTTM,HSCOM,HSCNT,HSJJ,HSLDUZ,PSHLCPRS
     81 I $P($G(^PSRX(HSREX,"STA")),"^")=5 S $P(^PSRX(HSREX,"STA"),"^")=0 S PSHLCPRS="Removed from Suspense, External Interface." D EN^PSOHLSN1(HSREX,"SC","ZU",PSHLCPRS)
     82 S DA=$O(^PS(52.5,"B",HSREX,0)) I DA K DIK S DIK="^PS(52.5," D ^DIK
     83 I $G(HSFL)="P" S HSLDUZ=+$P($G(^PSRX(HSREX,"P",HSFILL,0)),"^",7)
     84 E  S HSLDUZ=$S('HSFILL:+$P($G(^PSRX(HSREX,0)),"^",16),1:+$P($G(^PSRX(HSREX,1,HSFILL,0)),"^",7))
     85 D NOW^%DTC S DTTM=%,HSCOM="Removed from Suspense"_$S($G(HSFL)="P":" (Partial)",1:"")_$S($G(HSRP):" (Reprint)",1:"")_" (External Interface)"
     86 S HSCNT=0 F HSJJ=0:0 S HSJJ=$O(^PSRX(HSREX,"A",HSJJ)) Q:'HSJJ  S HSCNT=HSJJ
     87 S HSCNT=HSCNT+1,^PSRX(HSREX,"A",0)="^52.3DA^"_HSCNT_"^"_HSCNT S ^PSRX(HSREX,"A",HSCNT,0)=DTTM_"^X^"_$G(HSLDUZ)_"^"_$S($G(HSFL)="P":6,$G(HSFILL)<6:$G(HSFILL),1:(HSFILL+1))_"^"_$G(HSCOM)
     88 Q
     89LAB(HLREX,HLFL,HLFILL,HLREPT) ;
     90 N HLDUZ,NOW,DA,HCT,HFF
     91 D NOW^%DTC S NOW=% S HCT=0 F HFF=0:0 S HFF=$O(^PSRX(HLREX,"L",HFF)) Q:'HFF  S HCT=HFF
     92 I HLFL="F" S HLDUZ=$S('HLFILL:+$P($G(^PSRX(HLREX,0)),"^",16),1:+$P($G(^PSRX(HLREX,1,HLFILL,0)),"^",7))
     93 I HLFL="P" S HLDUZ=+$P($G(^PSRX(HLREX,"P",HLFILL,0)),"^",7)
     94 S HCT=HCT+1,^PSRX(HLREX,"L",0)="^52.032DA^"_HCT_"^"_HCT
     95 S ^PSRX(HLREX,"L",HCT,0)=NOW_"^"_$S($G(HLFL)="F":HLFILL,1:(99-HLFILL))_"^"_"From Rx number "_$P(^PSRX(HLREX,0),"^")_$S($G(HLFL)="P":" (Partial)",1:"")_$S($G(HLREPT):" (Reprint)",1:"")_" (External Interface)"_"^"_$G(HLDUZ)
     96 N PSOBADR,PSOTEMP
     97 S PSOBADR=$$CHKRX^PSOBAI(HLREX)
     98 I $G(PSOBADR) S PSOTEMP=$P(PSOBADR,"^",2),PSOBADR=$P(PSOBADR,"^")
     99 I $G(PSOBADR),'$G(PSOTEMP) D
     100 .S HCT=HCT+1,^PSRX(HLREX,"L",0)="^52.032DA^"_HCT_"^"_HCT
     101 .S ^PSRX(HLREX,"L",HCT,0)=NOW_"^"_$S($G(HLFL)="F":HLFILL,1:(99-HLFILL))_"^"_"ROUTING="_$G(MW)_" (BAD ADDRESS)"_"^"_$G(HLDUZ)
     102 Q
     103RPT ;
     104 S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",9)=$S($G(PSOSUREP)!($G(RXRP(HLINRX))):1,1:0)
     105 S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",10)=+$G(PDUZ)
     106 Q
     107SETZ ;
     108 D NOW^%DTC S PSODTM=%
     109 S ZTRTN=$S($$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4:"INIT^PSOHLDS",1:"INIT^PSOHLSG")
     110 S ZTIO="",ZTDTH=$H,ZTSAVE("^UTILITY($J,""PSOHL"",")="",ZTSAVE("PSOPAR")="",ZTSAVE("PSOSITE")="",ZTSAVE("PSODTM")="",ZTSAVE("PSOLAP")=""
     111 S ZTSAVE("RXRP(")="",ZTSAVE("RXPR(")="",ZTSAVE("RXFL(")="",ZTSAVE("RXRS(")=""
     112 S ZTDESC=$S($$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4:"Outpatient Automation External Interface",1:"GENERIC INTERFACE LABEL INFORMATION")
     113 D ^%ZTLOAD
     114 Q
     115SOMD ;send only mark drugs to external interface and print in vista
     116 S HLFLG=0 F HLLP=1:1 S HLRX=$P(PPLHL,",",HLLP) D  Q:$G(HLFLG)
     117 .S HLNEXT=$P(PPLHL,",",(HLLP+1)) I HLNEXT=""!(HLNEXT=",") S HLFLG=1
     118 .Q:'$G(HLRX)
     119 .Q:'$D(^PSRX(HLRX,0))
     120 .Q:$P($G(^PSRX(HLRX,"STA")),"^")=4
     121 .I $P($G(^PSRX(HLRX,"STA")),"^")>11!('$P(^PSRX(HLRX,0),"^",2)) Q
     122 .Q:$G(RXRP(HLRX,"RP"))
     123 .S HLRR=$O(^PS(52.5,"B",HLRX,0)) Q:'HLRR  I $G(^PS(52.5,+HLRR,"P"))=1 K HLRR Q
     124 .S DRG=+$P($G(^PSRX(HLRX,0)),"^",6) I '$P($G(^PSDRUG(DRG,6)),"^") Q
     125 .S HLRXY(HLRX)="" ; VALID RXS
     126 I $D(HLRXY) G SOMDQ
     127 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLN.m

    r613 r623  
    1 PSOLBLN ;BIR/RTR-NEW PRINTS LABEL ; 3/11/07 1:56pm
    2         ;;7.0;OUTPATIENT PHARMACY;**16,36,71,107,110,117,135,233,208**;DEC 1997;Build 41
    3         ; Modified from FOIA VistA
    4         ; Copyright (C) 2007 WorldVistA
    5         ;
    6         ; This program is free software; you can redistribute it and/or modify
    7         ; it under the terms of the GNU General Public License as published by
    8         ; the Free Software Foundation; either version 2 of the License, or
    9         ; (at your option) any later version.
    10         ;
    11         ; This program is distributed in the hope that it will be useful,
    12         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ; GNU General Public License for more details.
    15         ;
    16         ; You should have received a copy of the GNU General Public License
    17         ; along with this program; if not, write to the Free Software
    18         ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    19         ;External reference to ^PSDRUG supported by DBIA 221
    20         ;External reference to ^VA(200 supported by DBIA 224
    21         K PSOSTLK,ZTKDRUG I $L($T(PSOSTALK^PSOTALK1)) D PSOSTALK^PSOTALK1 S PSOSTLK=1 ; PRINT SCRIPTALK LABEL IF APPLICABLE
    22         I $G(IOS),$G(PSOBARS) I $G(PSOBAR0)=""!($G(PSOBAR1)="") S PSOIOS=IOS D DEVBAR^PSOBMST
    23         I $G(DFN) D ADD^VADPT
    24         S ADDR(33)=$G(VAPA(4))_", "_$P($G(VAPA(5)),"^",2)_"  "_$S($G(VAPA(11))]"":$P($G(VAPA(11)),"^",2),1:$G(VAPA(6))),ADDR(22)=""
    25         S:$G(VAPA(2))]"" ADDR(22)=$G(VAPA(2))_" "_$G(VAPA(3)),ADDR(22)=$E(ADDR(22),1,46) S:ADDR(22)="" ADDR(22)=ADDR(33),ADDR(33)=""
    26         S ADDR(4)=$S(ADDR(33)="":ADDR(22),1:ADDR(33)) I $G(VAPA(2))="",$G(VAPA(3))="" S ADDR(2)=ADDR(4),ADDR(3)="",ADDR(4)="" G ST
    27         I $G(VAPA(2))'="",$G(VAPA(3))="" S ADDR(2)=VAPA(2),ADDR(3)=ADDR(4),ADDR(4)="" G ST
    28         I $G(VAPA(2))="",$G(VAPA(3))'="" S ADDR(2)=VAPA(3),ADDR(3)=ADDR(4),ADDR(4)="" G ST
    29         S ADDR(2)=$G(VAPA(2)),ADDR(3)=$G(VAPA(3))
    30 ST      I $P($G(^PSRX(RX,3)),"^",3) S PSOPROV=+$P(^(0),"^",4) S PSOPROV=$S($G(RXP):+$P($G(RXP),"^",17),$G(RXF):+$P($G(^PSRX(RX,1,RXF,0)),"^",17),1:PSOPROV) S:'$G(PSOPROV) PSOPROV=+$P(^PSRX(RX,0),"^",4) D
    31         .I +$P($G(^VA(200,PSOPROV,"PS")),"^",7) S:'$P($G(PHYS),"/",2) PHYS=$G(PHYS)_"/"_+$P($G(^PSRX(RX,3)),"^",3)
    32         S COPIES=COPIES-1,$P(ULN,"_",34)="",PSOTRAIL=1 I $G(SIDE) D REP^PSOLBL2 G REP
    33         S (Y,X1)=EXPDT X ^DD("DD") S EXPDT=Y,Y=$P(^PSRX(RX,0),"^",13) X ^DD("DD") S ISD=Y,X2=DT D ^%DTC S DIFF=X
    34         S Y=DATE X ^DD("DD") S DATE=Y D NOW^%DTC S Y=% X ^DD("DD") S NOW=Y
    35         S TECH="("_$S($P($G(^PSRX(+$G(RX),"OR1")),"^",5):$P($G(^PSRX(+$G(RX),"OR1")),"^",5),1:$P(RXY,"^",16))_"/"_$S($G(VRPH)&($P(PSOPAR,"^",32)):VRPH,1:" ")_")"
    36         S PSZIP=$P(PS,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
    37         ;
    38         I $G(PSOAFYN)="Y" G PSOAFPL1 ;vfah
    39         ;
    40 L1      W ?3,"VAMC ",$P(PS,"^",7),", ",STATE,"  ",$G(PSOHZIP),?54,"VAMC ",$P(PS,"^",7),", ",STATE,"  ",$G(PSOHZIP),?102 W $S($D(REPRINT)&($G(PSOBLALL)):"(GROUP REPRINT)",$D(REPRINT):"(REPRINT)",1:"") W:$G(RXP) "(PARTIAL)"
    41         W !?3,$P(PS2,"^",2),"  ",$P(PS,"^",3),"-",$P(PS,"^",4),"   ",TECH,?54,$P(PS2,"^",2),"  ",$P(PS,"^",3),"-",$P(PS,"^",4),"   ",TECH,?102,$P(PS2,"^",2)," ",TECH," ",NOW
    42         W !,"Rx# ",RXN,"  ",DATE,"  Fill ",RXF+1," of ",1+$P(RXY,"^",9),?54,"Rx# ",RXN,"  ",DATE,"  Fill ",RXF+1," of ",1+$P(RXY,"^",9),?102,"Rx# ",RXN,"  ",DATE,"  Fill ",RXF+1," of ",1+$P(RXY,"^",9)
    43         W !,PNM,"  ",$G(SSNPN),?54,PNM,"  ",$G(SSNPN),?102,PNM,"  ",$G(SSNPN)
    44         F DR=1:1 Q:$G(SGY(DR))=""  D:DR=4!(DR=7)!(DR=10)!(DR=13)  W !,$G(SGY(DR)),?54,$G(SGY(DR)),?102,$S($G(OSGY(DR))]"":OSGY(DR),1:$G(SGY(DR)))
    45         .F GG=1:1:27 W !
    46         I DR>4 S KK=$S(DR=5!(DR=8)!(DR=11):2,(DR=6)!(DR=9)!(DR=12):1,1:0) I KK F HH=1:1:KK W !
    47         I DR=2 W !!
    48         I DR=3 W !
    49         W !,$G(PHYS),?54,$G(PHYS),?102,$G(PHYS)
    50         S PSMF=$S($G(NURSE):"Mfg______Exp______",1:""),PSDU=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),660)),"^",8),PSDU=$S(PSDU="":"      "_PSMF,1:PSDU_" "_PSMF)
    51         W !,"Qty: "_$G(QTY),"  ",$G(PSDU),?54,"Qty: "_$G(QTY),"  ",$G(PSDU),?102,"Qty: "_$G(QTY),"  ",$G(PSDU)
    52         S ZTKDRUG="XXXXXX   SCRIPTALK RX   XXXXXX"
    53         I '$G(PSOSTLK) K PSDU,PSMF W !,DRUG,?54,DRUG,?102,DRUG
    54         I $G(PSOSTLK) K PSDU,PSMF W !,$S($G(PSOSTALK):ZTKDRUG,1:DRUG),?54,DRUG,?102,DRUG
    55         I $P(RXY,"^",9)-RXF'>0 D ^PSOLBLN1 G L13
    56         G:DIFF<30 L11
    57         W !?54,$P(RXY,"^",9)-RXF," Refills remain prior to ",EXPDT,?102,"Mfg "_$G(MFG)_" Lot# "_$G(LOT) G L12
    58 L11     W !?54,"Last fill prior to ",$G(EXPDT),?102,"Mfg "_$G(MFG)_" Lot# "_$G(LOT)
    59 L12     W !,$P(PS,"^",2),?54,$S($L($G(COPAYVAR)):$G(COPAYVAR)_"     ",1:""),"Days Supply: ",$G(DAYS),?102,"Tech__________RPh_________",!,$P(PS,"^",7),", ",STATE,"  ",$G(PSOHZIP)
    60         ;send a CR for OPTIFIL (P-MT661BC)
    61         I $G(PSOBARS),$P(PSOPAR,"^",19)'=1 S X="S",X2=PSOINST_"-"_RX S X1=$X W ?54,@PSOBAR1,X2,@PSOBAR0,$C(13) S $X=0 W:IOST["P-MT661BC" !
    62         E  W !!!
    63         W !,"FORWARDING SERVICE REQUESTED" W:"C"[$E(MW) !,?21,"CERTIFIED MAIL" W !?54,$G(VAPA(1))
    64         W !,$S($G(PS55)=2:"***DO NOT MAIL***",1:"***CRITICAL MEDICAL SHIPMENT***"),?54,$G(ADDR(2)),?102,"Routing: "_$S("W"[$E(MW):MW,1:MW_" MAIL")
    65         W !?54,$G(ADDR(3)),?102,"Days supply: ",$G(DAYS)," Cap: ",$S(PSCAP:"**NON-SFTY**",1:"SAFETY")
    66         W !?54,$G(ADDR(4)),?102,"Isd: ",ISD," Exp: ",EXPDT
    67         W !,PNM,?54,"*Indicate address change on back of this form",?102,"Last Fill: ",$G(PSOLASTF)
    68         W !,$S($D(PSMP(1)):PSMP(1),1:$G(VAPA(1))),?54,"[ ] Permanent",?102,"Pat. Stat ",PATST," Clinic: ",PSCLN
    69         W !,$S($D(PSMP(2)):PSMP(2),$D(PSMP(1)):"",1:$G(ADDR(2))),?54,"[ ] Temporary until ",$S($P($G(VAPA(10)),"^",2)]"":$P($G(VAPA(10)),"^",2),1:"__/__/__"),?102,$S($G(WARN)'="":"DRUG WARNING "_$G(WARN),1:"")
    70         W !,$S($D(PSMP(3)):PSMP(3),$D(PSMP(1)):"",1:$G(ADDR(3))),!,$S($D(PSMP(4)):PSMP(4),$D(PSMP(1)):"",1:$G(ADDR(4))),?54,"Signature",ULN
    71         I $G(PSOBARS) S X="S",X2=PSOINST_"-"_RX S X1=$X W ?102,@PSOBAR1,X2,@PSOBAR0,$C(13) S $X=0
    72 L13     I $G(WARN)'="",'$G(PSOBLALL) I '$G(PSDFNFLG),'$G(PSOLAPPL) D WARN^PSOLBL2
    73         W @IOF
    74         ;
    75 PSOAFPL1        I $G(PSOAFYN)="Y" D PSOAFP ;vfah
    76         ;
    77 REP     I COPIES>0 S SIDE=1 G ST
    78         D NOW^%DTC S NOW=% K %,%H,%I I $G(RXF)="" S RXF=0 F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I  S RXF=I
    79         S IR=0 F FDA=0:0 S FDA=$O(^PSRX(RX,"L",FDA)) Q:'FDA  S IR=FDA
    80         S IR=IR+1,^PSRX(RX,"L",0)="^52.032DA^"_IR_"^"_IR
    81         S ^PSRX(RX,"L",IR,0)=NOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_$S($G(PCOMX)]"":$G(PCOMX),$G(PCOMH(RX))]"":PCOMH(RX),1:"From RX number "_$P(^PSRX(RX,0),"^"))_$S($G(RXP):" (Partial)",1:"")_$S($D(REPRINT):" (Reprint)",1:"")_"^"_PDUZ
    82         N PSOBADR,PSOTEMP
    83         S PSOBADR=$$CHKRX^PSOBAI(RX)
    84         I $G(PSOBADR) S PSOTEMP=$P(PSOBADR,"^",2),PSOBADR=$P(PSOBADR,"^")
    85         I $G(PSOBADR),'$G(PSOTEMP) D
    86         .S IR=IR+1,^PSRX(RX,"L",0)="^52.032DA^"_IR_"^"_IR
    87         .S ^PSRX(RX,"L",IR,0)=NOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_"ROUTING="_$G(MW)_" (BAD ADDRESS)"_"^"_PDUZ
    88         S ^PSRX(RX,"TYPE")=0 K RXF,IR,FDA,NOW,I,PCOMH(RX)
    89 PSOAFPL2        I $G(PSOAFYN)="Y" G PSOAFPL3 ;vfah
    90         I $G(WARN)'="" I $G(PSDFNFLG)!($G(PSOLAPPL)) D ALLWARN^PSOLBLN1
    91         I $G(WARN)="" I $G(PSDFNFLG)!($G(PSOLAPPL)) D ALL^PSOLBLS
    92         I $G(PSOBLALL) D:$G(WARN)="" ALL^PSOLBLS D:$G(WARN)'="" ALLWARN^PSOLBLN1
    93         I '$D(PSSPND),$P(PSOPAR,"^",18) I $G(PSDFNFLG)!($G(PSOLAPPL))!($G(PSOBLALL)) D CHCK2^PSOTRLBL
    94 PSOAFPL3        ;vfah
    95         D:$G(PSOBLALL) TRAIL^PSOLBL2
    96 END     ;
    97         I $D(RXFLX(RX)) S RXFL(RX)=$G(RXFLX(RX)) K RXFLX
    98         ;
    99         I '$D(REPRINT)&($G(PSOAFYN)="Y") D ^PSODISP ;vfah auto-release
    100         ;
    101         D KILL^PSOLBL2 Q
    102         ;
    103         Q  ;vfah
    104         ;
    105 PSOAFP  ;Patient prescription print starts here;vfah
    106         S PSOAFPRV=$P($G(^PSRX(RX,0)),"^",4)
    107         S PSDU=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),660)),"^",8) ;vfah sets dispense units
    108         I $G(VFASDD)="Y" S $P(^PSRX(RX,"RXFIN"),"^",1)="Y" ;Sets complex order flag in File#52
    109         K VFASDD
    110         ;
    111 AFFAX   ;
    112         I $G(REPRINT)'=1 D
    113         .S LZ=0,STOP=0 F  S LZ=$O(^PSRX(RX,"PRC",LZ)) Q:'LZ!(STOP=1)  S LZZ=$P(^PSRX(RX,"PRC",LZ,0),"FAX: ",2) S LZZ=+LZZ I LZZ'=0 D
    114         ..I $D(^DIZ(22900)) D
    115         ...S DIC="^DIZ(22900,",DIC(0)="MOZ",X=LZZ
    116         ...D ^DIC K DIC
    117         ...I +Y'=-1 D
    118         ....S PSOAFFXP=X
    119         ....S PSOAFFXL=$P(Y,"^",2)
    120         ....S ^PSRX(RX,"PRC",LZ,0)=$TR(^PSRX(RX,"PRC",LZ,0),":","+")
    121         ....S STOP=1
    122         ...I +Y=-1 D
    123         ....S ^PSRX(RX,"PRC",LZ,0)=$TR(^PSRX(RX,"PRC",LZ,0),":","-")
    124         K STOP,LZ,LZZ
    125         I $G(REPRINT)=1 S PSOAFFXP=$G(PSOAFFXR)
    126         I $G(PSOAFFXP)>1 G AFPTL
    127         ;
    128 AFPTS   I PSOLAP["STAR" D PRNT^PSOAFPTS
    129         I PSOLAP["STAR" G AFKILL
    130         I PSOLAP["STRL" D PRNT^PSOAFPT1
    131         I PSOLAP["STRL" G AFKILL
    132         ;
    133 AFPTL   D BEGLP^PSOAFPTL
    134         ;
    135 AFKILL  K PSOAFPRV
    136         I $G(REPRINT)'=1 D ^%ZISC
     1PSOLBLN ;BIR/RTR-NEW PRINTS LABEL ; 3/11/07 1:56pm
     2 ;;7.0;OUTPATIENT PHARMACY;**16,36,71,107,110,117,135,233,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VistA
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 ;External reference to ^PSDRUG supported by DBIA 221
     20 ;External reference to ^VA(200 supported by DBIA 224
     21 K PSOSTLK,ZTKDRUG I $L($T(PSOSTALK^PSOTALK1)) D PSOSTALK^PSOTALK1 S PSOSTLK=1 ; PRINT SCRIPTALK LABEL IF APPLICABLE
     22 I $G(IOS),$G(PSOBARS) I $G(PSOBAR0)=""!($G(PSOBAR1)="") S PSOIOS=IOS D DEVBAR^PSOBMST
     23 I $G(DFN) D ADD^VADPT
     24 S ADDR(33)=$G(VAPA(4))_", "_$P($G(VAPA(5)),"^",2)_"  "_$S($G(VAPA(11))]"":$P($G(VAPA(11)),"^",2),1:$G(VAPA(6))),ADDR(22)=""
     25 S:$G(VAPA(2))]"" ADDR(22)=$G(VAPA(2))_" "_$G(VAPA(3)),ADDR(22)=$E(ADDR(22),1,46) S:ADDR(22)="" ADDR(22)=ADDR(33),ADDR(33)=""
     26 S ADDR(4)=$S(ADDR(33)="":ADDR(22),1:ADDR(33)) I $G(VAPA(2))="",$G(VAPA(3))="" S ADDR(2)=ADDR(4),ADDR(3)="",ADDR(4)="" G ST
     27 I $G(VAPA(2))'="",$G(VAPA(3))="" S ADDR(2)=VAPA(2),ADDR(3)=ADDR(4),ADDR(4)="" G ST
     28 I $G(VAPA(2))="",$G(VAPA(3))'="" S ADDR(2)=VAPA(3),ADDR(3)=ADDR(4),ADDR(4)="" G ST
     29 S ADDR(2)=$G(VAPA(2)),ADDR(3)=$G(VAPA(3))
     30ST I $P($G(^PSRX(RX,3)),"^",3) S PSOPROV=+$P(^(0),"^",4) S PSOPROV=$S($G(RXP):+$P($G(RXP),"^",17),$G(RXF):+$P($G(^PSRX(RX,1,RXF,0)),"^",17),1:PSOPROV) S:'$G(PSOPROV) PSOPROV=+$P(^PSRX(RX,0),"^",4) D
     31 .I +$P($G(^VA(200,PSOPROV,"PS")),"^",7) S:'$P($G(PHYS),"/",2) PHYS=$G(PHYS)_"/"_+$P($G(^PSRX(RX,3)),"^",3)
     32 S COPIES=COPIES-1,$P(ULN,"_",34)="",PSOTRAIL=1 I $G(SIDE) D REP^PSOLBL2 G REP
     33 S (Y,X1)=EXPDT X ^DD("DD") S EXPDT=Y,Y=$P(^PSRX(RX,0),"^",13) X ^DD("DD") S ISD=Y,X2=DT D ^%DTC S DIFF=X
     34 S Y=DATE X ^DD("DD") S DATE=Y D NOW^%DTC S Y=% X ^DD("DD") S NOW=Y
     35 S TECH="("_$S($P($G(^PSRX(+$G(RX),"OR1")),"^",5):$P($G(^PSRX(+$G(RX),"OR1")),"^",5),1:$P(RXY,"^",16))_"/"_$S($G(VRPH)&($P(PSOPAR,"^",32)):VRPH,1:" ")_")"
     36 S PSZIP=$P(PS,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
     37 ;
     38 I $G(PSOAFYN)="Y" G PSOAFPL1 ;vfah
     39 ;
     40L1 W ?3,"VAMC ",$P(PS,"^",7),", ",STATE,"  ",$G(PSOHZIP),?54,"VAMC ",$P(PS,"^",7),", ",STATE,"  ",$G(PSOHZIP),?102 W $S($D(REPRINT)&($G(PSOBLALL)):"(GROUP REPRINT)",$D(REPRINT):"(REPRINT)",1:"") W:$G(RXP) "(PARTIAL)"
     41 W !?3,$P(PS2,"^",2),"  ",$P(PS,"^",3),"-",$P(PS,"^",4),"   ",TECH,?54,$P(PS2,"^",2),"  ",$P(PS,"^",3),"-",$P(PS,"^",4),"   ",TECH,?102,$P(PS2,"^",2)," ",TECH," ",NOW
     42 W !,"Rx# ",RXN,"  ",DATE,"  Fill ",RXF+1," of ",1+$P(RXY,"^",9),?54,"Rx# ",RXN,"  ",DATE,"  Fill ",RXF+1," of ",1+$P(RXY,"^",9),?102,"Rx# ",RXN,"  ",DATE,"  Fill ",RXF+1," of ",1+$P(RXY,"^",9)
     43 W !,PNM,"  ",$G(SSNPN),?54,PNM,"  ",$G(SSNPN),?102,PNM,"  ",$G(SSNPN)
     44 F DR=1:1 Q:$G(SGY(DR))=""  D:DR=4!(DR=7)!(DR=10)!(DR=13)  W !,$G(SGY(DR)),?54,$G(SGY(DR)),?102,$S($G(OSGY(DR))]"":OSGY(DR),1:$G(SGY(DR)))
     45 .F GG=1:1:27 W !
     46 I DR>4 S KK=$S(DR=5!(DR=8)!(DR=11):2,(DR=6)!(DR=9)!(DR=12):1,1:0) I KK F HH=1:1:KK W !
     47 I DR=2 W !!
     48 I DR=3 W !
     49 W !,$G(PHYS),?54,$G(PHYS),?102,$G(PHYS)
     50 S PSMF=$S($G(NURSE):"Mfg______Exp______",1:""),PSDU=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),660)),"^",8),PSDU=$S(PSDU="":"      "_PSMF,1:PSDU_" "_PSMF)
     51 W !,"Qty: "_$G(QTY),"  ",$G(PSDU),?54,"Qty: "_$G(QTY),"  ",$G(PSDU),?102,"Qty: "_$G(QTY),"  ",$G(PSDU)
     52 S ZTKDRUG="XXXXXX   SCRIPTALK RX   XXXXXX"
     53 I '$G(PSOSTLK) K PSDU,PSMF W !,DRUG,?54,DRUG,?102,DRUG
     54 I $G(PSOSTLK) K PSDU,PSMF W !,$S($G(PSOSTALK):ZTKDRUG,1:DRUG),?54,DRUG,?102,DRUG
     55 I $P(RXY,"^",9)-RXF'>0 D ^PSOLBLN1 G L13
     56 G:DIFF<30 L11
     57 W !?54,$P(RXY,"^",9)-RXF," Refills remain prior to ",EXPDT,?102,"Mfg "_$G(MFG)_" Lot# "_$G(LOT) G L12
     58L11 W !?54,"Last fill prior to ",$G(EXPDT),?102,"Mfg "_$G(MFG)_" Lot# "_$G(LOT)
     59L12 W !,$P(PS,"^",2),?54,$S($L($G(COPAYVAR)):$G(COPAYVAR)_"     ",1:""),"Days Supply: ",$G(DAYS),?102,"Tech__________RPh_________",!,$P(PS,"^",7),", ",STATE,"  ",$G(PSOHZIP)
     60 ;send a CR for OPTIFIL (P-MT661BC)
     61 I $G(PSOBARS),$P(PSOPAR,"^",19)'=1 S X="S",X2=PSOINST_"-"_RX S X1=$X W ?54,@PSOBAR1,X2,@PSOBAR0,$C(13) S $X=0 W:IOST["P-MT661BC" !
     62 E  W !!!
     63 W !,"FORWARDING SERVICE REQUESTED" W:"C"[$E(MW) !,?21,"CERTIFIED MAIL" W !?54,$G(VAPA(1))
     64 W !,$S($G(PS55)=2:"***DO NOT MAIL***",1:"***CRITICAL MEDICAL SHIPMENT***"),?54,$G(ADDR(2)),?102,"Routing: "_$S("W"[$E(MW):MW,1:MW_" MAIL")
     65 W !?54,$G(ADDR(3)),?102,"Days supply: ",$G(DAYS)," Cap: ",$S(PSCAP:"**NON-SFTY**",1:"SAFETY")
     66 W !?54,$G(ADDR(4)),?102,"Isd: ",ISD," Exp: ",EXPDT
     67 W !,PNM,?54,"*Indicate address change on back of this form",?102,"Last Fill: ",$G(PSOLASTF)
     68 W !,$S($D(PSMP(1)):PSMP(1),1:$G(VAPA(1))),?54,"[ ] Permanent",?102,"Pat. Stat ",PATST," Clinic: ",PSCLN
     69 W !,$S($D(PSMP(2)):PSMP(2),$D(PSMP(1)):"",1:$G(ADDR(2))),?54,"[ ] Temporary until ",$S($P($G(VAPA(10)),"^",2)]"":$P($G(VAPA(10)),"^",2),1:"__/__/__"),?102,$S($G(WARN)'="":"DRUG WARNING "_$G(WARN),1:"")
     70 W !,$S($D(PSMP(3)):PSMP(3),$D(PSMP(1)):"",1:$G(ADDR(3))),!,$S($D(PSMP(4)):PSMP(4),$D(PSMP(1)):"",1:$G(ADDR(4))),?54,"Signature",ULN
     71 I $G(PSOBARS) S X="S",X2=PSOINST_"-"_RX S X1=$X W ?102,@PSOBAR1,X2,@PSOBAR0,$C(13) S $X=0
     72L13 I $G(WARN)'="",'$G(PSOBLALL) I '$G(PSDFNFLG),'$G(PSOLAPPL) D WARN^PSOLBL2
     73 W @IOF
     74 ;
     75PSOAFPL1 I $G(PSOAFYN)="Y" D PSOAFP ;vfah
     76 ;
     77REP I COPIES>0 S SIDE=1 G ST
     78 D NOW^%DTC S NOW=% K %,%H,%I I $G(RXF)="" S RXF=0 F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I  S RXF=I
     79 S IR=0 F FDA=0:0 S FDA=$O(^PSRX(RX,"L",FDA)) Q:'FDA  S IR=FDA
     80 S IR=IR+1,^PSRX(RX,"L",0)="^52.032DA^"_IR_"^"_IR
     81 S ^PSRX(RX,"L",IR,0)=NOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_$S($G(PCOMX)]"":$G(PCOMX),$G(PCOMH(RX))]"":PCOMH(RX),1:"From RX number "_$P(^PSRX(RX,0),"^"))_$S($G(RXP):" (Partial)",1:"")_$S($D(REPRINT):" (Reprint)",1:"")_"^"_PDUZ
     82 N PSOBADR,PSOTEMP
     83 S PSOBADR=$$CHKRX^PSOBAI(RX)
     84 I $G(PSOBADR) S PSOTEMP=$P(PSOBADR,"^",2),PSOBADR=$P(PSOBADR,"^")
     85 I $G(PSOBADR),'$G(PSOTEMP) D
     86 .S IR=IR+1,^PSRX(RX,"L",0)="^52.032DA^"_IR_"^"_IR
     87 .S ^PSRX(RX,"L",IR,0)=NOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_"ROUTING="_$G(MW)_" (BAD ADDRESS)"_"^"_PDUZ
     88 S ^PSRX(RX,"TYPE")=0 K RXF,IR,FDA,NOW,I,PCOMH(RX)
     89PSOAFPL2 I $G(PSOAFYN)="Y" G PSOAFPL3 ;vfah
     90 I $G(WARN)'="" I $G(PSDFNFLG)!($G(PSOLAPPL)) D ALLWARN^PSOLBLN1
     91 I $G(WARN)="" I $G(PSDFNFLG)!($G(PSOLAPPL)) D ALL^PSOLBLS
     92 I $G(PSOBLALL) D:$G(WARN)="" ALL^PSOLBLS D:$G(WARN)'="" ALLWARN^PSOLBLN1
     93 I '$D(PSSPND),$P(PSOPAR,"^",18) I $G(PSDFNFLG)!($G(PSOLAPPL))!($G(PSOBLALL)) D CHCK2^PSOTRLBL
     94PSOAFPL3 ;vfah
     95 D:$G(PSOBLALL) TRAIL^PSOLBL2
     96END ;
     97 I $D(RXFLX(RX)) S RXFL(RX)=$G(RXFLX(RX)) K RXFLX
     98 ;
     99 I '$D(REPRINT)&($G(PSOAFYN)="Y") D ^PSODISP ;vfah auto-release
     100 ;
     101 D KILL^PSOLBL2 Q
     102 ;
     103 Q  ;vfah
     104 ;
     105PSOAFP ;Patient prescription print starts here;vfah
     106 S PSOAFPRV=$P($G(^PSRX(RX,0)),"^",4)
     107 S PSDU=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),660)),"^",8) ;vfah sets dispense units
     108 I $G(VFASDD)="Y" S $P(^PSRX(RX,"RXFIN"),"^",1)="Y" ;Sets complex order flag in File#52
     109 K VFASDD
     110 ;
     111AFFAX ;
     112 I $G(REPRINT)'=1 D
     113 .S LZ=0,STOP=0 F  S LZ=$O(^PSRX(RX,"PRC",LZ)) Q:'LZ!(STOP=1)  S LZZ=$P(^PSRX(RX,"PRC",LZ,0),"FAX: ",2) S LZZ=+LZZ I LZZ'=0 D
     114 ..I $D(^DIZ(22900)) D
     115 ...S DIC="^DIZ(22900,",DIC(0)="MOZ",X=LZZ
     116 ...D ^DIC K DIC
     117 ...I +Y'=-1 D
     118 ....S PSOAFFXP=X
     119 ....S PSOAFFXL=$P(Y,"^",2)
     120 ....S ^PSRX(RX,"PRC",LZ,0)=$TR(^PSRX(RX,"PRC",LZ,0),":","+")
     121 ....S STOP=1
     122 ...I +Y=-1 D
     123 ....S ^PSRX(RX,"PRC",LZ,0)=$TR(^PSRX(RX,"PRC",LZ,0),":","-")
     124 K STOP,LZ,LZZ
     125 I $G(REPRINT)=1 S PSOAFFXP=$G(PSOAFFXR)
     126 I $G(PSOAFFXP)>1 G AFPTL
     127 ;
     128AFPTS I PSOLAP["STAR" D PRNT^PSOAFPTS
     129 I PSOLAP["STAR" G AFKILL
     130 I PSOLAP["STRL" D PRNT^PSOAFPT1
     131 I PSOLAP["STRL" G AFKILL
     132 ;
     133AFPTL D BEGLP^PSOAFPTL
     134 ;
     135AFKILL K PSOAFPRV
     136 I $G(REPRINT)'=1 D ^%ZISC

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLN2.m

    r613 r623  
    1 PSOLBLN2        ;BHAM ISC/RTR - NEW LABEL TRAILER ; 11/12/06 8:02pm
    2         ;;7.0;OUTPATIENT PHARMACY;**92,107,110,208**;DEC 1997;Build 41
    3         ; Modified from FOIA VISTA,
    4         ; Copyright (C) 2007 WorldVistA
    5         ;
    6         ; This program is free software; you can redistribute it and/or modify
    7         ; it under the terms of the GNU General Public License as published by
    8         ; the Free Software Foundation; either version 2 of the License, or
    9         ; (at your option) any later version.
    10         ;
    11         ; This program is distributed in the hope that it will be useful,
    12         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ; GNU General Public License for more details.
    15         ;
    16         ; You should have received a copy of the GNU General Public License
    17         ; along with this program; if not, write to the Free Software
    18         ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    19         Q:'+$G(RXN)!('$G(PSOTRAIL))!('+$G(DFN))
    20         I $G(PSOBLALL),$P(PPL,",",PI+1)'="" Q
    21         K ^TMP($J,"PSOMAIL"),^TMP($J,"PSONARR"),^TMP($J,"PSOSUSP") S PRCOPAY=$S('$D(PSOCPN):0,1:1)
    22 START   ;RETURN MAIL
    23         S PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:"") I $P(PSOSYS,"^",4),$D(^PS(59,+$P($G(PSOSYS),"^",4),0)) S PS=^PS(59,$P($G(PSOSYS),"^",4),0)
    24         S VAADDR1=$P(PS,"^"),VASTREET=$P(PS,"^",2),STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UNKNOWN")
    25         S PSZIP=$P(PS,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
    26         S ^TMP($J,"PSOMAIL",$S(PRCOPAY:1,1:3))="Pharmacy Service (119)",^($S(PRCOPAY:2,1:4))=$G(VAADDR1),^($S(PRCOPAY:3,1:5))=$G(VASTREET),^($S(PRCOPAY:4,1:6))=$P(PS,"^",7)_", "_$G(STATE)_"  "_$G(PSOHZIP)
    27         I PRCOPAY F ZZZ=5:1:15 S ^TMP($J,"PSOMAIL",ZZZ)=""
    28         I 'PRCOPAY F ZZZ=7:1:17 S ^TMP($J,"PSOMAIL",ZZZ)=""
    29         S ^TMP($J,"PSOMAIL",$S(PRCOPAY:16,1:18))="Use the label above to mail the computer",^($S(PRCOPAY:17,1:19))="copies back to us. Apply enough postage",^($S(PRCOPAY:18,1:20))="to your envelope to ensure delivery."
    30 NARR    ;SET TMP GLOBAL FOR NARRATIVES
    31         K ^UTILITY($J,"W") S (DIWL,PSNACNT)=1,DIWR=45,DIWF="",(PSSIXFL,PSSEVFL)=0 F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,6,ZZ)) Q:'ZZ  I $D(^(ZZ,0)) S X=^(0) D ^DIWP
    32         F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL  S ^TMP($J,"PSONARR",PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1,PSSIXFL=1
    33         I PSSIXFL S ^TMP($J,"PSONARR",PSNACNT)="" S PSNACNT=PSNACNT+1
    34         S DIWL=1,DIWR=45,DIWF="" K ^UTILITY($J,"W") F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,7,ZZ)) Q:'ZZ  I $D(^(ZZ,0)) S X=^(0) D ^DIWP
    35         F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL  S ^TMP($J,"PSONARR",PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1,PSSEVFL=1
    36         I $G(PSOCHAMP),$G(PSOTRAMT) D:PSSEVFL  S ^TMP($J,"PSONARR",PSNACNT)="REMIT $"_PSOTRAMT_" TO AGENT CASHIER." G SUSP
    37         .S ^TMP($J,"PSONARR",PSNACNT)="" S PSNACNT=PSNACNT+1
    38         I 'PRCOPAY G SUSP
    39         I PSSEVFL S ^TMP($J,"PSONARR",PSNACNT)="" S PSNACNT=PSNACNT+1
    40         S DIWL=1,DIWR=45,DIWF="" K ^UTILITY($J,"W") F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,4,ZZ)) Q:'ZZ  I $D(^(ZZ,0)) S X=^(0) D ^DIWP
    41         F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL  S ^TMP($J,"PSONARR",PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1
    42 SUSP    ;SUSPENSE DOCUMENT
    43         S (PSSUFLG,PSSPCNT)=0 S:'$D(DFN) DFN=+$P($G(^PSRX(RX,0)),"^",2) S PSODFN=DFN,(SPPL,RXX,STA)=""
    44         I $G(PSODTCUT)']"" S X1=DT,X2=-120 D C^%DTC S PSODTCUT=X
    45         D ^PSOBUILD S (STA,RXX)="" F  S STA=$O(PSOSD(STA)) Q:STA=""  F  S RXX=$O(PSOSD(STA,RXX)) Q:RXX=""  I $P(PSOSD(STA,RXX),"^",2)=5 S SPPL=$P(PSOSD(STA,RXX),"^")_","_SPPL
    46         D 6^VADPT,PID^VADPT I SPPL="" S PSSUFLG=1 G PRINT
    47         S ^TMP($J,"PSOSUSP",1)=$E($P(VADM(2),"^",2),5,12),^(2)=VADM(1),^(3)=$G(VAPA(1)),^(4)=$G(ADDR(2)) I $G(ADDR(3))="",$G(ADDR(4))="" S ^TMP($J,"PSOSUSP",5)="" G ADD
    48         I $G(ADDR(3))'="",$G(ADDR(4))="" S ^TMP($J,"PSOSUSP",5)=$G(ADDR(3)) S ^TMP($J,"PSOSUSP",6)="" G ADD
    49         S ^TMP($J,"PSOSUSP",5)=$G(ADDR(3)),^(6)=$G(ADDR(4)),^(7)=""
    50 ADD     F ZZ=0:0 S ZZ=$O(^TMP($J,"PSOSUSP",ZZ)) Q:'ZZ  S PSSPCNT=ZZ
    51         S PSSPCNT=PSSPCNT+1 S ^TMP($J,"PSOSUSP",PSSPCNT)="   The following prescriptions will be" S PSSPCNT=PSSPCNT+1 S ^TMP($J,"PSOSUSP",PSSPCNT)="mailed to you on or after the date indicated." S PSSPCNT=PSSPCNT+1
    52         S ^TMP($J,"PSOSUSP",PSSPCNT)="",PSSPCNT=PSSPCNT+1,^(PSSPCNT)="Rx#                   Date",PSSPCNT=PSSPCNT+1,^(PSSPCNT)="============================================",PSSPCNT=PSSPCNT+1,^(PSSPCNT)="",PSSPCNT=PSSPCNT+1
    53         F XX=1:1 Q:$P(SPPL,",",XX)=""  S PSSSRX=$P(SPPL,",",XX) D
    54         .S SPNUM=$O(^PS(52.5,"B",PSSSRX,0)) I SPNUM S SPDATE=$P($G(^PS(52.5,SPNUM,0)),"^",2) S Y=SPDATE D DD^%DT S SPDATE=Y
    55         .S $P(PSOLGTH," ",(20-($L($P(^PSRX(PSSSRX,0),"^")))))="" S ^TMP($J,"PSOSUSP",PSSPCNT)=$P(^PSRX(PSSSRX,0),"^")_PSOLGTH_$G(SPDATE) S PSSPCNT=PSSPCNT+1
    56         .S ^TMP($J,"PSOSUSP",PSSPCNT)="  "_$$ZZ^PSOSUTL(PSSSRX) S PSSPCNT=PSSPCNT+1 K SPNUM,SPDATE,Y
    57 PRINT   S PSOTRDFN=$P(VADM(2),"^"),PSOTRDFN=$S(PSOTRDFN]"":PSOTRDFN,1:"Unavailable") S Y=DT X ^DD("DD") S EDT=Y
    58         ;W ?54,VADM(1)_" "_$E($P(VADM(2),"^",2),5,12)_" "_EDT ;vfah
    59         W ! I PRCOPAY,$G(PSOBARS) S X="S",X2=PSOTRDFN,X1=$X W ?54,@PSOBAR1,PSOTRDFN,@PSOBAR0,$C(13) S $X=0
    60         I PRCOPAY,'$G(PSOBARS) W !!!
    61         I 'PRCOPAY W !
    62         I 'PSSUFLG D PRSUS G END
    63         ;S (PSNONARR,PSNOADDR,PSNOBOTH)=0 F TTT=1:1 Q:$G(PSNOBOTH)  D  ;vfah
    64         ;.W $G(^TMP($J,"PSOMAIL",TTT)) S:'$O(^(TTT)) PSNOADDR=1 ;vfah
    65         ;.W ?54,$G(^TMP($J,"PSONARR",TTT)),! S:'$O(^(TTT)) PSNONARR=1 ;vfah
    66         ;.I PSNOADDR,PSNONARR S PSNOBOTH=1 ;vfah
    67 END     K ^TMP($J,"PSONARR"),^TMP($J,"PSOMAIL"),^TMP($J,"PSOSUSP"),^UTILITY($J,"W")
    68         K DIWF,DIWL,DIWR,EDT,LLL,PRCOPAY,PS,PSNACNT,PSNOADDR,PSNOBOTH,PSNONARR,PSNOSUSP,PSNTHREE,PSOLGTH,PSOSD,PSOTRAIL,PSOTRDFN,PSSEVFL,PSSIXFL,PSSPCNT,PSSSRX,PSSUFLG,RXX,SPDATE,SPNUM,SPPL,STATE,TTT,VAADDR1,VADM,VAEL,VAPA,VASTREET,ZZ,ZZZ W @IOF
    69         ;I $P(PSOPAR,"^",31) D BLANK^PSOLBLD W @IOF
    70         I $P(PSOPAR,"^",31)="1" D BLANK^PSOLBLD W @IOF ;vfah
    71         Q
    72 PRSUS   S (PSNONARR,PSNOADDR,PSNOSUSP,PSNTHREE)=0 F TTT=1:1 Q:$G(PSNTHREE)  D
    73         .W $G(^TMP($J,"PSOMAIL",TTT)) S:'$O(^(TTT)) PSNOADDR=1
    74         .W ?54,$G(^TMP($J,"PSONARR",TTT)) S:'$O(^(TTT)) PSNONARR=1
    75         .W ?102,$G(^TMP($J,"PSOSUSP",TTT)),! S:'$O(^(TTT)) PSNOSUSP=1
    76         .I PSNOADDR,PSNONARR,PSNOSUSP S PSNTHREE=1
     1PSOLBLN2 ;BHAM ISC/RTR - NEW LABEL TRAILER ; 11/12/06 8:02pm
     2 ;;7.0;OUTPATIENT PHARMACY;**92,107,110,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 Q:'+$G(RXN)!('$G(PSOTRAIL))!('+$G(DFN))
     20 I $G(PSOBLALL),$P(PPL,",",PI+1)'="" Q
     21 K ^TMP($J,"PSOMAIL"),^TMP($J,"PSONARR"),^TMP($J,"PSOSUSP") S PRCOPAY=$S('$D(PSOCPN):0,1:1)
     22START ;RETURN MAIL
     23 S PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:"") I $P(PSOSYS,"^",4),$D(^PS(59,+$P($G(PSOSYS),"^",4),0)) S PS=^PS(59,$P($G(PSOSYS),"^",4),0)
     24 S VAADDR1=$P(PS,"^"),VASTREET=$P(PS,"^",2),STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UNKNOWN")
     25 S PSZIP=$P(PS,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
     26 S ^TMP($J,"PSOMAIL",$S(PRCOPAY:1,1:3))="Pharmacy Service (119)",^($S(PRCOPAY:2,1:4))=$G(VAADDR1),^($S(PRCOPAY:3,1:5))=$G(VASTREET),^($S(PRCOPAY:4,1:6))=$P(PS,"^",7)_", "_$G(STATE)_"  "_$G(PSOHZIP)
     27 I PRCOPAY F ZZZ=5:1:15 S ^TMP($J,"PSOMAIL",ZZZ)=""
     28 I 'PRCOPAY F ZZZ=7:1:17 S ^TMP($J,"PSOMAIL",ZZZ)=""
     29 S ^TMP($J,"PSOMAIL",$S(PRCOPAY:16,1:18))="Use the label above to mail the computer",^($S(PRCOPAY:17,1:19))="copies back to us. Apply enough postage",^($S(PRCOPAY:18,1:20))="to your envelope to ensure delivery."
     30NARR ;SET TMP GLOBAL FOR NARRATIVES
     31 K ^UTILITY($J,"W") S (DIWL,PSNACNT)=1,DIWR=45,DIWF="",(PSSIXFL,PSSEVFL)=0 F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,6,ZZ)) Q:'ZZ  I $D(^(ZZ,0)) S X=^(0) D ^DIWP
     32 F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL  S ^TMP($J,"PSONARR",PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1,PSSIXFL=1
     33 I PSSIXFL S ^TMP($J,"PSONARR",PSNACNT)="" S PSNACNT=PSNACNT+1
     34 S DIWL=1,DIWR=45,DIWF="" K ^UTILITY($J,"W") F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,7,ZZ)) Q:'ZZ  I $D(^(ZZ,0)) S X=^(0) D ^DIWP
     35 F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL  S ^TMP($J,"PSONARR",PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1,PSSEVFL=1
     36 I $G(PSOCHAMP),$G(PSOTRAMT) D:PSSEVFL  S ^TMP($J,"PSONARR",PSNACNT)="REMIT $"_PSOTRAMT_" TO AGENT CASHIER." G SUSP
     37 .S ^TMP($J,"PSONARR",PSNACNT)="" S PSNACNT=PSNACNT+1
     38 I 'PRCOPAY G SUSP
     39 I PSSEVFL S ^TMP($J,"PSONARR",PSNACNT)="" S PSNACNT=PSNACNT+1
     40 S DIWL=1,DIWR=45,DIWF="" K ^UTILITY($J,"W") F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,4,ZZ)) Q:'ZZ  I $D(^(ZZ,0)) S X=^(0) D ^DIWP
     41 F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL  S ^TMP($J,"PSONARR",PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1
     42SUSP ;SUSPENSE DOCUMENT
     43 S (PSSUFLG,PSSPCNT)=0 S:'$D(DFN) DFN=+$P($G(^PSRX(RX,0)),"^",2) S PSODFN=DFN,(SPPL,RXX,STA)=""
     44 I $G(PSODTCUT)']"" S X1=DT,X2=-120 D C^%DTC S PSODTCUT=X
     45 D ^PSOBUILD S (STA,RXX)="" F  S STA=$O(PSOSD(STA)) Q:STA=""  F  S RXX=$O(PSOSD(STA,RXX)) Q:RXX=""  I $P(PSOSD(STA,RXX),"^",2)=5 S SPPL=$P(PSOSD(STA,RXX),"^")_","_SPPL
     46 D 6^VADPT,PID^VADPT I SPPL="" S PSSUFLG=1 G PRINT
     47 S ^TMP($J,"PSOSUSP",1)=$E($P(VADM(2),"^",2),5,12),^(2)=VADM(1),^(3)=$G(VAPA(1)),^(4)=$G(ADDR(2)) I $G(ADDR(3))="",$G(ADDR(4))="" S ^TMP($J,"PSOSUSP",5)="" G ADD
     48 I $G(ADDR(3))'="",$G(ADDR(4))="" S ^TMP($J,"PSOSUSP",5)=$G(ADDR(3)) S ^TMP($J,"PSOSUSP",6)="" G ADD
     49 S ^TMP($J,"PSOSUSP",5)=$G(ADDR(3)),^(6)=$G(ADDR(4)),^(7)=""
     50ADD F ZZ=0:0 S ZZ=$O(^TMP($J,"PSOSUSP",ZZ)) Q:'ZZ  S PSSPCNT=ZZ
     51 S PSSPCNT=PSSPCNT+1 S ^TMP($J,"PSOSUSP",PSSPCNT)="   The following prescriptions will be" S PSSPCNT=PSSPCNT+1 S ^TMP($J,"PSOSUSP",PSSPCNT)="mailed to you on or after the date indicated." S PSSPCNT=PSSPCNT+1
     52 S ^TMP($J,"PSOSUSP",PSSPCNT)="",PSSPCNT=PSSPCNT+1,^(PSSPCNT)="Rx#                   Date",PSSPCNT=PSSPCNT+1,^(PSSPCNT)="============================================",PSSPCNT=PSSPCNT+1,^(PSSPCNT)="",PSSPCNT=PSSPCNT+1
     53 F XX=1:1 Q:$P(SPPL,",",XX)=""  S PSSSRX=$P(SPPL,",",XX) D
     54 .S SPNUM=$O(^PS(52.5,"B",PSSSRX,0)) I SPNUM S SPDATE=$P($G(^PS(52.5,SPNUM,0)),"^",2) S Y=SPDATE D DD^%DT S SPDATE=Y
     55 .S $P(PSOLGTH," ",(20-($L($P(^PSRX(PSSSRX,0),"^")))))="" S ^TMP($J,"PSOSUSP",PSSPCNT)=$P(^PSRX(PSSSRX,0),"^")_PSOLGTH_$G(SPDATE) S PSSPCNT=PSSPCNT+1
     56 .S ^TMP($J,"PSOSUSP",PSSPCNT)="  "_$$ZZ^PSOSUTL(PSSSRX) S PSSPCNT=PSSPCNT+1 K SPNUM,SPDATE,Y
     57PRINT S PSOTRDFN=$P(VADM(2),"^"),PSOTRDFN=$S(PSOTRDFN]"":PSOTRDFN,1:"Unavailable") S Y=DT X ^DD("DD") S EDT=Y
     58 ;W ?54,VADM(1)_" "_$E($P(VADM(2),"^",2),5,12)_" "_EDT ;vfah
     59 W ! I PRCOPAY,$G(PSOBARS) S X="S",X2=PSOTRDFN,X1=$X W ?54,@PSOBAR1,PSOTRDFN,@PSOBAR0,$C(13) S $X=0
     60 I PRCOPAY,'$G(PSOBARS) W !!!
     61 I 'PRCOPAY W !
     62 I 'PSSUFLG D PRSUS G END
     63 ;S (PSNONARR,PSNOADDR,PSNOBOTH)=0 F TTT=1:1 Q:$G(PSNOBOTH)  D  ;vfah
     64 ;.W $G(^TMP($J,"PSOMAIL",TTT)) S:'$O(^(TTT)) PSNOADDR=1 ;vfah
     65 ;.W ?54,$G(^TMP($J,"PSONARR",TTT)),! S:'$O(^(TTT)) PSNONARR=1 ;vfah
     66 ;.I PSNOADDR,PSNONARR S PSNOBOTH=1 ;vfah
     67END K ^TMP($J,"PSONARR"),^TMP($J,"PSOMAIL"),^TMP($J,"PSOSUSP"),^UTILITY($J,"W")
     68 K DIWF,DIWL,DIWR,EDT,LLL,PRCOPAY,PS,PSNACNT,PSNOADDR,PSNOBOTH,PSNONARR,PSNOSUSP,PSNTHREE,PSOLGTH,PSOSD,PSOTRAIL,PSOTRDFN,PSSEVFL,PSSIXFL,PSSPCNT,PSSSRX,PSSUFLG,RXX,SPDATE,SPNUM,SPPL,STATE,TTT,VAADDR1,VADM,VAEL,VAPA,VASTREET,ZZ,ZZZ W @IOF
     69 ;I $P(PSOPAR,"^",31) D BLANK^PSOLBLD W @IOF
     70 I $P(PSOPAR,"^",31)="1" D BLANK^PSOLBLD W @IOF ;vfah
     71 Q
     72PRSUS S (PSNONARR,PSNOADDR,PSNOSUSP,PSNTHREE)=0 F TTT=1:1 Q:$G(PSNTHREE)  D
     73 .W $G(^TMP($J,"PSOMAIL",TTT)) S:'$O(^(TTT)) PSNOADDR=1
     74 .W ?54,$G(^TMP($J,"PSONARR",TTT)) S:'$O(^(TTT)) PSNONARR=1
     75 .W ?102,$G(^TMP($J,"PSOSUSP",TTT)),! S:'$O(^(TTT)) PSNOSUSP=1
     76 .I PSNOADDR,PSNONARR,PSNOSUSP S PSNTHREE=1

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLLLI.m

    r613 r623  
    1 PSOLLLI ;BIR/JLC - LASER LABELS INITIALIZATION ;4/25/07 9:00am
    2         ;;7.0;OUTPATIENT PHARMACY;**120,157,189,161,244,200,206,225**;DEC 1997;Build 29
    3         ;
    4         ;DBIAs PSDRUG-221, PS(55-2228, SC-10040, IBARX-125, PSXSRP-2201, %ZIS-3435, DPT-3097, ^TMP($J,"PSNPPIO"-3794
    5         ;External reference to DRUG^PSSWRNA supported by DBIA 4449
    6         ;
    7         ;*244 remove test for partial fill when testing status > 11
    8         ;
    9 DQ      N PSOBIO S (I,PSOIO)=0 F  S I=$O(^%ZIS(2,IOST(0),55,I)) Q:'I  S X0=$G(^(I,0)) I X0]"" S PSOIO($P(X0,"^"))=^(1),PSOIO=1
    10 DQ1     I '$D(PPL) G HLEX
    11         I $P($G(PSOPAR),"^",30)=2,'$G(PSOEXREP) G HLEX
    12         K RXFLX S PSOCKHN=","_$G(PPL),PSRESOLV=+PPL D CHECK
    13         S PSOINT=1 F PI=1:1 S RX=$P(PPL,",",PI) Q:RX=""  D
    14         . S RXY=$G(^PSRX(RX,0)) Q:RXY=""  I PSOPDFN'=$P(RXY,"^",2),'PSOINT D TRAIL^PSOLLL1 S PSOPDFN=$P(RXY,"^",2)
    15         . K RXP,REPRINT D C
    16         I 'PSOINT D TRAIL^PSOLLL1
    17 HLEX    K RXPI,PSORX,RXP,PSOIOS,PSOLAPPL,XXX,COPAYVAR,TECH,PHYS,MFG,NURSE,STATE,SIDE,COPIES,EXDT,ISD,PSOINST,RXN,RXY,VADT,DEA,WARN,FDT,QTY,PATST,PDA,PS,PS1,RXP,REPRINT
    18         K SGY,OSGY,PS2,PSL,PSNP,INRX,RR,XTYPE,SSNP,SSNPN,PNM,ADDR,PSODBQ,PSOLASTF,PSRESOLV,PSOEXREP,PSOSXQ
    19         K DATE,DR,DRUG,LINE,MW,PRTFL,VRPH,EXPDT,X2,DIFF,DAYS,PSZIP,PSOHZIP,PS55,PS55X
    20         K ^TMP($J,"PSNPMI"),^TMP($J,"PSOCP",+$G(PSOCPN)),PSOCPN,PSOLBLDR,PSOLBLPS,PSOLBLCP,RXPR,RXRP,RXRS,PSOCKHN,RXFLX,PSOLAPPL,PSOPDFN,PSDFNFLG,PSOZERO,NEXTRX,PSOBLALL,STA
    21         I '$G(PSOSUREP),'$G(PSOSUSPR) S ZTREQ="@"
    22         Q
    23 C       N PSOBIO S (I,PSOIO)=0 F  S I=$O(^%ZIS(2,IOST(0),55,I)) Q:'I  S X0=$G(^(I,0)) I X0]"" S PSOIO($P(X0,"^"))=^(1),PSOIO=1
    24         U IO Q:'$D(^PSRX(RX,0))  S RXY=^(0),RX2=^(2),RXSTA=^("STA") K SGY,OSGY
    25         S (SIGM,PFM,PMIM,L2,L3,L4,L5,FILLCONT,BOTTLBL)=0
    26         K SIGF,PFF,PMIF S (SIGF,PFF,PMIF)=0 F I="DR","T" S (SIGF(I),PFF(I))=1
    27         F I="A","B","I" S PMIF(I)=1
    28         D NOW^%DTC S Y=$P(%,"."),PSOFNOW=% X ^DD("DD") S PSONOW=Y,Y=PSOFNOW X ^DD("DD") S PSONOWT=Y
    29         S:$G(PSOBLALL) PSOBLRX=RX S:$D(RXRP(RX)) REPRINT=1 S:$D(RXPR(RX)) RXP=RXPR(RX)
    30         I $G(PSOSUREP)!($G(PSOEXREP)) S REPRINT=1 I '$G(RXRP(RX)) S RXRP(RX)=1
    31         S A=$P(RXSTA,"^") I A>11 D AL^PSOLBL("QT") K RXP,REPRINT Q      ;*244
    32         I A=3 D AL^PSOLBL("QT") K RXP,REPRINT Q
    33         I $G(RXPR(RX)),'$D(^PSRX(RX,"P",RXP,0)) K RXP,REPRINT Q
    34         I $P($G(RXFL(RX)),"^"),'$D(^PSRX(RX,1,$P($G(RXFL(RX)),"^"),0)) K RXP,REPRINT Q
    35         I $G(PSODBQ)!($G(RXRS(RX))) S RR=$O(^PS(52.5,"B",RX,0)) Q:'RR  I $G(^PS(52.5,RR,"P"))=1 K RXP,REPRINT Q
    36         I $G(RXRS(RX))!($G(PSOPULL)) S PSOSXQ=0 N DR,DA,DIE D  I $G(PSOSXQ) K RXP,REPRINT Q
    37         . S DA=$O(^PS(52.5,"B",RX,0)) Q:'DA
    38         . S A=$P($G(^PS(52.5,DA,0)),"^",7) I A="" Q
    39         . I A="Q" S DIE="^PS(52.5,",DR="3////P" D ^DIE Q
    40         . K RXRS(RX) S PSOSXQ=1
    41         I $G(PSRESOLV)=RX D ENLBL^PSOBSET K PSRESOLV
    42         I $P(RXSTA,"^")'=4 D
    43         . I $G(PSOSUSPR) D AREC^PSOSUTL
    44         . I $G(PSOPULL)!($G(RXRS(RX))) D AREC1^PSOSUTL
    45         . I $G(PSOSUREP) D AREC^PSOSUSRP
    46         . I $G(PSXREP) D AREC^PSXSRP
    47         S RXY=^PSRX(RX,0),RX2=^(2),RXSTA=^("STA")
    48         K ^UTILITY("DIQ1",$J) S DA=$P($$SITE^VASITE(),"^")
    49         I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIC
    50         S RXN=$P(RXY,"^"),DFN=+$P(RXY,"^",2),PSOLBLPS=+$P(RXY,"^",3),PSOLBLDR=+$P(RXY,"^",6)
    51         S ISD=$P(RXY,"^",13),RXF=0,SIG=$P($G(^PSRX(RX,"SIG")),"^"),ISD=$E(ISD,4,5)_"/"_$E(ISD,6,7)_"/"_($E(ISD,1,3)+1700),ZY=0,$P(LINE,"_",28)="_"
    52         S NURSE=$S($P($G(^DPT(DFN,"NHC")),"^")="Y":1,$P($G(^PS(55,DFN,40)),"^"):1,1:0)
    53         S FDT=$P(RX2,"^",2),PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:""),PS1=$S($D(^(1)):^(1),1:""),PSOSITE7=$P(^("IB"),"^")
    54         S PS2=$P(PS,"^")_"^"_$P(PS,"^",6)
    55         S EXPDT=$P(RX2,"^",6),EXDT=$S('EXPDT:"",1:$E(EXPDT,4,5)_"/"_$E(EXPDT,6,7)_"/"_($E(EXPDT,1,3)+1700))
    56         S COPIES=$S($P($G(RXRP(RX)),"^",2):$P($G(RXRP(RX)),"^",2),$P(RXY,"^",18)]"":$P(RXY,"^",18),1:1)
    57         K PSOCKHNX S PSOCKHL=$L(RX),PSOCKHN=$E($G(PSOCKHN),(PSOCKHL+2),999) D  K PSOCKHNX,PSOCKHL,PSOCKHA
    58         .S PSOCKHA=","_RX_","
    59         .I PSOCKHN'[PSOCKHA Q
    60         .S PSOCKHA=$E(PSOCKHA,1,($L(PSOCKHA)-1))
    61         .S PSOCKHNX=$L(PSOCKHN,PSOCKHA)-1
    62         .I +$G(PSOCKHNX)>0 D DOUB
    63         I $O(^PSRX(RX,1,0)),$G(RXFL(RX))'=0 S $P(^PSRX(RX,3),"^",6)="" K ^PSRX(RX,"DAI"),^PSRX(RX,"DRI")
    64         I '$G(RXP),'$O(^PSRX(RX,1,0)) S RXFL(RX)=0
    65         I '$G(RXP) D OSET I '$O(^PSRX(RX,1,0))!($G(RXFL(RX))=0) G ORIG
    66         I $O(^PSRX(RX,1,0)),'$G(RXP) D  G STA
    67         . I '$G(RXFL(RX)) S XTYPE=1 D REF
    68         I $G(RXP) S XTYPE="P" D REF G STA
    69 ORIG    S TECH=$P($G(^VA(200,+$P(RXY,"^",16),0)),"^"),PHYS=$S($D(^VA(200,+$P(RXY,"^",4),0)):$P(^(0),"^"),1:"UKN")
    70         S DAYS=$P(RXY,"^",8),QTY=$P(RXY,"^",7)
    71         D 6^VADPT,PID^VADPT6 S SSNPN=$G(VA("BID"))
    72 STA     S STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UKN")
    73         S DRUG=$$ZZ^PSOSUTL(RX),DEA=$P($G(^PSDRUG(+$P(RXY,"^",6),0)),"^",3),WARN=$P($G(^(0)),"^",8)
    74         S WARN=$$DRUG^PSSWRNA(+$P(RXY,"^",6),+$P(RXY,"^",2))
    75         S SIDE=$S($P($G(RXRP(RX)),"^",3):1,1:0)
    76         I $G(^PSRX(RX,"P",+$G(RXP),0))]"" S RXPI=RXP D
    77         .S RXP=^PSRX(RX,"P",RXP,0)
    78         .S RXY=$P(RXP,"^")_"^"_$P(RXY,"^",2,6)_"^"_$P(RXP,"^",4)_"^"_$P(RXP,"^",10)_"^"_$P(RXY,"^",9)_"^"_$P($G(^PSRX(RX,"SIG")),"^",2)_"^"_$P(RXP,"^",2)_"^"_$P(RXY,"^",12,14)_"^"_$P(^PSRX(RX,"STA"),"^")_"^"_$P(RXP,"^",7)_"^"_$P(RXY,"^",17,99)
    79         .S FDT=$P(RXP,"^")
    80         S MW=$P(RXY,"^",11) I $G(RXFL(RX))'=0 D:$G(RXFL(RX))  I '$G(RXFL(RX)) F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I  S RXF=RXF+1 S:'$G(RXP) MW=$P(^PSRX(RX,1,I,0),"^",2) I +^PSRX(RX,1,I,0)'<FDT S FDT=+^(0)
    81         .I $G(RXFL(RX)),'$D(^PSRX(RX,1,RXFL(RX),0)) K RXFL(RX) Q
    82         .S RXF=RXFL(RX) S:'$G(RXP) MW=$P($G(^PSRX(RX,1,RXF,0)),"^",2) I +^PSRX(RX,1,RXF,0)'<FDT S FDT=+^(0)
    83         I MW="W",$G(^PSRX(RX,"MP"))]"" D
    84         .S PSMP=^PSRX(RX,"MP"),PSJ=0 F PSI=1:1:$L(PSMP) S PSMP(PSI)="",PSJ=PSJ+1 F PSJ=PSJ:1 S PSMP(PSI)=PSMP(PSI)_$P(PSMP," ",PSJ)_" " Q:($L(PSMP(PSI))+$L($P(PSMP," ",PSJ+1))>30)
    85         .K PSMP(PSI)
    86         ;New mail codes for CMOP
    87         S MAILCOM=""
    88         S X=$G(^PS(55,DFN,0)),PSCAP=$P(X,"^",2),PS55=$P(X,"^",3),PS55X=$P(X,"^",5)
    89         I PS55X]"",PS55>1,PS55X<DT S PS55=0
    90         S:MW="M" MW=$S((PS55=1!(PS55=4)):"R",1:MW)
    91         S MAILCOM=$P($G(^PS(59,PSOSITE,9)),"^")
    92         S MW=$S(MW="M":"REGULAR",MW="R":"CERTIFIED",1:"WINDOW")
    93         I $G(PSMP(1))="",$G(PS55)=2 S PSMP(1)=$G(SSNPN)
    94         S DATE=$E(FDT,1,7),REF=$P(RXY,"^",9)-RXF S:'$G(RXP) $P(^PSRX(RX,3),"^")=FDT S:REF<1 REF=0 D ^PSOLBL2 S II=RX D ^PSORFL,RFLDT^PSORFL
    95         S (X,PSOFLAST)=$G(PSOLASTF) I X?1N.E D ^%DT X ^DD("DD") S PSOFLAST=Y
    96         S PATST=$G(^PS(53,+$P(RXY,"^",3),0)) S PRTFL=1 I REF=0 S:('$P(PATST,"^",5))!(DEA["W")!(DEA[1)!(DEA[2) PRTFL=0
    97         S VRPH=$P(RX2,"^",10),PSCLN=+$P(RXY,"^",5),PSCLN=$G(^SC(PSCLN,0)),PSCLN=$S($P(PSCLN,"^",2)'="":$P(PSCLN,"^",2),1:$E($P(PSCLN,"^"),1,7)) I PSCLN="" S PSCLN="UNKNOWN"
    98         S PATST=$P(PATST,"^",2),X1=DT,X2=$P(RXY,"^",8)-10 D C^%DTC:REF I $D(^PSRX(RX,2)),$P(^(2),"^",6),REF,X'<$P(^(2),"^",6) S REF=0,VRPH=$P(^(2),"^",10)
    99         I $G(PSOCHAMP),$G(PSOTRAMT) S COPAYVAR="CHAMPUS" G LBL
    100         I $G(RXP) S COPAYVAR="" G LBL
    101         I $P($G(^PS(53,+$G(PSOLBLPS),0)),"^",7) D SNO G LBL
    102         I DEA["I"!(DEA["S") D SNO G LBL
    103         I $P(^PSRX(RX,"STA"),"^")>0,$P(^("STA"),"^")'=2,'$G(PSODBQ) D SNO G LBL
    104         I $G(PSOLBLCP)="" D IBCP
    105         N PSOQI S PSOQI=$G(^PSRX(RX,"IBQ"))
    106         I $G(PSOLBLCP)=0 D SNO G LBL
    107         I $G(PSOLBLCP)=1 I $P(PSOQI,"^",2)!($P(PSOQI,"^",3))!($P(PSOQI,"^",4))!($P(PSOQI,"^",5))!($P(PSOQI,"^",6))!($P(PSOQI,"^",7))!($P(PSOQI,"^",8)) D SNO G LBL
    108         I $G(PSOLBLCP)=2 I $P(PSOQI,"^")!($P(PSOQI,"^",2))!($P(PSOQI,"^",3))!($P(PSOQI,"^",4))!($P(PSOQI,"^",5))!($P(PSOQI,"^",6))!($P(PSOQI,"^",7))!($P(PSOQI,"^",8)) D SNO G LBL
    109         I $G(PSOLBLCP)=2,'$P($G(^PSRX(RX,"IB")),"^") D SNO G LBL
    110         S PSOCPN=$P(RXY,"^",2),INRX=$P(RXY,"^")
    111         I $G(^TMP($J,"PSOCP",PSOCPN))="" S ^(PSOCPN)=PSOCPN
    112         S ^TMP($J,"PSOCP",PSOCPN,INRX)=INRX_"^"_$$ZZ^PSOSUTL(RX)_"^"_+$G(DAYS),COPAYVAR="COPAY" K ZDRUG
    113 LBL     I $G(PSOIO("LLI"))]"" X PSOIO("LLI")
    114         I $P(RXSTA,"^")=4 D ^PSOLLL8 Q  ;for a critical interaction entered by a tech - don't allow a label to be printed
    115         I $D(^PSRX(RX,"DRI")),'$G(RXF),'$G(RXP) D ^PSOLLL8
    116         I $P($G(^PSRX(RX,3)),"^",6),'$G(RXF),'$G(RXP) D ^PSOLLL9
    117         S PSOINT=0 G ^PSOLLL1
    118 REF     F XXX=0:0 S XXX=$O(^PSRX(RX,XTYPE,XXX)) Q:+XXX'>0  D
    119         .S TECH=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",7),0)):$P(^(0),"^"),1:"UNKNOWN")
    120         .S QTY=$P(^PSRX(RX,XTYPE,XXX,0),"^",4),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",17),0)):$P(^(0),"^"),$D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT6 S SSNPN=$G(VA("BID"))
    121         .S DAYS=$P(^PSRX(RX,XTYPE,XXX,0),"^",10)
    122         Q
    123 CHECK   S PSDFNFLG=0,PSOZERO=$P(PPL,","),PSOPDFN=$P(^PSRX(PSOZERO,0),"^",2)
    124         Q
    125 OSET    ;
    126         N A
    127         I $G(RXFL(RX))']""!($G(RXFL(RX))=0) D  Q
    128         .S A=^PSRX(RX,0)
    129         .S TECH=$P($G(^VA(200,+$P(A,"^",16),0)),"^"),QTY=$P(A,"^",7),PHYS=$S($D(^VA(200,+$P(A,"^",4),0)):$P(^(0),"^"),1:"UKN") D 6^VADPT,PID^VADPT6 S SSNPN=$G(VA("BID"))
    130         .S DAYS=$P(A,"^",8)
    131         I '$D(^PSRX(RX,1,RXFL(RX),0)) K RXFL(RX) Q
    132         S A=^PSRX(RX,1,RXFL(RX),0)
    133         S TECH=$S($D(^VA(200,+$P(A,"^",7),0)):$P(^(0),"^"),1:"UNKNOWN")
    134         S QTY=$P(A,"^",4),PHYS=$S($D(^VA(200,+$P(A,"^",17),0)):$P(^(0),"^"),$D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT6 S SSNPN=$G(VA("BID"))
    135         S DAYS=$P(A,"^",10)
    136         Q
    137 DOUB    ;
    138         Q:'$D(RXFL(RX))
    139         I +$G(RXFL(RX))-PSOCKHNX<0 Q
    140         S RXFLX(RX)=$G(RXFL(RX))
    141         S RXFL(RX)=$G(RXFL(RX))-PSOCKHNX
    142         Q
    143 IBCP    ;
    144         N X,Y,PSOJJ,PSOLL
    145         S PSOLBLCP=""
    146         S X=$P($G(^PS(59,+$G(PSOSITE),"IB")),"^")_"^"_$G(DFN) D XTYPE^IBARX
    147         S PSOJJ="" F  S PSOJJ=$O(Y(PSOJJ)) Q:'PSOJJ  S PSOLL="" F  S PSOLL=$O(Y(PSOJJ,PSOLL)) Q:PSOLL=""  S:PSOLL>0 PSOLBLCP=PSOLL
    148         I '$G(PSOLBLCP) S PSOLBLCP=0
    149         Q
    150 SNO     ;
    151         S COPAYVAR="NO COPAY"
    152         Q
     1PSOLLLI ;BIR/JLC - LASER LABELS INITIALIZATION ;10 Oct 2006  4:56 PM
     2 ;;7.0;OUTPATIENT PHARMACY;**120,157,189,161,244,200**;DEC 1997;Build 7
     3 ;
     4 ;DBIAs PSDRUG-221, PS(55-2228, SC-10040, IBARX-125, PSXSRP-2201, %ZIS-3435, DPT-3097, ^TMP($J,"PSNPPIO"-3794
     5 ;External reference to DRUG^PSSWRNA supported by DBIA 4449
     6 ;
     7 ;*244 remove test for partial fill when testing status > 11
     8 ;
     9DQ N PSOBIO S (I,PSOIO)=0 F  S I=$O(^%ZIS(2,IOST(0),55,I)) Q:'I  S X0=$G(^(I,0)) I X0]"" S PSOIO($P(X0,"^"))=^(1),PSOIO=1
     10DQ1 I '$D(PPL) G HLEX
     11 I $P($G(PSOPAR),"^",30)=2,'$G(PSOEXREP) G HLEX
     12 K RXFLX S PSOCKHN=","_$G(PPL),PSRESOLV=+PPL D CHECK
     13 S PSOINT=1 F PI=1:1 S RX=$P(PPL,",",PI) Q:RX=""  D
     14 . S RXY=$G(^PSRX(RX,0)) Q:RXY=""  I PSOPDFN'=$P(RXY,"^",2),'PSOINT D TRAIL^PSOLLL1 S PSOPDFN=$P(RXY,"^",2)
     15 . K RXP,REPRINT D C
     16 I 'PSOINT D TRAIL^PSOLLL1
     17HLEX K RXPI,PSORX,RXP,PSOIOS,PSOLAPPL,XXX,COPAYVAR,TECH,PHYS,MFG,NURSE,STATE,SIDE,COPIES,EXDT,ISD,PSOINST,RXN,RXY,VADT,DEA,WARN,FDT,QTY,PATST,PDA,PS,PS1,RXP,REPRINT
     18 K SGY,OSGY,PS2,PSL,PSNP,INRX,RR,XTYPE,SSNP,SSNPN,PNM,ADDR,PSODBQ,PSOLASTF,PSRESOLV,PSOEXREP,PSOSXQ
     19 K DATE,DR,DRUG,LINE,MW,PRTFL,VRPH,EXPDT,X2,DIFF,DAYS,PSZIP,PSOHZIP,PS55,PS55X
     20 K ^TMP($J,"PSNPMI"),^TMP($J,"PSOCP",+$G(PSOCPN)),PSOCPN,PSOLBLDR,PSOLBLPS,PSOLBLCP,RXPR,RXRP,RXRS,PSOCKHN,RXFLX,PSOLAPPL,PSOPDFN,PSDFNFLG,PSOZERO,NEXTRX,PSOBLALL,STA
     21 I '$G(PSOSUREP),'$G(PSOSUSPR) S ZTREQ="@"
     22 Q
     23C N PSOBIO S (I,PSOIO)=0 F  S I=$O(^%ZIS(2,IOST(0),55,I)) Q:'I  S X0=$G(^(I,0)) I X0]"" S PSOIO($P(X0,"^"))=^(1),PSOIO=1
     24 U IO Q:'$D(^PSRX(RX,0))  S RXY=^(0),RX2=^(2),RXSTA=^("STA") K SGY,OSGY
     25 S (SIGM,PFM,PMIM,L2,L3,L4,L5,FILLCONT,BOTTLBL)=0
     26 K SIGF,PFF,PMIF S (SIGF,PFF,PMIF)=0 F I="DR","T" S (SIGF(I),PFF(I))=1
     27 F I="A","B","I" S PMIF(I)=1
     28 D NOW^%DTC S Y=$P(%,"."),PSOFNOW=% X ^DD("DD") S PSONOW=Y,Y=PSOFNOW X ^DD("DD") S PSONOWT=Y
     29 S:$G(PSOBLALL) PSOBLRX=RX S:$D(RXRP(RX)) REPRINT=1 S:$D(RXPR(RX)) RXP=RXPR(RX)
     30 I $G(PSOSUREP)!($G(PSOEXREP)) S REPRINT=1 I '$G(RXRP(RX)) S RXRP(RX)=1
     31 S A=$P(RXSTA,"^") I A>11 D AL^PSOLBL("QT") K RXP,REPRINT Q      ;*244
     32 I A=3 D AL^PSOLBL("QT") K RXP,REPRINT Q
     33 I $G(RXPR(RX)),'$D(^PSRX(RX,"P",RXP,0)) K RXP,REPRINT Q
     34 I $P($G(RXFL(RX)),"^"),'$D(^PSRX(RX,1,$P($G(RXFL(RX)),"^"),0)) K RXP,REPRINT Q
     35 I $G(PSODBQ)!($G(RXRS(RX))) S RR=$O(^PS(52.5,"B",RX,0)) Q:'RR  I $G(^PS(52.5,RR,"P"))=1 K RXP,REPRINT Q
     36 I $G(RXRS(RX))!($G(PSOPULL)) S PSOSXQ=0 N DR,DA,DIE D  I $G(PSOSXQ) K RXP,REPRINT Q
     37 . S DA=$O(^PS(52.5,"B",RX,0)) Q:'DA
     38 . S A=$P($G(^PS(52.5,DA,0)),"^",7) I A="" Q
     39 . I A="Q" S DIE="^PS(52.5,",DR="3////P" D ^DIE Q
     40 . K RXRS(RX) S PSOSXQ=1
     41 I $G(PSRESOLV)=RX D ENLBL^PSOBSET K PSRESOLV
     42 I $P(RXSTA,"^")'=4 D
     43 . I $G(PSOSUSPR) D AREC^PSOSUTL
     44 . I $G(PSOPULL)!($G(RXRS(RX))) D AREC1^PSOSUTL
     45 . I $G(PSOSUREP) D AREC^PSOSUSRP
     46 . I $G(PSXREP) D AREC^PSXSRP
     47 S RXY=^PSRX(RX,0),RX2=^(2),RXSTA=^("STA")
     48 K ^UTILITY("DIQ1",$J) S DA=$P($$SITE^VASITE(),"^")
     49 I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIC
     50 S RXN=$P(RXY,"^"),DFN=+$P(RXY,"^",2),PSOLBLPS=+$P(RXY,"^",3),PSOLBLDR=+$P(RXY,"^",6)
     51 S ISD=$P(RXY,"^",13),RXF=0,SIG=$P($G(^PSRX(RX,"SIG")),"^"),ISD=$E(ISD,4,5)_"/"_$E(ISD,6,7)_"/"_($E(ISD,1,3)+1700),ZY=0,$P(LINE,"_",28)="_"
     52 S NURSE=$S($P($G(^DPT(DFN,"NHC")),"^")="Y":1,$P($G(^PS(55,DFN,40)),"^"):1,1:0)
     53 S FDT=$P(RX2,"^",2),PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:""),PS1=$S($D(^(1)):^(1),1:""),PSOSITE7=$P(^("IB"),"^")
     54 S PS2=$P(PS,"^")_"^"_$P(PS,"^",6)
     55 S EXPDT=$P(RX2,"^",6),EXDT=$S('EXPDT:"",1:$E(EXPDT,4,5)_"/"_$E(EXPDT,6,7)_"/"_($E(EXPDT,1,3)+1700))
     56 S COPIES=$S($P($G(RXRP(RX)),"^",2):$P($G(RXRP(RX)),"^",2),$P(RXY,"^",18)]"":$P(RXY,"^",18),1:1)
     57 K PSOCKHNX S PSOCKHL=$L(RX),PSOCKHN=$E($G(PSOCKHN),(PSOCKHL+2),999) D  K PSOCKHNX,PSOCKHL,PSOCKHA
     58 .S PSOCKHA=","_RX_","
     59 .I PSOCKHN'[PSOCKHA Q
     60 .S PSOCKHA=$E(PSOCKHA,1,($L(PSOCKHA)-1))
     61 .S PSOCKHNX=$L(PSOCKHN,PSOCKHA)-1
     62 .I +$G(PSOCKHNX)>0 D DOUB
     63 I $O(^PSRX(RX,1,0)),$G(RXFL(RX))'=0 S $P(^PSRX(RX,3),"^",6)="" K ^PSRX(RX,"DAI"),^PSRX(RX,"DRI")
     64 I '$G(RXP),'$O(^PSRX(RX,1,0)) S RXFL(RX)=0
     65 I '$G(RXP) D OSET I '$O(^PSRX(RX,1,0))!($G(RXFL(RX))=0) G ORIG
     66 I $O(^PSRX(RX,1,0)),'$G(RXP) D  G STA
     67 . I '$G(RXFL(RX)) S XTYPE=1 D REF
     68 I $G(RXP) S XTYPE="P" D REF G STA
     69ORIG S TECH=$P($G(^VA(200,+$P(RXY,"^",16),0)),"^"),PHYS=$S($D(^VA(200,+$P(RXY,"^",4),0)):$P(^(0),"^"),1:"UKN")
     70 S DAYS=$P(RXY,"^",8),QTY=$P(RXY,"^",7)
     71 D 6^VADPT,PID^VADPT6 S SSNPN=$G(VA("BID"))
     72STA S STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UKN")
     73 S DRUG=$$ZZ^PSOSUTL(RX),DEA=$P($G(^PSDRUG(+$P(RXY,"^",6),0)),"^",3),WARN=$P($G(^(0)),"^",8)
     74 S WARN=$$DRUG^PSSWRNA(+$P(RXY,"^",6),+$P(RXY,"^",2))
     75 S SIDE=$S($P($G(RXRP(RX)),"^",3):1,1:0)
     76 I $G(^PSRX(RX,"P",+$G(RXP),0))]"" S RXPI=RXP D
     77 .S RXP=^PSRX(RX,"P",RXP,0)
     78 .S RXY=$P(RXP,"^")_"^"_$P(RXY,"^",2,6)_"^"_$P(RXP,"^",4)_"^"_$P(RXP,"^",10)_"^"_$P(RXY,"^",9)_"^"_$P($G(^PSRX(RX,"SIG")),"^",2)_"^"_$P(RXP,"^",2)_"^"_$P(RXY,"^",12,14)_"^"_$P(^PSRX(RX,"STA"),"^")_"^"_$P(RXP,"^",7)_"^"_$P(RXY,"^",17,99)
     79 .S FDT=$P(RXP,"^")
     80 S MW=$P(RXY,"^",11) I $G(RXFL(RX))'=0 D:$G(RXFL(RX))  I '$G(RXFL(RX)) F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I  S RXF=RXF+1 S:'$G(RXP) MW=$P(^PSRX(RX,1,I,0),"^",2) I +^PSRX(RX,1,I,0)'<FDT S FDT=+^(0)
     81 .I $G(RXFL(RX)),'$D(^PSRX(RX,1,RXFL(RX),0)) K RXFL(RX) Q
     82 .S RXF=RXFL(RX) S:'$G(RXP) MW=$P($G(^PSRX(RX,1,RXF,0)),"^",2) I +^PSRX(RX,1,RXF,0)'<FDT S FDT=+^(0)
     83 I MW="W",$G(^PSRX(RX,"MP"))]"" D
     84 .S PSMP=^PSRX(RX,"MP"),PSJ=0 F PSI=1:1:$L(PSMP) S PSMP(PSI)="",PSJ=PSJ+1 F PSJ=PSJ:1 S PSMP(PSI)=PSMP(PSI)_$P(PSMP," ",PSJ)_" " Q:($L(PSMP(PSI))+$L($P(PSMP," ",PSJ+1))>30)
     85 .K PSMP(PSI)
     86 ;New mail codes for CMOP
     87 S MAILCOM=""
     88 S X=$G(^PS(55,DFN,0)),PSCAP=$P(X,"^",2),PS55=$P(X,"^",3),PS55X=$P(X,"^",5)
     89 I PS55X]"",PS55>1,PS55X<DT S PS55=1
     90 S:MW="M" MW=$S((PS55=1!(PS55=4)):"R",1:MW)
     91 S MAILCOM=$P($G(^PS(59,PSOSITE,9)),"^")
     92 S MW=$S(MW="M":"REGULAR",MW="R":"CERTIFIED",1:"WINDOW")
     93 I $G(PSMP(1))="",$G(PS55)=2 S PSMP(1)=$G(SSNPN)
     94 S DATE=$E(FDT,1,7),REF=$P(RXY,"^",9)-RXF S:'$G(RXP) $P(^PSRX(RX,3),"^")=FDT S:REF<1 REF=0 D ^PSOLBL2 S II=RX D ^PSORFL,RFLDT^PSORFL
     95 S (X,PSOFLAST)=$G(PSOLASTF) I X?1N.E D ^%DT X ^DD("DD") S PSOFLAST=Y
     96 S PATST=$G(^PS(53,+$P(RXY,"^",3),0)) S PRTFL=1 I REF=0 S:('$P(PATST,"^",5))!(DEA["A"&(DEA'["B"))!(DEA["W") PRTFL=0
     97 S VRPH=$P(RX2,"^",10),PSCLN=+$P(RXY,"^",5),PSCLN=$G(^SC(PSCLN,0)),PSCLN=$S($P(PSCLN,"^",2)'="":$P(PSCLN,"^",2),1:$E($P(PSCLN,"^"),1,7)) I PSCLN="" S PSCLN="UNKNOWN"
     98 S PATST=$P(PATST,"^",2),X1=DT,X2=$P(RXY,"^",8)-10 D C^%DTC:REF I $D(^PSRX(RX,2)),$P(^(2),"^",6),REF,X'<$P(^(2),"^",6) S REF=0,VRPH=$P(^(2),"^",10)
     99 I $G(PSOCHAMP),$G(PSOTRAMT) S COPAYVAR="CHAMPUS" G LBL
     100 I $G(RXP) S COPAYVAR="" G LBL
     101 I $P($G(^PS(53,+$G(PSOLBLPS),0)),"^",7) D SNO G LBL
     102 I DEA["I"!(DEA["S") D SNO G LBL
     103 I $P(^PSRX(RX,"STA"),"^")>0,$P(^("STA"),"^")'=2,'$G(PSODBQ) D SNO G LBL
     104 I $G(PSOLBLCP)="" D IBCP
     105 N PSOQI S PSOQI=$G(^PSRX(RX,"IBQ"))
     106 I $G(PSOLBLCP)=0 D SNO G LBL
     107 I $G(PSOLBLCP)=1 I $P(PSOQI,"^",2)!($P(PSOQI,"^",3))!($P(PSOQI,"^",4))!($P(PSOQI,"^",5))!($P(PSOQI,"^",6))!($P(PSOQI,"^",7)) D SNO G LBL
     108 I $G(PSOLBLCP)=2 I $P(PSOQI,"^")!($P(PSOQI,"^",2))!($P(PSOQI,"^",3))!($P(PSOQI,"^",4))!($P(PSOQI,"^",5))!($P(PSOQI,"^",6))!($P(PSOQI,"^",7)) D SNO G LBL
     109 I $G(PSOLBLCP)=2,'$P($G(^PSRX(RX,"IB")),"^") D SNO G LBL
     110 S PSOCPN=$P(RXY,"^",2),INRX=$P(RXY,"^")
     111 I $G(^TMP($J,"PSOCP",PSOCPN))="" S ^(PSOCPN)=PSOCPN
     112 S ^TMP($J,"PSOCP",PSOCPN,INRX)=INRX_"^"_$$ZZ^PSOSUTL(RX)_"^"_+$G(DAYS),COPAYVAR="COPAY" K ZDRUG
     113LBL I $G(PSOIO("LLI"))]"" X PSOIO("LLI")
     114 I $P(RXSTA,"^")=4 D ^PSOLLL8 Q  ;for a critical interaction entered by a tech - don't allow a label to be printed
     115 I $D(^PSRX(RX,"DRI")),'$G(RXF),'$G(RXP) D ^PSOLLL8
     116 I $P($G(^PSRX(RX,3)),"^",6),'$G(RXF),'$G(RXP) D ^PSOLLL9
     117 S PSOINT=0 G ^PSOLLL1
     118REF F XXX=0:0 S XXX=$O(^PSRX(RX,XTYPE,XXX)) Q:+XXX'>0  D
     119 .S TECH=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",7),0)):$P(^(0),"^"),1:"UNKNOWN")
     120 .S QTY=$P(^PSRX(RX,XTYPE,XXX,0),"^",4),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",17),0)):$P(^(0),"^"),$D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT6 S SSNPN=$G(VA("BID"))
     121 .S DAYS=$P(^PSRX(RX,XTYPE,XXX,0),"^",10)
     122 Q
     123CHECK S PSDFNFLG=0,PSOZERO=$P(PPL,","),PSOPDFN=$P(^PSRX(PSOZERO,0),"^",2)
     124 Q
     125OSET ;
     126 N A
     127 I $G(RXFL(RX))']""!($G(RXFL(RX))=0) D  Q
     128 .S A=^PSRX(RX,0)
     129 .S TECH=$P($G(^VA(200,+$P(A,"^",16),0)),"^"),QTY=$P(A,"^",7),PHYS=$S($D(^VA(200,+$P(A,"^",4),0)):$P(^(0),"^"),1:"UKN") D 6^VADPT,PID^VADPT6 S SSNPN=$G(VA("BID"))
     130 .S DAYS=$P(A,"^",8)
     131 I '$D(^PSRX(RX,1,RXFL(RX),0)) K RXFL(RX) Q
     132 S A=^PSRX(RX,1,RXFL(RX),0)
     133 S TECH=$S($D(^VA(200,+$P(A,"^",7),0)):$P(^(0),"^"),1:"UNKNOWN")
     134 S QTY=$P(A,"^",4),PHYS=$S($D(^VA(200,+$P(A,"^",17),0)):$P(^(0),"^"),$D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT6 S SSNPN=$G(VA("BID"))
     135 S DAYS=$P(A,"^",10)
     136 Q
     137DOUB ;
     138 Q:'$D(RXFL(RX))
     139 I +$G(RXFL(RX))-PSOCKHNX<0 Q
     140 S RXFLX(RX)=$G(RXFL(RX))
     141 S RXFL(RX)=$G(RXFL(RX))-PSOCKHNX
     142 Q
     143IBCP ;
     144 N X,Y,PSOJJ,PSOLL
     145 S PSOLBLCP=""
     146 S X=$P($G(^PS(59,+$G(PSOSITE),"IB")),"^")_"^"_$G(DFN) D XTYPE^IBARX
     147 S PSOJJ="" F  S PSOJJ=$O(Y(PSOJJ)) Q:'PSOJJ  S PSOLL="" F  S PSOLL=$O(Y(PSOJJ,PSOLL)) Q:PSOLL=""  S:PSOLL>0 PSOLBLCP=PSOLL
     148 I '$G(PSOLBLCP) S PSOLBLCP=0
     149 Q
     150SNO ;
     151 S COPAYVAR="NO COPAY"
     152 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMAO.m

    r613 r623  
    1 PSOLMAO ;BHAM ISC/LC - ACTIVE ORDERS ;03/14/1995
    2         ;;7.0;OUTPATIENT PHARMACY;**225**;DEC 1997;Build 29
    3 EN      ; -- main entry point for PSO LM ACTION ORDER
    4         D EN^VALM("PSO LM ACTIVE ORDERS")
    5         Q
    6         ;
    7 HDR     ; -- header code
    8         ;S VALMHDR(1)="This is a test header for PSO LM ACTION ORDER."
    9         ;S VALMHDR(2)="This is the second line"
    10         D HDR^PSOLMUTL
    11         Q
    12         ;
    13 INIT    ; -- init variables and list array
    14         ;F LINE=1:1:30 D SET^VALM10(LINE,LINE_"     Line number "_LINE)
    15         S VALMCNT=PSOPF
    16         D RV^PSOORFL
    17         Q
    18         ;
    19 HELP    ; -- help code
    20         S X="?" D DISP^XQORM1 W !!
    21         Q
    22         ;
    23 EXIT    ; -- exit code
    24         S PSOQFLG=1 Q
    25         ;
    26 EXPND   ; -- expand code
    27         Q
    28         ;
     1PSOLMAO ;BHAM ISC/LC - ACTIVE ORDERS ; 14-MAR-1995
     2 ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
     3EN ; -- main entry point for PSO LM ACTION ORDER
     4 D EN^VALM("PSO LM ACTIVE ORDERS")
     5 Q
     6 ;
     7HDR ; -- header code
     8 ;S VALMHDR(1)="This is a test header for PSO LM ACTION ORDER."
     9 ;S VALMHDR(2)="This is the second line"
     10 D HDR^PSOLMUTL
     11 Q
     12 ;
     13INIT ; -- init variables and list array
     14 ;F LINE=1:1:30 D SET^VALM10(LINE,LINE_"     Line number "_LINE)
     15 S VALMCNT=PSOPF
     16 Q
     17 ;
     18HELP ; -- help code
     19 S X="?" D DISP^XQORM1 W !!
     20 Q
     21 ;
     22EXIT ; -- exit code
     23 S PSOQFLG=1 Q
     24 ;
     25EXPND ; -- expand code
     26 Q
     27 ;

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMPO.m

    r613 r623  
    1 PSOLMPO ;ISC-BHAM/LC - pending orders ;03/13/95
    2         ;;7.0;OUTPATIENT PHARMACY;**46,225**;DEC 1997;Build 29
    3 EN      ; -- main entry point for PSO LM PENDING ORDER
    4         S PSOLMC=0 D EN^VALM("PSO LM PENDING ORDER") K PSOLMC
    5         Q
    6         ;
    7 HDR     ; -- header code
    8         D HDR^PSOLMUTL
    9         Q
    10         ;
    11 INIT    ; -- init variables and list array
    12         ;F LINE=1:1:30 D SET^VALM10(LINE,LINE_"     Line number "_LINE)
    13         S VALMCNT=IEN,VALM("TITLE")=$S($P(OR0,"^",23):"FL-",1:"")_"Pending OP Orders ("_$S($P(OR0,"^",14)="S":"STAT",$P(OR0,"^",14)="E":"EMERGENCY",1:"ROUTINE")_")"
    14         D RV^PSONFI
    15         Q
    16         ;
    17 HELP    ; -- help code
    18         S X="?" D DISP^XQORM1 W !!
    19         Q
    20         ;
    21 EXIT    ; -- exit code
    22         K FLAGLINE D CLEAN^VALM10
    23         Q
    24         ;
    25 EXPND   ; -- expand code
    26         Q
    27         ;
     1PSOLMPO ;ISC-BHAM/LC - pending orders ; 11/3/06 9:58pm
     2 ;;7.0;OUTPATIENT PHARMACY;**46,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19EN ; -- main entry point for PSO LM PENDING ORDER
     20 I $G(PSOAFYN)'="Y" S PSOLMC=0 D EN^VALM("PSO LM PENDING ORDER") K PSOLMCP ;vfam
     21 I $G(PSOAFYN)="Y" D ACP^PSOORNEW ;vfam
     22 Q
     23 ;
     24HDR ; -- header code
     25 D HDR^PSOLMUTL
     26 Q
     27 ;
     28INIT ; -- init variables and list array
     29 ;F LINE=1:1:30 D SET^VALM10(LINE,LINE_"     Line number "_LINE)
     30 S VALMCNT=IEN,VALM("TITLE")="Pending OP Orders ("_$S($P(OR0,"^",14)="S":"STAT",$P(OR0,"^",14)="E":"EMERGENCY",1:"ROUTINE")_")"
     31 D RV^PSONFI Q
     32 ;
     33HELP ; -- help code
     34 S X="?" D DISP^XQORM1 W !!
     35 Q
     36 ;
     37EXIT ; -- exit code
     38 Q
     39 ;
     40EXPND ; -- expand code
     41 Q
     42 ;

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMPO1.m

    r613 r623  
    1 PSOLMPO1        ;ISC-BHAM/SAB - complete pending orders ;03/13/1995
    2         ;;7.0;OUTPATIENT PHARMACY;**46,71,225**;DEC 1997;Build 29
    3 EN      ; -- main entry point for PSO LM COMPLETE ORDER
    4         D EN^VALM("PSO LM COMPLETE ORDER")
    5         K PSOANSQD
    6         Q
    7         ;
    8 HDR     ; -- header code
    9         D HDR^PSOLMUTL
    10         Q
    11         ;
    12 INIT    ; -- init variables and list array
    13         S VALMCNT=IEN,VALM("TITLE")=$S($P(OR0,"^",23):"FL-",1:"")_"Pending OP Orders ("_$S($P($G(OR0),"^",14)="S":"STAT",$P($G(OR0),"^",14)="E":"EMERGENCY",1:"ROUTINE")_")"
    14         D RV^PSONFI Q
    15         ;
    16 HELP    ; -- help code
    17         S X="?" D DISP^XQORM1 W !!
    18         Q
    19         ;
    20 EXIT    ; -- exit code
    21         K FLAGLINE D CLEAN^VALM10
    22         Q
    23         ;
    24 EXPND   ; -- expand code
    25         Q
    26         ;
     1PSOLMPO1 ;ISC-BHAM/SAB - complete pending orders ; 13-MAR-1995
     2 ;;7.0;OUTPATIENT PHARMACY;**46,71**;DEC 1997
     3EN ; -- main entry point for PSO LM COMPLETE ORDER
     4 D EN^VALM("PSO LM COMPLETE ORDER")
     5 K PSOANSQD
     6 Q
     7 ;
     8HDR ; -- header code
     9 D HDR^PSOLMUTL
     10 Q
     11 ;
     12INIT ; -- init variables and list array
     13 S VALMCNT=IEN,VALM("TITLE")="Pending OP Orders ("_$S($P($G(OR0),"^",14)="S":"STAT",$P($G(OR0),"^",14)="E":"EMERGENCY",1:"ROUTINE")_")"
     14 D RV^PSONFI Q
     15 ;
     16HELP ; -- help code
     17 S X="?" D DISP^XQORM1 W !!
     18 Q
     19 ;
     20EXIT ; -- exit code
     21 Q
     22 ;
     23EXPND ; -- expand code
     24 Q
     25 ;

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMPO2.m

    r613 r623  
    1 PSOLMPO2        ;ISC-BHAM/SAB - list template to complete backdoor orders ;03/13/1995
    2         ;;7.0;OUTPATIENT PHARMACY;**46,71,225**;DEC 1997;Build 29
    3 EN      ; -- main entry point for PSO LM BACKDOOR ORDER
    4         D EN^VALM("PSO LM BACKDOOR ORDER")
    5         Q
    6         ;
    7 HDR     ; -- header code
    8         D HDR^PSOLMUTL
    9         Q
    10         ;
    11 INIT    ; -- init variables and list array
    12         S VALMCNT=IEN,VALM("TITLE")="New OP Order ("_$S($G(COPY):"COPY",1:"ROUTINE")_")"
    13         S VALMCNT=PSOPF
    14         D RV^PSONFI Q
    15         ;
    16 HELP    ; -- help code
    17         S X="?" D DISP^XQORM1 W !!
    18         Q
    19         ;
    20 EXIT    ; -- exit code
    21         K PSOANSQD
    22         S PSOQFLG=1
    23         K FLAGLINE D CLEAN^VALM10
    24         Q
    25         ;
    26 EXPND   ; -- expand code
    27         Q
    28         ;
     1PSOLMPO2 ;ISC-BHAM/SAB - list template to complete backdoor orders ; 13-MAR-1995
     2 ;;7.0;OUTPATIENT PHARMACY;**46,71**;DEC 1997
     3EN ; -- main entry point for PSO LM BACKDOOR ORDER
     4 D EN^VALM("PSO LM BACKDOOR ORDER")
     5 Q
     6 ;
     7HDR ; -- header code
     8 D HDR^PSOLMUTL
     9 Q
     10 ;
     11INIT ; -- init variables and list array
     12 S VALMCNT=IEN,VALM("TITLE")="New OP Order ("_$S($G(COPY):"COPY",1:"ROUTINE")_")"
     13 S VALMCNT=PSOPF
     14 D RV^PSONFI Q
     15 ;
     16HELP ; -- help code
     17 S X="?" D DISP^XQORM1 W !!
     18 Q
     19 ;
     20EXIT ; -- exit code
     21 K PSOANSQD
     22 S PSOQFLG=1 Q
     23 ;
     24EXPND ; -- expand code
     25 Q
     26 ;

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMRN.m

    r613 r623  
    1 PSOLMRN ;ISC-BHAM/SAB - displays renewal rxs ;04/21/1995
    2         ;;7.0;OUTPATIENT PHARMACY;**11,46,84,225**;DEC 1997;Build 29
    3 EN      ; -- main entry point for PSO LM RENEW LIST
    4         S VALMCNT=PSOPF,PSOLM=1
    5         D EN^VALM("PSO LM RENEW LIST")
    6         Q
    7         ;
    8 HDR     ; -- header code
    9         K ^TMP("PSOHDR",$J) D HDR^PSOLMUTL
    10         Q
    11         ;
    12 INIT    ; -- init variables and list array
    13         ;F LINE=1:1:30 D SET^VALM10(LINE,LINE_"     Line number "_LINE)
    14         S VALMCNT=PSOPF,PSOLM=1
    15         D RV^PSONFI Q
    16         ;
    17 HELP    ; -- help code
    18         S X="?" D DISP^XQORM1 W !!
    19         Q
    20         ;
    21 EXIT    ; -- exit code
    22         I $G(Y)=-1!($G(Y)="Q") S PSOQUIT=1
    23         I $G(Y)="Q",$P($G(Y(1)),"^",3)="QU" S PSOQQ=1
    24         K FLAGLINE D CLEAN^VALM10
    25         Q
    26         ;
    27 EXPND   ; -- expand code
    28         Q
    29         ;
     1PSOLMRN ;ISC-BHAM/SAB - displays renewal rxs ; 21-APR-1995
     2 ;;7.0;OUTPATIENT PHARMACY;**11,46,84**;DEC 1997
     3EN ; -- main entry point for PSO LM RENEW LIST
     4 S VALMCNT=PSOPF,PSOLM=1
     5 D EN^VALM("PSO LM RENEW LIST")
     6 Q
     7 ;
     8HDR ; -- header code
     9 K ^TMP("PSOHDR",$J) D HDR^PSOLMUTL
     10 Q
     11 ;
     12INIT ; -- init variables and list array
     13 ;F LINE=1:1:30 D SET^VALM10(LINE,LINE_"     Line number "_LINE)
     14 S VALMCNT=PSOPF,PSOLM=1
     15 D RV^PSONFI Q
     16 ;
     17HELP ; -- help code
     18 S X="?" D DISP^XQORM1 W !!
     19 Q
     20 ;
     21EXIT ; -- exit code
     22 I $G(Y)=-1!($G(Y)="Q") S PSOQUIT=1
     23 I $G(Y)="Q",$P($G(Y(1)),"^",3)="QU" S PSOQQ=1
     24 Q
     25 ;
     26EXPND ; -- expand code
     27 Q
     28 ;

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMUTL.m

    r613 r623  
    1 PSOLMUTL        ;BIR/SAB - listman utilities ;03/07/95
    2         ;;7.0;OUTPATIENT PHARMACY;**19,46,84,99,131,132,148,268,225**;DEC 1997;Build 29
    3         ;External reference FULL^VALM1 supported by dbia 10116
    4         ;External reference $$SETSTR^VALM1 supported by dbia 10116
    5         ;External reference EN2^GMRAPEMO supported by dbia 190
    6         ;External reference to ^ORD(101 supported by DBIA 872
    7         ;
    8 EN      W @IOF S VALMCNT=0
    9         D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) W $C(7),!!?5,"Site parameter must be defined!",! G INITQ
    10         D EN^PSOLMPI
    11 INITQ   Q
    12 HDR     ;patient med profile display
    13         K VALMHDR S HDR=^TMP("PSOHDR",$J,1,0)
    14         S:^TMP("PSOHDR",$J,8,0) X=IORVON_"<A>"_IORVOFF,HDR=$$SETSTR^VALM1(X,HDR,80-$L(X),80) S VALMHDR(1)=HDR
    15         I '(^TMP("PSOHDR",$J,8,0)) S PSONOAL="" D ALLERGY^PSOORUT2 I PSONOAL'="" D  K PSONOAL
    16         .S X=IORVON_"<NO ALLERGY ASSESSMENT>"_IORVOFF,HDR=$$SETSTR^VALM1(X,HDR,80-$L(X),80) S VALMHDR(1)=HDR
    17         S HDR="  PID: "_^TMP("PSOHDR",$J,2,0)
    18         S VALMHDR(2)=$$SETSTR^VALM1("Ht(cm): "_^TMP("PSOHDR",$J,7,0),HDR,52,27)
    19         S HDR="  DOB: "_^TMP("PSOHDR",$J,3,0)_" ("_^TMP("PSOHDR",$J,4,0)_")"
    20         S VALMHDR(3)=$$SETSTR^VALM1(" Wt(kg): "_^TMP("PSOHDR",$J,6,0),HDR,51,28)
    21         S HDR="  SEX: "_$E(^TMP("PSOHDR",$J,5,0),1,44)
    22         S VALMHDR(4)=HDR
    23         S $P(VALMHDR(4)," ",30)="  "_$E(^TMP("PSOHDR",$J,5,0),48,80)
    24         Q:$G(PS)="VIEW"!($G(PS)="DELETE")
    25         S VALMHDR(5)=$G(^TMP("PSOHDR",$J,9,0))
    26         S VALMHDR(6)=$G(^TMP("PSOHDR",$J,10,0))
    27         Q
    28         ;
    29 NEWALL(DFN)     ; Enter Allergy info.
    30         N PSOID D FULL^VALM1,EN2^GMRAPEM0,^PSOORUT2 S VALMBCK="R"
    31         Q
    32 NEWSEL  ;allows order selection by number instead of action
    33         S Y=$P(XQORNOD(0),"=",2) N VALMCNT D NEWSEL^PSOORNE2
    34         Q
    35 EDTSEL  ;allows edit selection by number instead of action - active orders
    36         N VALMCNT S Y=$P(XQORNOD(0),"=",2) D EDTSEL^PSOOREDT
    37         Q
    38 SELAL   ;selection of allergy by number instead of action - select allergy
    39         N VALMCNT S Y=$P(XQORNOD(0),"=",2) D SELAL^PSOORDA
    40         Q
    41 EDTNEW  ;allows edit selection by number instead of action - new orders
    42         N VALMCNT S Y=$P(XQORNOD(0),"=",2) D EDTSEL^PSOORNE1
    43         Q
    44 EDTRNEW ;allows edit selection by number instead of action - renew orders
    45         N VALMCNT S Y=$P(XQORNOD(0),"=",2) D EDTSEL^PSOORNE4
    46         Q
    47 EDTPEN  ;allows edit selection by number instead of action - pending orders
    48         N VALMCNT S Y=$P(XQORNOD(0),"=",2),SEDT=1 G EDTSEL^PSOORNEW
    49         Q
    50 HLDHDR  ;keeps patient's header info
    51         S IOTM=VALM("TM"),IOBM=IOSL W IOSC W @IOSTBM W IORC
    52         Q
    53         ;
    54 BYPASS  S:$G(PSOFDR) SIGOK=1 S Y=-1,VALMBCK="Q"
    55         Q
    56 ACTIONS()       ;screen actions on active orders
    57         Q:$G(PKI1)=2 0
    58         N DIC,X,Y K DIC,Y S DIC="^ORD(101,"_DA(1)_",10,",X=DA,DIC(0)="ZN" D ^DIC Q:Y<0 0
    59         S Y=Y(0,0)
    60         I Y="PSO REFILL" Q $S(PSOACT["R":1,1:0)
    61         I Y="PSO RENEW" Q $S(PSOACT["N":1,1:0)
    62         I Y="PSO REPRINT" Q $S(PSOACT["P":1,1:0)
    63         I Y="PSO EDIT ORDERS" Q $S(PSOACT["E":1,1:0)
    64         I Y="PSO RELEASE" Q $S(PSOACT["L":1,1:0)
    65         I Y="PSO PARTIAL" Q $S(PSOACT["T":1,1:0)
    66         I Y="PSO CANCEL" Q $S(PSOACT["D":1,1:0)
    67         I Y="PSO HOLD" Q $S(PSOACT["H":1,1:0)
    68         I Y="PSO UNHOLD" Q $S(PSOACT["U":1,1:0)
    69         I Y="PSO LM BACKDOOR COPY" Q $S(PSOACT["C":1,1:0)
    70         I Y="PSO VERIFY" Q $S(PSOACT["V":1,1:0)
    71         I Y="PSO ACTIVITY LOGS" Q 1
    72         Q 1
    73 ACTIONS1()      ;screen actions on pending orders
    74         Q:$G(PKI1)=2 0
    75         N DIC,X,Y K DIC,Y S DIC="^ORD(101,"_DA(1)_",10,",X=DA,DIC(0)="ZN" D ^DIC Q:Y<0 0
    76         S Y=Y(0,0)
    77         I Y="PSO LM DISCONTINUE" Q $S(PSOACT["D":1,1:0)
    78         I Y="PSO LM EDIT" Q $S(PSOACT["E":1,1:0)
    79         I Y="PSO LM FINISH" Q $S(PSOACT["F":1,1:0)
    80         I Y="PSO LM FLAG" Q $S(PSOACT["X":1,1:0)
    81         Q 1
    82 PKIACT()        ;screen actions on pending orders DEA/PKI proj.
    83         Q:$G(PKI1)=2 0
    84         Q 1
     1PSOLMUTL ;BIR/SAB - listman utilities ;03/07/95
     2 ;;7.0;OUTPATIENT PHARMACY;**19,46,84,99,131,132,148,268**;DEC 1997;Build 9
     3 ;External reference FULL^VALM1 supported by dbia 10116
     4 ;External reference $$SETSTR^VALM1 supported by dbia 10116
     5 ;External reference EN2^GMRAPEMO supported by dbia 190
     6 ;External reference to ^ORD(101 supported by DBIA 872
     7 ;
     8EN W @IOF S VALMCNT=0
     9 D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) W $C(7),!!?5,"Site parameter must be defined!",! G INITQ
     10 D EN^PSOLMPI
     11INITQ Q
     12HDR ;patient med profile display
     13 K VALMHDR S HDR=^TMP("PSOHDR",$J,1,0)
     14 S:^TMP("PSOHDR",$J,8,0) X=IORVON_"<A>"_IORVOFF,HDR=$$SETSTR^VALM1(X,HDR,80-$L(X),80) S VALMHDR(1)=HDR
     15 I '(^TMP("PSOHDR",$J,8,0)) S PSONOAL="" D ALLERGY^PSOORUT2 I PSONOAL'="" D  K PSONOAL
     16 .S X=IORVON_"<NO ALLERGY ASSESSMENT>"_IORVOFF,HDR=$$SETSTR^VALM1(X,HDR,80-$L(X),80) S VALMHDR(1)=HDR
     17 S HDR="  PID: "_^TMP("PSOHDR",$J,2,0)
     18 S VALMHDR(2)=$$SETSTR^VALM1("Ht(cm): "_^TMP("PSOHDR",$J,7,0),HDR,52,27)
     19 S HDR="  DOB: "_^TMP("PSOHDR",$J,3,0)_" ("_^TMP("PSOHDR",$J,4,0)_")"
     20 S VALMHDR(3)=$$SETSTR^VALM1(" Wt(kg): "_^TMP("PSOHDR",$J,6,0),HDR,51,28)
     21 S HDR="  SEX: "_$E(^TMP("PSOHDR",$J,5,0),1,44)
     22 S VALMHDR(4)=HDR
     23 S $P(VALMHDR(4)," ",30)="  "_$E(^TMP("PSOHDR",$J,5,0),48,80)
     24 Q:$G(PS)="VIEW"!($G(PS)="DELETE")
     25 S VALMHDR(5)=$G(^TMP("PSOHDR",$J,9,0))
     26 S VALMHDR(6)=$G(^TMP("PSOHDR",$J,10,0))
     27 Q
     28 ;
     29NEWALL(DFN) ; Enter Allergy info.
     30 N PSOID D FULL^VALM1,EN2^GMRAPEM0,^PSOORUT2 S VALMBCK="R"
     31 Q
     32NEWSEL ;allows order selection by number instead of action
     33 S Y=$P(XQORNOD(0),"=",2) N VALMCNT D NEWSEL^PSOORNE2
     34 Q
     35EDTSEL ;allows edit selection by number instead of action - active orders
     36 N VALMCNT S Y=$P(XQORNOD(0),"=",2) D EDTSEL^PSOOREDT
     37 Q
     38SELAL ;selection of allergy by number instead of action - select allergy
     39 N VALMCNT S Y=$P(XQORNOD(0),"=",2) D SELAL^PSOORDA
     40 Q
     41EDTNEW ;allows edit selection by number instead of action - new orders
     42 N VALMCNT S Y=$P(XQORNOD(0),"=",2) D EDTSEL^PSOORNE1
     43 Q
     44EDTRNEW ;allows edit selection by number instead of action - renew orders
     45 N VALMCNT S Y=$P(XQORNOD(0),"=",2) D EDTSEL^PSOORNE4
     46 Q
     47EDTPEN ;allows edit selection by number instead of action - pending orders
     48 N VALMCNT S Y=$P(XQORNOD(0),"=",2),SEDT=1 G EDTSEL^PSOORNEW
     49 Q
     50HLDHDR ;keeps patient's header info
     51 S IOTM=VALM("TM"),IOBM=IOSL W IOSC W @IOSTBM W IORC
     52 Q
     53 ;
     54BYPASS S:$G(PSOFDR) SIGOK=1 S Y=-1,VALMBCK="Q"
     55 Q
     56ACTIONS() ;screen actions on active orders
     57 Q:$G(PKI1)=2 0
     58 N DIC,X,Y K DIC,Y S DIC="^ORD(101,"_DA(1)_",10,",X=DA,DIC(0)="ZN" D ^DIC Q:Y<0 0
     59 S Y=Y(0,0)
     60 I Y="PSO REFILL" Q $S(PSOACT["R":1,1:0)
     61 I Y="PSO RENEW" Q $S(PSOACT["N":1,1:0)
     62 I Y="PSO REPRINT" Q $S(PSOACT["P":1,1:0)
     63 I Y="PSO EDIT ORDERS" Q $S(PSOACT["E":1,1:0)
     64 I Y="PSO RELEASE" Q $S(PSOACT["L":1,1:0)
     65 I Y="PSO PARTIAL" Q $S(PSOACT["T":1,1:0)
     66 I Y="PSO CANCEL" Q $S(PSOACT["D":1,1:0)
     67 I Y="PSO HOLD" Q $S(PSOACT["H":1,1:0)
     68 I Y="PSO UNHOLD" Q $S(PSOACT["U":1,1:0)
     69 I Y="PSO LM BACKDOOR COPY" Q $S(PSOACT["C":1,1:0)
     70 I Y="PSO VERIFY" Q $S(PSOACT["V":1,1:0)
     71 I Y="PSO ACTIVITY LOGS" Q 1
     72 Q 1
     73ACTIONS1() ;screen actions on pending orders
     74 Q:$G(PKI1)=2 0
     75 N DIC,X,Y K DIC,Y S DIC="^ORD(101,"_DA(1)_",10,",X=DA,DIC(0)="ZN" D ^DIC Q:Y<0 0
     76 S Y=Y(0,0)
     77 I Y="PSO LM DISCONTINUE" Q $S(PSOACT["D":1,1:0)
     78 I Y="PSO LM EDIT" Q $S(PSOACT["E":1,1:0)
     79 I Y="PSO LM FINISH" Q $S(PSOACT["F":1,1:0)
     80 Q 1
     81PKIACT() ;screen actions on pending orders DEA/PKI proj.
     82 Q:$G(PKI1)=2 0
     83 Q 1

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLSET.m

    r613 r623  
    1 PSOLSET ;BHAM ISC/SAB - site parameter set up ;3/13/07  19:50
    2 VERS    ;;7.0;OUTPATIENT PHARMACY;**10,22,32,40,120,247,208**;DEC 1997;Build 41
    3         ; Modified from FOIA VistA
    4         ; Copyright (C) 2007 WorldVistA
    5         ;
    6         ; This program is free software; you can redistribute it and/or modify
    7         ; it under the terms of the GNU General Public License as published by
    8         ; the Free Software Foundation; either version 2 of the License, or
    9         ; (at your option) any later version.
    10         ;
    11         ; This program is distributed in the hope that it will be useful,
    12         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ; GNU General Public License for more details.
    15         ;
    16         ; You should have received a copy of the GNU General Public License
    17         ; along with this program; if not, write to the Free Software
    18         ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    19         ;Reference to ^PS(59.7 supported by DBIA 694
    20         ;Reference to ^PSX(550 supported by DBIA 2230
    21         ;Reference to ^%ZIS(2 supported by DBIA 3435
    22         ;
    23         I '$D(DUZ) W !,$C(7),"DUZ Number must be defined !!",! G LEAVE
    24         W !,"Outpatient Pharmacy software - Version "_$P($T(VERS),";",3)
    25         I $D(^XTMP("PSO_V7 INSTALL",0)) W !!,"Outpatient Pharmacy software is being installed.  PLEASE TRY LATER!",! G LEAVE
    26         S PSOBAR1="",PSOBARS=0 ;make sure we have one
    27         S PSOCNT=0 F I=0:0 S I=$O(^PS(59,I)) Q:'I  S PSOCNT=PSOCNT+1,Y=I
    28         G DIV1:PSOCNT W !,$C(7) S DIR("A",1)="Site parameters must be specified for at least one site."
    29         S DIR("A",2)="This is usually done by the package Co-ordinator.",DIR("A")="Do you want to continue:  ",DIR("B")="YES",DIR(0)="SA^Y:YES;N:NO",DIR("?")="Enter Y to edit site parameters or N to exit." D ^DIR
    30         G LEAVE:"Y"'[$E(X)
    31         W ! D ^PSOSITED G PSOLSET
    32 DIV1    G:PSOCNT=1 DIV3 S DIR(0)="Y",DIR("?")="Enter 'Y' to select Division or 'N' to EXIT"
    33 DIV2    I PSOCNT>1 W ! S DIC("A")="Division: ",DIC=59,DIC(0)="AEMQ"
    34         S:$G(PSOVEX)'=1 DIC("S")="I $S('$D(^PS(59,+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)"
    35         D ^DIC K DIC G:$D(DUOUT)!($D(DTOUT)) LEAVE
    36         I +Y<0 W $C(7),! S DIR("A",1)="A 'DIVISION' must be selected!",DIR("A")="Do you want to try again",DIR("B")="YES" D ^DIR G:'Y LEAVE G DIV2
    37 DIV3    K DIR S PSOSITE=+Y W:PSOCNT>1 !!?10,"You are logged on under the ",$P(^PS(59,PSOSITE,0),"^")," division.",! S PSOPAR=$G(^PS(59,PSOSITE,1)),PSOPAR7=$G(^PS(59,PSOSITE,"IB")),PSOSYS=$G(^PS(59.7,1,40.1)) D CUTDATE^PSOFUNC
    38         S PSOPINST=$P($G(^PS(59,PSOSITE,"INI")),"^")
    39         S (SITE,DA)=$P(^XMB(1,1,"XUS"),"^",17),DIC="4",DIQ(0)="IE",DR=".01;99",DIQ="PSXUTIL" D EN^DIQ1 S S3=$G(PSXUTIL(4,SITE,99,"I")),S2=$G(PSXUTIL(4,SITE,.01,"E")) K DA,DIC,DIQ(0),DR
    40         S PSXSYS=+$O(^PSX(550,"C",""))_"^"_$G(S3)_"^"_$G(S2),PSOINST=S3
    41         K S3,S2,S1,PSXUTIL
    42         I $G(PSXSYS) D
    43         .K:($P($G(^PSX(550,+PSXSYS,0)),"^",2)'="A") PSXSYS
    44         .S Y=$$VERSION^XPDUTL("PSO") I Y>6.0 S PSXVER=1
    45         E  K PSXSYS
    46         S PSODIV=$S(($P(PSOSYS,"^",2))&('$P(PSOSYS,"^",3)):0,1:1)
    47         I $D(DUZ),$D(^VA(200,+DUZ,0)) S PSOCLC=DUZ
    48 PLBL    I $P(PSOPAR,"^",8) D
    49         .S %ZIS="MNQ",%ZIS("A")="Select PROFILE PRINTER: " S:$G(PSOCLBL)&($D(PSOPROP)) %ZIS("B")=PSOPROP
    50         .D ^%ZIS K %ZIS,IO("Q"),IOP Q:POP  S PSOPROP=ION D ^%ZISC
    51         S PSOAFIN=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",1) ;vfah
    52         S PSOAFPFX=$S(PSOAFIN="Y":"Select LABEL PRINTER or FAX DEVICE: ",1:"Select LABEL PRINT: ") ;vfah
    53 LBL     S %ZIS="MNQ",%ZIS("A")=PSOAFPFX S:$G(PSOCLBL)&($D(PSOLAP))!($G(SUSPT)) %ZIS("B")=$S($G(SUSPT):PSLION,1:PSOLAP) ;vfah
    54         D ^%ZIS K %ZIS,IO("Q"),IOP S:POP PSOQUIT=1 G:POP EXIT S @$S($G(SUSPT):"PSLION",1:"PSOLAP")=ION,PSOPIOST=$G(IOST(0))
    55         N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
    56         S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19),PSOIOS=IOS D ^%ZISC
    57 LASK    I $G(PSOPIOST),$D(^%ZIS(2,PSOPIOST,55,"B","LL")) G EXIT
    58         ;
    59         ;vfah AutoFinish fax additions begin here
    60         K PSOAFFXP,PSOAFFXL
    61         I PSOLAP["FAX" D
    62         .S PSOAFFXP="",PSOAFFXL="",PSOAFFXR=""
    63         .S PSOLAP="AFFAX" D
    64         ..S PSOION="" S PSOION=$O(^%ZIS(1,"B",PSOLAP,PSOION))
    65         ..I $D(^DIZ(22900)) D
    66         ...S DIC="^DIZ(22900,",DIC(0)="AEQMZ",DIC("A")="SEND FAX TO: "
    67         ...D ^DIC K DIC
    68         ...I Y=-1 W !,"Invalid selection" G LBL
    69         ...S PSOAFFXL=$P(Y,"^",2)
    70         ...S PSOAFFXP=$P($G(^DIZ(22900,+Y,3)),"^",3)
    71         ...S PSOAFFXR=PSOAFFXP
    72         ...I PSOAFFXL=""!(PSOAFFXP="") G LBL
    73         I $G(PSOAFFXP)&(PSOLAP="AFFAX")'="" G EXIT
    74         ;vfah Autofinish fax additions end here
    75         ;
    76         K DIR S DIR("A")="OK to assume label alignment is correct",DIR("B")="YES",DIR(0)="Y",DIR("?")="Enter Y if labels are aligned, N if they need to be aligned." D ^DIR S:$D(DIRUT) PSOQUIT=1 G:Y!($D(DIRUT)) EXIT
    77 P2      S IOP=$G(PSOLAP) D ^%ZIS K IOP I POP W $C(7),!?5,"Printer is busy.",! G LASK
    78         U IO(0) W !,"Align labels so that a perforation is at the top of the",!,"print head and the left side is at column zero."
    79         W ! K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E" D ^DIR K DIR,DTOUT,DUOUT Q:$D(DIRUT)  D ^PSOLBLT D ^%ZISC
    80         K DIRUT,DIR S DIR("A")="Is this correct",DIR("B")="YES",DIR(0)="Y",DIR("?")="Enter Y if labels are aligned correctly, N if they need to be aligned." D ^DIR S:$D(DIRUT) PSOQUIT=1 G:Y!($D(DIRUT)) EXIT
    81         G P2
    82 LEAVE   S XQUIT="" G FINAL
    83 Q       W !?10,$C(7),"Default printer for labels must be entered." G LBL
    84         ;
    85 EXIT    D ^%ZISC Q:$G(PSOCLBL)
    86         D:'$G(PSOBFLAG) GROUP K I,IOP,X,Y,%ZIS,DIC,J,DIR,X,Y,DTOUT,DIROUT,DIRUT,DUOUT Q
    87         ;
    88 FINAL   ;exit action from main menu - kill and quit
    89         K SITE,PSOCP,PSNP,PSL,PRCA,PSLION,PSOPINST
    90         K GROUPCNT,DISGROUP,PSOCAP,PSOINST,PSOION,PSONULBL,PSOSITE7,PFIO,PSOIOS,X,Y,PSOSYS,PSODIV,PSOPAR,PSOPAR7,PSOLAP,PSOPROP,PSOCLC,PSOCNT
    91         K PSODTCUT,PSOSITE,PSOPRPAS,PSOBAR1,PSOBAR0,PSOBARS,SIG,DIR,DIRUT,DTOUT,DIROUT,DUOUT,I,%ZIS,DIC,J,PSOREL
    92         Q
    93 GROUP   ;display group
    94         S GROUPCNT=0,AGROUP="" I $D(^PS(59.3,0)) F  S AGROUP=$O(^PS(59.3,"B",AGROUP)) Q:AGROUP=""  D
    95         .S GROUPCNT=GROUPCNT+1 I GROUPCNT=1 S AGROUP1=AGROUP
    96         S:GROUPCNT=1 GRPNME=AGROUP1,II="" G:GROUPCNT>1 GROUP1
    97         Q:'$D(GRPNME)  F  S II=$O(^PS(59.3,"B",GRPNME,II)) Q:II=""  S DISGROUP=II
    98         K AGROUP,AGROUP1,GRPNME,II
    99         Q
    100 GROUP1  W ! S DIC("A")="Bingo Board Display: ",DIC=59.3,DIC(0)="AEMQZ",DIR(0)="Y",DIR("?")="Enter 'Y' to select Bingo Board Display or 'N' to EXIT"
    101         S:$P($G(^PS(59,PSOSITE,1)),"^",20) DIC("B")=$P($G(^PS(59,PSOSITE,1)),"^",20)
    102         D ^DIC K DIC Q:$D(DTOUT)!($D(DUOUT))
    103         I +Y<0 W $C(7) S DIR("A",1)="A 'BINGO BOARD DISPLAY' should be selected!",DIR("A")="Do you want to try again",DIR("B")="YES",DIR("?")="A display group must be defined in order to run Bingo Board." D ^DIR Q:"Y"'[$E(X)  G GROUP
    104         S DISGROUP=+Y
    105         K DIR,DIC,AGROUP,AGROUP1,GRPNME,II
    106         Q
     1PSOLSET ;BHAM ISC/SAB - site parameter set up ;3/13/07  19:50
     2VERS ;;7.0;OUTPATIENT PHARMACY;**10,22,32,40,120,247,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VistA
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 ;Reference to ^PS(59.7 supported by DBIA 694
     20 ;Reference to ^PSX(550 supported by DBIA 2230
     21 ;Reference to ^%ZIS(2 supported by DBIA 3435
     22 ;
     23 I '$D(DUZ) W !,$C(7),"DUZ Number must be defined !!",! G LEAVE
     24 W !,"Outpatient Pharmacy software - Version "_$P($T(VERS),";",3)
     25 I $D(^XTMP("PSO_V7 INSTALL",0)) W !!,"Outpatient Pharmacy software is being installed.  PLEASE TRY LATER!",! G LEAVE
     26 S PSOBAR1="",PSOBARS=0 ;make sure we have one
     27 S PSOCNT=0 F I=0:0 S I=$O(^PS(59,I)) Q:'I  S PSOCNT=PSOCNT+1,Y=I
     28 G DIV1:PSOCNT W !,$C(7) S DIR("A",1)="Site parameters must be specified for at least one site."
     29 S DIR("A",2)="This is usually done by the package Co-ordinator.",DIR("A")="Do you want to continue:  ",DIR("B")="YES",DIR(0)="SA^Y:YES;N:NO",DIR("?")="Enter Y to edit site parameters or N to exit." D ^DIR
     30 G LEAVE:"Y"'[$E(X)
     31 W ! D ^PSOSITED G PSOLSET
     32DIV1 G:PSOCNT=1 DIV3 S DIR(0)="Y",DIR("?")="Enter 'Y' to select Division or 'N' to EXIT"
     33DIV2 I PSOCNT>1 W ! S DIC("A")="Division: ",DIC=59,DIC(0)="AEMQ"
     34 S:$G(PSOVEX)'=1 DIC("S")="I $S('$D(^PS(59,+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)"
     35 D ^DIC K DIC G:$D(DUOUT)!($D(DTOUT)) LEAVE
     36 I +Y<0 W $C(7),! S DIR("A",1)="A 'DIVISION' must be selected!",DIR("A")="Do you want to try again",DIR("B")="YES" D ^DIR G:'Y LEAVE G DIV2
     37DIV3 K DIR S PSOSITE=+Y W:PSOCNT>1 !!?10,"You are logged on under the ",$P(^PS(59,PSOSITE,0),"^")," division.",! S PSOPAR=$G(^PS(59,PSOSITE,1)),PSOPAR7=$G(^PS(59,PSOSITE,"IB")),PSOSYS=$G(^PS(59.7,1,40.1)) D CUTDATE^PSOFUNC
     38 S PSOPINST=$P($G(^PS(59,PSOSITE,"INI")),"^")
     39 S (SITE,DA)=$P(^XMB(1,1,"XUS"),"^",17),DIC="4",DIQ(0)="IE",DR=".01;99",DIQ="PSXUTIL" D EN^DIQ1 S S3=$G(PSXUTIL(4,SITE,99,"I")),S2=$G(PSXUTIL(4,SITE,.01,"E")) K DA,DIC,DIQ(0),DR
     40 S PSXSYS=+$O(^PSX(550,"C",""))_"^"_$G(S3)_"^"_$G(S2),PSOINST=S3
     41 K S3,S2,S1,PSXUTIL
     42 I $G(PSXSYS) D
     43 .K:($P($G(^PSX(550,+PSXSYS,0)),"^",2)'="A") PSXSYS
     44 .S Y=$$VERSION^XPDUTL("PSO") I Y>6.0 S PSXVER=1
     45 E  K PSXSYS
     46 S PSODIV=$S(($P(PSOSYS,"^",2))&('$P(PSOSYS,"^",3)):0,1:1)
     47 I $D(DUZ),$D(^VA(200,+DUZ,0)) S PSOCLC=DUZ
     48PLBL I $P(PSOPAR,"^",8) D
     49 .S %ZIS="MNQ",%ZIS("A")="Select PROFILE PRINTER: " S:$G(PSOCLBL)&($D(PSOPROP)) %ZIS("B")=PSOPROP
     50 .D ^%ZIS K %ZIS,IO("Q"),IOP Q:POP  S PSOPROP=ION D ^%ZISC
     51 S PSOAFIN=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",1) ;vfah
     52 S PSOAFPFX=$S(PSOAFIN="Y":"Select LABEL PRINTER or FAX DEVICE: ",1:"Select LABEL PRINT: ") ;vfah
     53LBL S %ZIS="MNQ",%ZIS("A")=PSOAFPFX S:$G(PSOCLBL)&($D(PSOLAP))!($G(SUSPT)) %ZIS("B")=$S($G(SUSPT):PSLION,1:PSOLAP) ;vfah
     54 D ^%ZIS K %ZIS,IO("Q"),IOP S:POP PSOQUIT=1 G:POP EXIT S @$S($G(SUSPT):"PSLION",1:"PSOLAP")=ION,PSOPIOST=$G(IOST(0))
     55 N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
     56 S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19),PSOIOS=IOS D ^%ZISC
     57LASK I $G(PSOPIOST),$D(^%ZIS(2,PSOPIOST,55,"B","LL")) G EXIT
     58 ;
     59 ;vfah AutoFinish fax additions begin here
     60 K PSOAFFXP,PSOAFFXL
     61 I PSOLAP["FAX" D
     62 .S PSOAFFXP="",PSOAFFXL="",PSOAFFXR=""
     63 .S PSOLAP="AFFAX" D
     64 ..S PSOION="" S PSOION=$O(^%ZIS(1,"B",PSOLAP,PSOION))
     65 ..I $D(^DIZ(22900)) D
     66 ...S DIC="^DIZ(22900,",DIC(0)="AEQMZ",DIC("A")="SEND FAX TO: "
     67 ...D ^DIC K DIC
     68 ...I Y=-1 W !,"Invalid selection" G LBL
     69 ...S PSOAFFXL=$P(Y,"^",2)
     70 ...S PSOAFFXP=$P($G(^DIZ(22900,+Y,3)),"^",3)
     71 ...S PSOAFFXR=PSOAFFXP
     72 ...I PSOAFFXL=""!(PSOAFFXP="") G LBL
     73 I $G(PSOAFFXP)&(PSOLAP="AFFAX")'="" G EXIT
     74 ;vfah Autofinish fax additions end here
     75 ;
     76 K DIR S DIR("A")="OK to assume label alignment is correct",DIR("B")="YES",DIR(0)="Y",DIR("?")="Enter Y if labels are aligned, N if they need to be aligned." D ^DIR S:$D(DIRUT) PSOQUIT=1 G:Y!($D(DIRUT)) EXIT
     77P2 S IOP=$G(PSOLAP) D ^%ZIS K IOP I POP W $C(7),!?5,"Printer is busy.",! G LASK
     78 U IO(0) W !,"Align labels so that a perforation is at the top of the",!,"print head and the left side is at column zero."
     79 W ! K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E" D ^DIR K DIR,DTOUT,DUOUT Q:$D(DIRUT)  D ^PSOLBLT D ^%ZISC
     80 K DIRUT,DIR S DIR("A")="Is this correct",DIR("B")="YES",DIR(0)="Y",DIR("?")="Enter Y if labels are aligned correctly, N if they need to be aligned." D ^DIR S:$D(DIRUT) PSOQUIT=1 G:Y!($D(DIRUT)) EXIT
     81 G P2
     82LEAVE S XQUIT="" G FINAL
     83Q W !?10,$C(7),"Default printer for labels must be entered." G LBL
     84 ;
     85EXIT D ^%ZISC Q:$G(PSOCLBL)
     86 D:'$G(PSOBFLAG) GROUP K I,IOP,X,Y,%ZIS,DIC,J,DIR,X,Y,DTOUT,DIROUT,DIRUT,DUOUT Q
     87 ;
     88FINAL ;exit action from main menu - kill and quit
     89 K SITE,PSOCP,PSNP,PSL,PRCA,PSLION,PSOPINST
     90 K GROUPCNT,DISGROUP,PSOCAP,PSOINST,PSOION,PSONULBL,PSOSITE7,PFIO,PSOIOS,X,Y,PSOSYS,PSODIV,PSOPAR,PSOPAR7,PSOLAP,PSOPROP,PSOCLC,PSOCNT
     91 K PSODTCUT,PSOSITE,PSOPRPAS,PSOBAR1,PSOBAR0,PSOBARS,SIG,DIR,DIRUT,DTOUT,DIROUT,DUOUT,I,%ZIS,DIC,J,PSOREL
     92 Q
     93GROUP ;display group
     94 S GROUPCNT=0,AGROUP="" I $D(^PS(59.3,0)) F  S AGROUP=$O(^PS(59.3,"B",AGROUP)) Q:AGROUP=""  D
     95 .S GROUPCNT=GROUPCNT+1 I GROUPCNT=1 S AGROUP1=AGROUP
     96 S:GROUPCNT=1 GRPNME=AGROUP1,II="" G:GROUPCNT>1 GROUP1
     97 Q:'$D(GRPNME)  F  S II=$O(^PS(59.3,"B",GRPNME,II)) Q:II=""  S DISGROUP=II
     98 K AGROUP,AGROUP1,GRPNME,II
     99 Q
     100GROUP1 W ! S DIC("A")="Bingo Board Display: ",DIC=59.3,DIC(0)="AEMQZ",DIR(0)="Y",DIR("?")="Enter 'Y' to select Bingo Board Display or 'N' to EXIT"
     101 S:$P($G(^PS(59,PSOSITE,1)),"^",20) DIC("B")=$P($G(^PS(59,PSOSITE,1)),"^",20)
     102 D ^DIC K DIC Q:$D(DTOUT)!($D(DUOUT))
     103 I +Y<0 W $C(7) S DIR("A",1)="A 'BINGO BOARD DISPLAY' should be selected!",DIR("A")="Do you want to try again",DIR("B")="YES",DIR("?")="A display group must be defined in order to run Bingo Board." D ^DIR Q:"Y"'[$E(X)  G GROUP
     104 S DISGROUP=+Y
     105 K DIR,DIC,AGROUP,AGROUP1,GRPNME,II
     106 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOMAUEX.m

    r613 r623  
    1 PSOMAUEX        ;BIR/SAB-Auto expire of prescriptions ; 10/10/07 11:17am
    2         ;;7.0;OUTPATIENT PHARMACY;**40,73,139,148,257**;DEC 1997;Build 19
    3         ;;
    4         ;External reference to STATUS^ORQOR2 is supported by DBIA 3458
    5         ;External reference to ^PS(59.7 is supported by DBIA 694
    6         ;External reference to LOCK1^ORX2 and UNLK1^ORX2 are supported by DBIA 867
    7         ;
    8         I '$G(DT) S DT=$$DT^XLFDT
    9         W @IOF,!!?10," ******* Auto Expire of Prescriptions *******"
    10         W !!,"You need to run this job only if expired prescriptions are showing up as active"
    11         W !,"orders on the Orders tab in CPRS. This could be due to the following:"
    12         W !,"1. The Expire Prescriptions [PSO EXPIRE PRESCRIPTIONS] option was not"
    13         W !,"   queued as a daily task.       *****  AND *****"
    14         W !,"2. Those patient's prescription(s) were never being accessed/viewed in"
    15         W !,"   Patient Prescription Processing [PSO LM BACKDOOR ORDERS] option.",!
    16         W !,"*******************************************************************************"
    17         W !,"* For sites that have not queued the Expire Prescriptions job on their        *"
    18         W !,"* daily task schedule, you  should do so by selecting the Queue Background    *"
    19         W !,"* Jobs [PSO AUTOQUEUE JOBS] option from the Maintenance (Outpatient Pharmacy) *"
    20         W !,"* [PSO MAINTENANCE] option and in the Edit Option Schedule template make an   *"
    21         W !,"* entry for Expire Prescriptions [PSO EXPIRE PRESCRIPTIONS] option and        *"
    22         W !,"* schedule it to run daily.                                                   *"
    23         W !,"*******************************************************************************"
    24         W !!
    25         S ZZDT=$S($P($G(^PS(59.7,1,49.99)),"^",7):$P(^PS(59.7,1,49.99),"^",7),1:$P($G(^PS(59.7,1,49.99)),"^",4))
    26         I 'ZZDT D  Q  ; V7.0 inst. dt not found, quit this job
    27         .W !!!,"***** Outpatient installation date was not found, *****"
    28         .W !,"***** therefore this job cannot be run!!!!!       *****",!!
    29         ;
    30         ; - Ask for START DATE
    31         K %DT S %DT(0)=-DT,%DT="AEP",%DT("A")="Start Date: "
    32         S %DT("B")=$$FMTE^XLFDT($$FMADD^XLFDT(ZZDT\1,-121))
    33         W ! D ^%DT I Y<0!($D(DTOUT)) Q
    34         S ZZDT=Y
    35         ;
    36         K %DT D NOW^%DTC S %DT="RAEX",%DT(0)=%,%DT("A")="Select the Date/Time to queue this job: "
    37         W ! D ^%DT K %DT I $D(DTOUT)!(Y<0) W !!!?10,"Job not queued!" Q
    38         S ZTDTH=$G(Y),ZTSAVE("ZZDT")="",ZTIO="",ZTRTN="EN^PSOMAUEX",ZTDESC="Auto expire of Rxs "
    39         D ^%ZTLOAD
    40         W:$D(ZTSK) !!,"Task Queued !",!
    41         Q
    42 EN      ;
    43         N PSOSVDT
    44         S PSOSVDT=""
    45         S X1=DT,X2=-1 D C^%DTC S CDT=X  ; setting the end date to to today-1
    46         F  S ZZDT=$O(^PSRX("AG",ZZDT)) Q:'ZZDT!(ZZDT>CDT)  D EN1 S PSOSVDT=ZZDT
    47         I PSOSVDT>($P(^PS(59.7,1,49.99),"^",8)) D
    48         .S DIE=59.7,DA=1,DR="49.95///"_PSOSVDT D ^DIE K DIE,DA,DR
    49         K PSOEXRX,PSOEXSTA,ZZDT,CDT,ORN,PIFN,PSUSD,PRFDT,PDA,PSDTEST S:$D(ZTQUEUED) ZTREQ="@"
    50         Q
    51 EN1     ;
    52         F PSOEXRX=0:0 S PSOEXRX=$O(^PSRX("AG",ZZDT,PSOEXRX)) Q:'PSOEXRX  D
    53         .Q:$P($G(^PSRX(PSOEXRX,2)),"^",6)'=ZZDT
    54         .I $D(^PSRX(PSOEXRX,0)) D EN2
    55         Q
    56 EN2     ;
    57          N CPRSDC,CPRSSTA
    58         S CPRSDC=",1,7,12,13,"
    59         S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2),CPRSSTA=""
    60         I ORN S CPRSSTA=+$$STATUS^ORQOR2(ORN)
    61         S DA=PSOEXRX K CMOP D ^PSOCMOPA
    62         S DA=$O(^PS(52.5,"B",PSOEXRX,0))
    63         I DA,$P($G(^PS(52.5,DA,0)),"^",2),$P($G(^(0)),"^",3) S DIK="^PS(52.5," D ^DIK K DIK
    64         I $D(^PS(52.4,PSOEXRX,0)) S DIK="^PS(52.4,",DA=PSOEXRX D ^DIK K DIK
    65         I $G(^PSRX(PSOEXRX,"H"))]"" K:$P(^PSRX(PSOEXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOEXRX,"H"),"^"),PSOEXRX) S ^PSRX(PSOEXRX,"H")=""
    66         S PSOEXSTA=$P($G(^PSRX(PSOEXRX,"STA")),"^")
    67         ;
    68         I PSOEXSTA=11 S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) I ORN I CPRSDC'[(","_CPRSSTA_",") D
    69         .S $P(^PSRX(PSOEXRX,0),"^",19)=1
    70         .D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired")
    71         ;
    72         I PSOEXSTA=13 D  Q
    73         .I 'ORN D EN^PSOHDR("PRES",PSOEXRX)
    74         ;
    75         I PSOEXSTA>9&(PSOEXSTA'=16) Q
    76         ;
    77         I +$P($G(^PSRX(PSOEXRX,2)),"^",6),+$P($G(^(2)),"^",6)<DT D
    78         .S $P(^PSRX(PSOEXRX,"STA"),"^")=11
    79         .S (PIFN,PSUSD,PRFDT)=0
    80         .F  S PIFN=$O(^PSRX(PSOEXRX,1,PIFN)) Q:'PIFN  S PSUSD=PIFN,PRFDT=+$P($G(^PSRX(PSOEXRX,1,PIFN,0)),"^")
    81         .D REVERSE^PSOBPSU1(PSOEXRX,+PSUSD,"DE",5,"RX EXPIRED")
    82         .I $G(PSUSD),'$P($G(^PSRX(PSOEXRX,1,PSUSD,0)),"^",18) D EN3
    83         .S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) I 'ORN D EN^PSOHDR("PRES",PSOEXRX) Q
    84         .;If CPRS side already DC'd or expired, just send the expiration to the HDR
    85         .I CPRSDC[(","_CPRSSTA_",") D EN^PSOHDR("PRES",PSOEXRX) Q
    86         .S $P(^PSRX(PSOEXRX,0),"^",19)=1
    87         .D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription past expiration date")
    88         Q
    89 EN3     ;
    90         S (PSDTEST,PDA)=0 F  S PDA=$O(^PSRX(PSOEXRX,"L",PDA)) Q:'PDA  S:$P($G(^PSRX(PSOEXRX,"L",PDA,0)),"^",2)=PSUSD PSDTEST=1
    91         Q:PSDTEST
    92         I $G(CMOP(CMOP("L")))="",".L.X."[("."_$G(CMOP("S"))_".") S PSDTEST=1
    93         N PSOORL
    94         S PSOORL=$$LOCK1^ORX2(ORN) S:'PSOORL PSDTEST=1 I PSOORL D UNLK1^ORX2(ORN)
    95         N PDAQ,PDA0
    96         S PDAQ=0
    97         F PDA=0:0 S PDA=$O(^PSRX(PSOEXRX,4,PDA)) Q:'PDA  D
    98         .S PDA0=$G(^PSRX(PSOEXRX,4,PDA,0)) Q:PDA0=""
    99         .I $P(PDA0,"^",3)=PSUSD S PSDTEST=1
    100 ENX     I 'PSDTEST K ^PSRX(PSOEXRX,1,PSUSD),^PSRX("AD",PRFDT,PSOEXRX,PSUSD),^PSRX(PSOEXRX,1,"B",PRFDT,PSUSD) D NSET
    101         Q
    102 NSET    ;
    103         N PSONM,PSONMX
    104         S PSONM="" F PSONMX=0:0 S PSONMX=$O(^PSRX(PSOEXRX,1,PSONMX)) Q:'PSONMX  S PSONM=PSONMX
    105         S ^PSRX(PSOEXRX,1,0)="^52.1DA^"_$G(PSONM)_"^"_$G(PSONM)
    106         Q
     1PSOMAUEX ;BIR/SAB-Auto expire of prescriptions ;10/10/96
     2 ;;7.0;OUTPATIENT PHARMACY;**40,73,139,148**;DEC 1997
     3 ;External reference to ^PS(59.7 is supported by DBIA 694
     4 ;External reference to STATUS^ORQOR2 is supported by DBIA 3458
     5 ;
     6 I '$G(DT) S DT=$$DT^XLFDT
     7 W @IOF,!!?10," ******* Auto Expire of Prescriptions *******"
     8 W !!,"You need to run this job only if expired prescriptions are showing up as active"
     9 W !,"orders on the Orders tab in CPRS. This could be due to the following:"
     10 W !,"1. The Expire Prescriptions [PSO EXPIRE PRESCRIPTIONS] option was not"
     11 W !,"   queued as a daily task.       *****  AND *****"
     12 W !,"2. Those patient's prescription(s) were never being accessed/viewed in"
     13 W !,"   Patient Prescription Processing [PSO LM BACKDOOR ORDERS] option.",!
     14 W !,"*******************************************************************************"
     15 W !,"* For sites that have not queued the Expire Prescriptions job on their        *"
     16 W !,"* daily task schedule, you  should do so by selecting the Queue Background    *"
     17 W !,"* Jobs [PSO AUTOQUEUE JOBS] option from the Maintenance (Outpatient Pharmacy) *"
     18 W !,"* [PSO MAINTENANCE] option and in the Edit Option Schedule template make an   *"
     19 W !,"* entry for Expire Prescriptions [PSO EXPIRE PRESCRIPTIONS] option and        *"
     20 W !,"* schedule it to run daily.                                                   *"
     21 W !,"*******************************************************************************"
     22 W !!
     23 S ZZIDT=$S($P($G(^PS(59.7,1,49.99)),"^",7):$P(^PS(59.7,1,49.99),"^",7),1:$P($G(^PS(59.7,1,49.99)),"^",4))
     24 I 'ZZIDT D  Q  ; V7.0 inst. dt not found, quit this job
     25 .W !!!,"***** Outpatient installation date was not found, *****"
     26 .W !,"***** therefore this job cannot be run!!!!!       *****",!!
     27 ;
     28 ; - Ask for START DATE
     29 K %DT S %DT(0)=-DT,%DT="AEP",%DT("A")="Start Date: "
     30 S %DT("B")=$$FMTE^XLFDT($$FMADD^XLFDT(ZZIDT\1-121))
     31 W ! D ^%DT I Y<0!($D(DTOUT)) Q
     32 S ZZIDT=Y
     33 ;
     34 K %DT D NOW^%DTC S %DT="RAEX",%DT(0)=%,%DT("A")="Select the Date/Time to queue this job: "
     35 W ! D ^%DT K %DT I $D(DTOUT)!(Y<0) W !!!?10,"Job not queued!" Q
     36 S ZTDTH=$G(Y),ZTSAVE("ZZIDT")="",ZTIO="",ZTRTN="EN^PSOMAUEX",ZTDESC="Auto expire of Rxs "
     37 D ^%ZTLOAD
     38 W:$D(ZTSK) !!,"Task Queued !",!
     39 Q
     40EN S X1=ZZIDT,X2=-121 D C^%DTC S ZZDT=X  ;setting the start date to 120 days before the install date
     41 S X1=DT,X2=-1 D C^%DTC S CDT=X  ; setting the end date to todate-1
     42 F  S ZZDT=$O(^PSRX("AG",ZZDT)) Q:'ZZDT!(ZZDT>CDT)  D EN1
     43 K PSOEXRX,PSOEXSTA,ZZIDT,ZZDT,CDT,ORN,PIFN,PSUSD,PRFDT,PDA,PSDTEST S:$D(ZTQUEUED) ZTREQ="@"
     44 Q
     45EN1 ;
     46 F PSOEXRX=0:0 S PSOEXRX=$O(^PSRX("AG",ZZDT,PSOEXRX)) Q:'PSOEXRX  D
     47 .Q:$P($G(^PSRX(PSOEXRX,2)),"^",6)'=ZZDT
     48 .I $D(^PSRX(PSOEXRX,0)) D EN2
     49 Q
     50EN2 ;
     51 S DA=$O(^PS(52.5,"B",PSOEXRX,0))
     52 I DA,$P($G(^PS(52.5,DA,0)),"^",2),$P($G(^(0)),"^",3) S DIK="^PS(52.5," D ^DIK K DIK
     53 I $D(^PS(52.4,PSOEXRX,0)) S DIK="^PS(52.4,",DA=PSOEXRX D ^DIK K DIK
     54 I $G(^PSRX(PSOEXRX,"H"))]"" K:$P(^PSRX(PSOEXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOEXRX,"H"),"^"),PSOEXRX) S ^PSRX(PSOEXRX,"H")=""
     55 S PSOEXSTA=$P($G(^PSRX(PSOEXRX,"STA")),"^")
     56 I PSOEXSTA=11 D
     57 .S $P(^PSRX(PSOEXRX,0),"^",19)=1
     58 .S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2)
     59 .I ORN,+$$STATUS^ORQOR2(ORN)=6 D
     60 ..D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired")
     61 I (PSOEXSTA="")!(PSOEXSTA>9) Q
     62 ;
     63 ;get only those Rxs whoes status lies within 0 & 9
     64 I PSOEXSTA?1N,+$P($G(^PSRX(PSOEXRX,2)),"^",6),+$P($G(^(2)),"^",6)<DT D
     65 .S $P(^PSRX(PSOEXRX,"STA"),"^")=11
     66 .I $P($G(^PSRX(PSOEXRX,"OR1")),"^",2) D
     67 ..D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription past expiration date")
     68 .S (PIFN,PSUSD,PRFDT)=0
     69 .F  S PIFN=$O(^PSRX(PSOEXRX,1,PIFN)) Q:'PIFN  S PSUSD=PIFN,PRFDT=+$P($G(^PSRX(PSOEXRX,1,PIFN,0)),"^")
     70 .D REVERSE^PSOBPSU1(PSOEXRX,+PSUSD,"DE",5,"RX EXPIRED")
     71 .I $G(PSUSD),'$P($G(^PSRX(PSOEXRX,1,PSUSD,0)),"^",18) D EN3
     72 Q
     73EN3 ;
     74 S (PSDTEST,PDA)=0 F  S PDA=$O(^PSRX(PSOEXRX,"L",PDA)) Q:'PDA  S:$P($G(^PSRX(PSOEXRX,"L",PDA,0)),"^",2)=PSUSD PSDTEST=1
     75 Q:PSDTEST
     76 S DA=PSOEXRX K CMOP D ^PSOCMOPA
     77 I $G(CMOP(CMOP("L")))="",$G(CMOP("S"))="L" S PSDTEST=1
     78ENX I 'PSDTEST K ^PSRX(PSOEXRX,1,PSUSD),^PSRX("AD",PRFDT,PSOEXRX,PSUSD),^PSRX(PSOEXRX,1,"B",PRFDT,PSUSD) D NSET
     79 Q
     80NSET ;
     81 N PSONM,PSONMX
     82 S PSONM="" F PSONMX=0:0 S PSONMX=$O(^PSRX(PSOEXRX,1,PSONMX)) Q:'PSONMX  S PSONM=PSONMX
     83 S ^PSRX(PSOEXRX,1,0)="^52.1DA^"_$G(PSONM)_"^"_$G(PSONM)
     84 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOMLLD2.m

    r613 r623  
    1 PSOMLLD2        ;BIR/LE - Service Connection Check for SC>50% ;02/27/04
    2         ;;7.0;OUTPATIENT PHARMACY;**143,219,239,225**;DEC 1997;Build 29
    3         ;External reference SDC022 supported by DBIA 1579
    4         ;External reference DIS^SDROUT2 private by DBIA 112
    5         ;External reference $$GETSHAD^DGUTL3 supported by DBIA 4462
    6 SC      ;This routine is used for SC>50% - OUTSIDE OF COPAY - DFN AND PSOSCP VARIABLES ARE EXPECTED TO BE PRESENT WHEN CALLED
    7         ; Requires: DFN, PSOSCP, PSOSCA
    8         I '$G(DFN) N DFN S DFN=+$G(PSODFN)
    9         ;I $G(DFN) I '$$SC^SDCO22(DFN) D  Q  ;if SC>49 don't ask if api says not to
    10         ;. K PSOANSQ("SC>50"),PSOANSQD("SC>50") I $G(PSOX("IRXN")) K PSOANSQ(PSOX("IRXN"),"SC>50")
    11 SC2     I $G(PSOMESOI)=1,$G(PSORXED) W !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",! S PSOMESOI=2
    12         I $G(PSOMESFI)=1 W !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",! S PSOMESFI=2
    13         D DIS^SDROUT2
    14         N PSOUFLAG S PSOUFLAG=0 K DIR S DIR(0)="Y"
    15         S DIR("A")="Was treatment for a Service Connected condition"
    16         S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related",DIR("?",2)="to Service Connected."
    17         I '$G(PSOFLAG) D
    18         . I PSOSCP<50 S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"SC"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"SC"))=1:"YES",1:"") I DIR("B")="" K DIR("B") S PSOUFLAG=0
    19         . I PSOSCP<50&($D(PSORX(+$G(PSORENW("OIRXN")),"SC>50"))) S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"SC>50"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"SC>50"))=1:"YES",1:"") I DIR("B")=""  K DIR("B") S PSOUFLAG=0
    20         . I PSOSCP>49 S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"SC>50"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"SC>50"))=1:"YES",1:"") I DIR("B")=""  K DIR("B") S PSOUFLAG=0
    21         . I '$D(DIR("B"))&($D(PSOANSQD("SC>50"))!($D(PSOANSQD("SC")))) D  I '$D(DIR("B")) K DIR("B") S PSOUFLAG=0
    22         .. I $D(PSOANSQD("SC>50")) I $G(PSOANSQD("SC>50"))=0!($G(PSOANSQD("SC>50"))=1) S (PSOUFLAG,DIR("B"))=$S($G(PSOANSQD("SC>50"))=1:"YES",1:"NO")
    23         .. I $D(PSOANSQD("SC")) I $G(PSOANSQD("SC"))=0!($G(PSOANSQD("SC"))=1) S (PSOUFLAG,DIR("B"))=$S($G(PSOANSQD("SC"))=1:"YES",1:"NO")
    24         I $G(PSORX("SC"))]""!($G(PSORX(+$G(PSORENW("OIRXN")),"SC"))'="") S DIR("B")=$S($G(PSORX("SC"))="SC":"YES",$G(PSORX("SC"))="NSC":"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"SC"))=1:"YES",$G(PSORX(+$G(PSORENW("OIRXN")),"SC"))=0:"NO",1:"")
    25         ;
    26         I $G(PSOFLAG),$G(PSONEWFF) I $G(PSOANSQD("SC>50"))=0!($G(PSOANSQD("SC>50"))=1) S DIR("B")=$S($G(PSOANSQD("SC>50"))=1:"YES",1:"NO")
    27         I $G(DIR("B"))="YES"!($G(DIR("B"))="NO") S PSOUFLAG=$G(DIR("B"))
    28         I $G(DIR("B"))="" K DIR("B")
    29         W ! D ^DIR K DIR
    30         I $G(Y)=1!($G(Y)=0) D  I $G(PSONEWFF),$G(PSOFLAG) S PSOANSQD("SC>50")=$G(Y)
    31         . I $G(PSOX("IRXN")) S PSOANSQ(PSOX("IRXN"),"SC>50")=+Y
    32         . S PSOANSQ("SC>50")=+Y
    33         I PSOFLAG I Y["^"!($D(DTOUT))!($D(DUOUT)) S PSOCPZ("DFLG")=1
    34         S:Y=0 Y=2
    35         S PSOANSR=+Y I 'PSOANSR,'PSOFLAG D  S $P(PSOCPAY,"^")=$S($G(PSOUFLAG)="NO":1,1:0) W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR Q
    36         .W !!,"This Renewal has been designated as "_$S($G(PSOUFLAG)="YES":"SERVICE CONNECTED",1:"NON-SERVICE CONNECTED.")
    37         .;W !,"Please use the 'Reset Copay Status/Cancel Charges' option to make  corrections."
    38         .S PSOANSQ("SC>50")=$S($G(PSOUFLAG)="YES":1,1:0)
    39         I $G(PSOFLAG),$G(PSOCPZ("DFLG")) G EXIT
    40         S:PSOANSR=1 PSOCPAY=0 S:PSOANSR=2 $P(PSOCPAY,"^")=1
    41 EXIT    ;
    42         K PSOANSR,DIR,DUOUT,DIRUT,DTOUT,Y,X,PSOSCA
    43         Q
    44         ;
    45 PAUSE   K DIR W ! S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
    46         Q
    47         ;
    48 SHAD    ; PROJ 112/SHAD Question
    49         I $G(PSODFN),$L($T(GETSHAD^DGUTL3)) I $$GETSHAD^DGUTL3(PSODFN)'=1 D  Q
    50         . K PSOANSQ("SHAD"),PSOANSQD("SHAD") I $G(PSOX("IRXN")) K PSOANSQ(PSOX("IRXN"),"SHAD")
    51         N PSOUFLAG S PSOUFLAG=0
    52         K DIR S DIR(0)="Y"
    53         S DIR("A")="Was treatment related to PROJ 112/SHAD"
    54         S DIR("?")=" "
    55         S DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to"
    56         S DIR("?",2)="Shipboard Hazard and Defense (SHAD) exposure."
    57         S DIR("?",3)="This response will be used to determine whether or not a copay should"
    58         S DIR("?",4)="be applied to the prescription."
    59         I '$G(PSOFLAG) D
    60         . S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"SHAD"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"SHAD"))=1:"YES",1:"")
    61         . I DIR("B")="" K DIR("B") S PSOUFLAG=0
    62         I $G(PSOFLAG),$G(PSONEWFF) D
    63         . I $G(PSOANSQD("SHAD"))=0!($G(PSOANSQD("SHAD"))=1) D
    64         . . S DIR("B")=$S($G(PSOANSQD("SHAD"))=1:"YES",1:"NO")
    65         W ! D ^DIR K DIR
    66         I $G(PSOFLAG) W ! D  Q
    67         . I Y["^"!($D(DUOUT))!($G(DTOUT)) S PSOCPZ("DFLG")=1 Q
    68         . S PSOANSQ("SHAD")=Y
    69         . I $G(PSONEWFF) S PSOANSQD("SHAD")=Y
    70         I Y["^"!($D(DUOUT))!($D(DTOUT)) D  Q
    71         . W !!,"This Renewal has been designated as"_$S($G(PSOUFLAG)="YES":"",1:" NOT")_" being used for treatment of "
    72         . W !,"Shipboard Hazard and Defense (SHAD) exposure." D:$G(PSOSCP)<50 MESS^PSOMLLDT D PAUSE
    73         . S PSOANSQ(PSOX("IRXN"),"SHAD")=$S($G(PSOUFLAG)="YES":1,1:0)
    74         I $G(PSOX("IRXN")) S PSOANSQ(PSOX("IRXN"),"SHAD")=Y
    75         E  S PSOANSQ("SHAD")=Y
    76         Q
    77         ;
     1PSOMLLD2 ;BIR/LE - Service Connection Check for SC>50% ;02/27/04
     2 ;;7.0;OUTPATIENT PHARMACY;**143,219,239**;DEC 1997
     3 ;External reference SDC022 supported by DBIA 1579
     4 ;External reference DIS^SDROUT2 private by DBIA 112
     5SC ;This routine is used for SC>50% - OUTSIDE OF COPAY - DFN AND PSOSCP VARIABLES ARE EXPECTED TO BE PRESENT WHEN CALLED
     6 ; Requires: DFN, PSOSCP, PSOSCA
     7 I '$G(DFN) N DFN S DFN=+$G(PSODFN)
     8 ;I $G(DFN) I '$$SC^SDCO22(DFN) D  Q  ;if SC>49 don't ask if api says not to
     9 ;. K PSOANSQ("SC>50"),PSOANSQD("SC>50") I $G(PSOX("IRXN")) K PSOANSQ(PSOX("IRXN"),"SC>50")
     10SC2 I $G(PSOMESOI)=1,$G(PSORXED) W !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",! S PSOMESOI=2
     11 I $G(PSOMESFI)=1 W !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",! S PSOMESFI=2
     12 D DIS^SDROUT2
     13 N PSOUFLAG S PSOUFLAG=0 K DIR S DIR(0)="Y"
     14 S DIR("A")="Was treatment for a Service Connected condition"
     15 S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related",DIR("?",2)="to Service Connected."
     16 I '$G(PSOFLAG) D
     17 . I PSOSCP<50 S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"SC"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"SC"))=1:"YES",1:"") I DIR("B")="" K DIR("B") S PSOUFLAG=0
     18 . I PSOSCP<50&($D(PSORX(+$G(PSORENW("OIRXN")),"SC>50"))) S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"SC>50"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"SC>50"))=1:"YES",1:"") I DIR("B")=""  K DIR("B") S PSOUFLAG=0
     19 . I PSOSCP>49 S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"SC>50"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"SC>50"))=1:"YES",1:"") I DIR("B")=""  K DIR("B") S PSOUFLAG=0
     20 . I '$D(DIR("B"))&($D(PSOANSQD("SC>50"))!($D(PSOANSQD("SC")))) D  I '$D(DIR("B")) K DIR("B") S PSOUFLAG=0
     21 .. I $D(PSOANSQD("SC>50")) I $G(PSOANSQD("SC>50"))=0!($G(PSOANSQD("SC>50"))=1) S (PSOUFLAG,DIR("B"))=$S($G(PSOANSQD("SC>50"))=1:"YES",1:"NO")
     22 .. I $D(PSOANSQD("SC")) I $G(PSOANSQD("SC"))=0!($G(PSOANSQD("SC"))=1) S (PSOUFLAG,DIR("B"))=$S($G(PSOANSQD("SC"))=1:"YES",1:"NO")
     23 I $G(PSORX("SC"))]""!($G(PSORX(+$G(PSORENW("OIRXN")),"SC"))'="") S DIR("B")=$S($G(PSORX("SC"))="SC":"YES",$G(PSORX("SC"))="NSC":"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"SC"))=1:"YES",$G(PSORX(+$G(PSORENW("OIRXN")),"SC"))=0:"NO",1:"")
     24 ;
     25 I $G(PSOFLAG),$G(PSONEWFF) I $G(PSOANSQD("SC>50"))=0!($G(PSOANSQD("SC>50"))=1) S DIR("B")=$S($G(PSOANSQD("SC>50"))=1:"YES",1:"NO")
     26 I $G(DIR("B"))="YES"!($G(DIR("B"))="NO") S PSOUFLAG=$G(DIR("B"))
     27 I $G(DIR("B"))="" K DIR("B")
     28 W ! D ^DIR K DIR
     29 I $G(Y)=1!($G(Y)=0) D  I $G(PSONEWFF),$G(PSOFLAG) S PSOANSQD("SC>50")=$G(Y)
     30 . I $G(PSOX("IRXN")) S PSOANSQ(PSOX("IRXN"),"SC>50")=+Y
     31 . S PSOANSQ("SC>50")=+Y
     32 I PSOFLAG I Y["^"!($D(DTOUT))!($D(DUOUT)) S PSOCPZ("DFLG")=1
     33 S:Y=0 Y=2
     34 S PSOANSR=+Y I 'PSOANSR,'PSOFLAG D  S $P(PSOCPAY,"^")=$S($G(PSOUFLAG)="NO":1,1:0) W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR Q
     35 .W !!,"This Renewal has been designated as "_$S($G(PSOUFLAG)="YES":"SERVICE CONNECTED",1:"NON-SERVICE CONNECTED.")
     36 .;W !,"Please use the 'Reset Copay Status/Cancel Charges' option to make  corrections."
     37 .S PSOANSQ("SC>50")=$S($G(PSOUFLAG)="YES":1,1:0)
     38 I $G(PSOFLAG),$G(PSOCPZ("DFLG")) G EXIT
     39 S:PSOANSR=1 PSOCPAY=0 S:PSOANSR=2 $P(PSOCPAY,"^")=1
     40EXIT ;
     41 K PSOANSR,DIR,DUOUT,DIRUT,DTOUT,Y,X,PSOSCA
     42 Q
     43 ;
     44PAUSE K DIR W ! S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
     45 Q
     46 ;

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOMLLDT.m

    r613 r623  
    1 PSOMLLDT        ;BIR/RTR - Copay date routine ;08/24/01
    2         ;;7.0;OUTPATIENT PHARMACY;**71,157,143,219,278,225**;DEC 1997;Build 29
    3         ;External reference SDC022 supported by DBIA 1579
    4         ;External reference DGMSTAPI supported by DBIA2716
    5         ;CIDC: Before doing EI question, check to see if should ask ei question
    6         ; because the flag could have changed in enrollment and we shouldn't
    7         ; ask if not flagged and should set nulls for answer if Rx is renewed
    8         ; or copied when flags changed.  Also, CPRS sometimes sends zeros for
    9         ; null answers. 5/12/04
    10 DT()    ;function for Copay date
    11         ;0 means Copay not in effect, 1 means Copay in effect
    12         N PSOMILDT
    13         S PSOMILDT=3020101
    14         I '$G(DT) S DT=$$DT^XLFDT
    15         Q $S(DT<PSOMILDT:0,1:1)
    16         ;
    17         Q
    18         ;New Copay questions, require if a Renewal
    19         ;PSOFLAG=1 for New, PSOFLAG=0 for Renewal
    20 MST     ;Military Sexual Trauma Question
    21         I $G(PSODFN) I $P($$GETSTAT^DGMSTAPI(PSODFN),"^",2)'="Y" D  Q
    22         . K PSOANSQ("MST"),PSOANSQD("MST") I $G(PSOX("IRXN")) K PSOANSQ(PSOX("IRXN"),"MST")
    23         N PSOUFLAG S PSOUFLAG=0
    24         K DIR S DIR(0)="Y"
    25         S DIR("A")="Was treatment related to Military Sexual Trauma"
    26         S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related",DIR("?",2)="to Military Sexual Trauma. This response will be used to determine whether or"
    27         S DIR("?",3)="not a copay should be applied to the prescription."
    28         I '$G(PSOFLAG) S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"MST"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"MST"))=1:"YES",1:"") I DIR("B")="" K DIR("B") S PSOUFLAG=0
    29         I $G(PSOFLAG),$G(PSONEWFF) I $G(PSOANSQD("MST"))=0!($G(PSOANSQD("MST"))=1) S DIR("B")=$S($G(PSOANSQD("MST"))=1:"YES",1:"NO")
    30         W ! D ^DIR K DIR
    31         I $G(PSOFLAG) W ! D  Q
    32         .I Y["^"!($D(DUOUT))!($D(DTOUT)) S PSOCPZ("DFLG")=1 Q
    33         .S PSOANSQ("MST")=Y
    34         .I $G(PSONEWFF) S PSOANSQD("MST")=Y
    35         I Y["^"!($D(DUOUT))!($D(DTOUT)) D  W !!,"This Renewal has been designated as"_$S($G(PSOUFLAG)="YES":"",1:" NOT")_" being used for treatment of Military",!,"Sexual Trauma." D:$G(PSOSCP)<50 MESSM D PAUSE Q
    36         .S PSOANSQ(PSOX("IRXN"),"MST")=$S($G(PSOUFLAG)="YES":1,1:0)
    37         I $G(PSOX("IRXN")) S PSOANSQ(PSOX("IRXN"),"MST")=Y
    38         E  S PSOANSQ("MST")=Y
    39         Q
    40 VEH     ;Vietnam-Era Herbicide Question
    41         I $G(PSODFN) I '$$AO^SDCO22(PSODFN) D  Q
    42         . K PSOANSQ("VEH"),PSOANSQD("VEH") I $G(PSOX("IRXN")) K PSOANSQ(PSOX("IRXN"),"VEH")
    43         N PSOUFLAG S PSOUFLAG=0
    44         K DIR S DIR(0)="Y"
    45         S DIR("A")="Was treatment related to Agent Orange exposure"
    46         S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to",DIR("?",2)="Vietnam-Era Herbicide (Agent Orange) exposure. This response will be used to"
    47         S DIR("?",3)="determine whether or not a copay should be applied to the prescription."
    48         I '$G(PSOFLAG) S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"VEH"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"VEH"))=1:"YES",1:"") I DIR("B")="" K DIR("B") S PSOUFLAG=0
    49         I $G(PSOFLAG),$G(PSONEWFF) I $G(PSOANSQD("VEH"))=0!($G(PSOANSQD("VEH"))=1) S DIR("B")=$S($G(PSOANSQD("VEH"))=1:"YES",1:"NO")
    50         W ! D ^DIR K DIR
    51         I $G(PSOFLAG) W ! D  Q
    52         .I Y["^"!($D(DUOUT))!($D(DTOUT)) S PSOCPZ("DFLG")=1 Q
    53         .S PSOANSQ("VEH")=Y
    54         .I $G(PSONEWFF) S PSOANSQD("VEH")=Y
    55         I Y["^"!($D(DUOUT))!($D(DTOUT)) D  W !!,"This Renewal has been designated as"_$S($G(PSOUFLAG)="YES":"",1:" NOT")_" being used for treatment of Vietnam-Era",!,"Herbicide (Agent Orange) exposure." D:$G(PSOSCP)<50 MESSV D PAUSE Q
    56         .S PSOANSQ(PSOX("IRXN"),"VEH")=$S($G(PSOUFLAG)="YES":1,1:0)
    57         I $G(PSOX("IRXN")) S PSOANSQ(PSOX("IRXN"),"VEH")=Y
    58         E  S PSOANSQ("VEH")=Y
    59         Q
    60 RAD     ;Radiation question
    61         I $G(PSODFN) I '$$IR^SDCO22(PSODFN) D  Q
    62         . K PSOANSQ("RAD"),PSOANSQD("RAD") I $G(PSOX("IRXN")) K PSOANSQ(PSOX("IRXN"),"RAD")
    63         N PSOUFLAG S PSOUFLAG=0
    64         K DIR S DIR(0)="Y"
    65         S DIR("A")="Was treatment related to Ionizing Radiation exposure"
    66         S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to",DIR("?",2)="ionizing radiation exposure during military service. This response will be used"
    67         S DIR("?",3)="to determine whether or not a copay should be applied to the prescription."
    68         I '$G(PSOFLAG) S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"RAD"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"RAD"))=1:"YES",1:"") I DIR("B")="" K DIR("B") S PSOUFLAG=0
    69         I $G(PSOFLAG),$G(PSONEWFF) I $G(PSOANSQD("RAD"))=0!($G(PSOANSQD("RAD"))=1) S DIR("B")=$S($G(PSOANSQD("RAD"))=1:"YES",1:"NO")
    70         W ! D ^DIR K DIR
    71         I $G(PSOFLAG) W ! D  Q
    72         .I Y["^"!($D(DUOUT))!($G(DTOUT)) S PSOCPZ("DFLG")=1 Q
    73         .S PSOANSQ("RAD")=Y
    74         .I $G(PSONEWFF) S PSOANSQD("RAD")=Y
    75         I Y["^"!($D(DUOUT))!($D(DTOUT)) D  W !!,"This Renewal has been designated as"_$S($G(PSOUFLAG)="YES":"",1:" NOT")_" being used for treatment of ionizing",!,"radiation exposure." D:$G(PSOSCP)<50 MESSM D PAUSE Q
    76         .S PSOANSQ(PSOX("IRXN"),"RAD")=$S($G(PSOUFLAG)="YES":1,1:0)
    77         I $G(PSOX("IRXN")) S PSOANSQ(PSOX("IRXN"),"RAD")=Y
    78         E  S PSOANSQ("RAD")=Y
    79         Q
    80 PGW     ;Persian Gulf War question
    81         I $G(PSODFN) I '$$EC^SDCO22(PSODFN) D  Q
    82         . K PSOANSQ("PGW"),PSOANSQD("PGW") I $G(PSOX("IRXN")) K PSOANSQ(PSOX("IRXN"),"PGW")
    83         N PSOUFLAG S PSOUFLAG=0
    84         K DIR S DIR(0)="Y"
    85         S DIR("A")="Was treatment related to service in SW Asia"
    86         S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related to"
    87         S DIR("?",2)="service in Southwest Asia. This response will be used to determine whether or"
    88         S DIR("?",3)="not a copay should be applied to the prescription."
    89         I '$G(PSOFLAG) S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"PGW"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"PGW"))=1:"YES",1:"") I DIR("B")="" K DIR("B") S PSOUFLAG=0
    90         I $G(PSOFLAG),$G(PSONEWFF) I $G(PSOANSQD("PGW"))=0!($G(PSOANSQD("PGW"))=1) S DIR("B")=$S($G(PSOANSQD("PGW"))=1:"YES",1:"NO")
    91         W ! D ^DIR K DIR
    92         I $G(PSOFLAG) W ! D  Q
    93         .I Y["^"!($D(DUOUT))!($D(DTOUT)) S PSOCPZ("DFLG")=1 Q
    94         .S PSOANSQ("PGW")=Y
    95         .I $G(PSONEWFF) S PSOANSQD("PGW")=Y
    96         I Y["^"!($D(DUOUT))!($D(DTOUT)) D  W !!,"This Renewal has been designated as"_$S($G(PSOUFLAG)="YES":"",1:" NOT")_" being used for treatment of",!,"Southwest Asia Conditions exposure." D:$G(PSOSCP)<50 MESS D PAUSE Q
    97         .S PSOANSQ(PSOX("IRXN"),"PGW")=$S($G(PSOUFLAG)="YES":1,1:0)
    98         I $G(PSOX("IRXN")) S PSOANSQ(PSOX("IRXN"),"PGW")=Y
    99         E  S PSOANSQ("PGW")=Y
    100         Q
    101 HNC     ;Head or Neck Cancer question
    102         I $G(PSODFN) I $T(GETCUR^DGNTAPI)]"" N PSONCP,PSONCPX S PSONCPX=$$GETCUR^DGNTAPI(PSODFN,"PSONCP") I $P($G(PSONCP("IND")),"^")'="Y" D  Q
    103         . K PSOANSQ("HNC"),PSOANSQD("HNC") I $G(PSOX("IRXN")) K PSOANSQ(PSOX("IRXN"),"HNC")
    104         N PSOUFLAG S PSOUFLAG=0
    105         K DIR S DIR(0)="Y"
    106         S DIR("A")="Was treatment related to Head and/or Neck Cancer"
    107         S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat Head and/or Neck Cancer",DIR("?",2)="due to nose or throat radium treatments while in the military. This response"
    108         S DIR("?",3)="will be used to determine whether or not a copay should be applied to the",DIR("?",4)="prescription."
    109         I '$G(PSOFLAG) S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"HNC"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"HNC"))=1:"YES",1:"") I DIR("B")="" K DIR("B") S PSOUFLAG=0
    110         I $G(PSOFLAG),$G(PSONEWFF) I $G(PSOANSQD("HNC"))=0!($G(PSOANSQD("HNC"))=1) S DIR("B")=$S($G(PSOANSQD("HNC"))=1:"YES",1:"NO")
    111         W ! D ^DIR K DIR
    112         I $G(PSOFLAG) W ! D  Q
    113         .I Y["^"!($D(DUOUT))!($D(DTOUT)) S PSOCPZ("DFLG")=1 Q
    114         .S PSOANSQ("HNC")=Y
    115         .I $G(PSONEWFF) S PSOANSQD("HNC")=Y
    116         I Y["^"!($D(DUOUT))!($D(DTOUT)) D  W !!,"This Renewal has been designated as"_$S($G(PSOUFLAG)="YES":"",1:" NOT")_" being used for treatment related to",!,"Head and/or Neck Cancer." D:$G(PSOSCP)<50 MESSV D PAUSE Q
    117         .S PSOANSQ(PSOX("IRXN"),"HNC")=$S($G(PSOUFLAG)="YES":1,1:0)
    118         I $G(PSOX("IRXN")) S PSOANSQ(PSOX("IRXN"),"HNC")=Y
    119         E  S PSOANSQ("HNC")=Y
    120         Q
    121 CV      ; Combat Veteran Question
    122         I $G(PSODFN) I '(+$P($$CVEDT^DGCV(PSODFN),"^",3)) D  Q
    123         . K PSOANSQ("CV"),PSOANSQD("CV") I $G(PSOX("IRXN")) K PSOANSQ(PSOX("IRXN"),"CV")
    124         N PSOUFLAG S PSOUFLAG=0
    125         K DIR S DIR(0)="Y"
    126         S DIR("A")="Was treatment related to Combat"
    127         S DIR("?")=" "
    128         S DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to"
    129         S DIR("?",2)="active duty in a theater of combat operations during a period of war after the"
    130         S DIR("?",3)="Gulf War. This response will be used to determine whether or not a copay should"
    131         S DIR("?",4)="be applied to the prescription."
    132         S DIR("B")="YES"
    133         I '$G(PSOFLAG) D
    134         .  S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"CV"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"CV"))=1:"YES",1:"")
    135         .  I DIR("B")="" S (PSOUFLAG,DIR("B"))="YES"
    136         I $G(PSOFLAG),$G(PSONEWFF) D
    137         .  I $G(PSOANSQD("CV"))=0!($G(PSOANSQD("CV"))=1) D
    138         .  .  S DIR("B")=$S($G(PSOANSQD("CV"))=1:"YES",1:"NO")
    139         W ! D ^DIR K DIR
    140         I $G(PSOFLAG) W ! D  Q
    141         .  I Y["^"!($D(DUOUT))!($G(DTOUT)) S PSOCPZ("DFLG")=1 Q
    142         .  S PSOANSQ("CV")=Y
    143         .  I $G(PSONEWFF) S PSOANSQD("CV")=Y
    144         I Y["^"!($D(DUOUT))!($D(DTOUT)) D  Q
    145         .  W !!,"This Renewal has been designated as"_$S($G(PSOUFLAG)="YES":"",1:" NOT")_" being used for treatment of military"
    146         .  W !,"combat service." D:$G(PSOSCP)<50 MESSM D PAUSE
    147         .  S PSOANSQ(PSOX("IRXN"),"CV")=$S($G(PSOUFLAG)="YES":1,1:0)
    148         I $G(PSOX("IRXN")) S PSOANSQ(PSOX("IRXN"),"CV")=Y
    149         E  S PSOANSQ("CV")=Y
    150         Q
    151 PAUSE   ;
    152         K DIR W ! S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
    153         Q
    154 MESS    ;
    155         Q:$G(PSODRUG("DEA"))["S"!($G(PSODRUG("DEA"))["I")
    156         W !,"Please use the 'Reset Copay Status/Cancel Charges' option to make corrections.",!
    157         Q
    158 MESSM   ;
    159         Q:$G(PSODRUG("DEA"))["S"!($G(PSODRUG("DEA"))["I")
    160         W " Please use the 'Reset Copay Status/Cancel Charges' option",!,"to make corrections.",!
    161         Q
    162 MESSV   ;
    163         Q:$G(PSODRUG("DEA"))["S"!($G(PSODRUG("DEA"))["I")
    164         W " Please use the 'Reset Copay Status/Cancel",!,"Charges' option to make corrections.",!
     1PSOMLLDT ;BIR/RTR - Copay date routine ;08/24/01
     2 ;;7.0;OUTPATIENT PHARMACY;**71,157,143,219,278**;DEC 1997;Build 3
     3 ;External reference SDC022 supported by DBIA 1579
     4 ;External reference DGMSTAPI supported by DBIA2716
     5 ;CIDC: Before doing EI question, check to see if should ask ei question
     6 ; because the flag could have changed in enrollment and we shouldn't
     7 ; ask if not flagged and should set nulls for answer if Rx is renewed
     8 ; or copied when flags changed.  Also, CPRS sometimes sends zeros for
     9 ; null answers. 5/12/04
     10DT() ;function for Copay date
     11 ;0 means Copay not in effect, 1 means Copay in effect
     12 N PSOMILDT
     13 S PSOMILDT=3020101
     14 I '$G(DT) S DT=$$DT^XLFDT
     15 Q $S(DT<PSOMILDT:0,1:1)
     16 ;
     17 Q
     18 ;New Copay questions, require if a Renewal
     19 ;PSOFLAG=1 for New, PSOFLAG=0 for Renewal
     20MST ;Military Sexual Trauma Question
     21 I $G(PSODFN) I $P($$GETSTAT^DGMSTAPI(PSODFN),"^",2)'="Y" D  Q
     22 . K PSOANSQ("MST"),PSOANSQD("MST") I $G(PSOX("IRXN")) K PSOANSQ(PSOX("IRXN"),"MST")
     23 N PSOUFLAG S PSOUFLAG=0
     24 K DIR S DIR(0)="Y"
     25 S DIR("A")="Was treatment related to Military Sexual Trauma"
     26 S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related",DIR("?",2)="to Military Sexual Trauma. This response will be used to determine whether or"
     27 S DIR("?",3)="not a copay should be applied to the prescription."
     28 I '$G(PSOFLAG) S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"MST"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"MST"))=1:"YES",1:"") I DIR("B")="" K DIR("B") S PSOUFLAG=0
     29 I $G(PSOFLAG),$G(PSONEWFF) I $G(PSOANSQD("MST"))=0!($G(PSOANSQD("MST"))=1) S DIR("B")=$S($G(PSOANSQD("MST"))=1:"YES",1:"NO")
     30 W ! D ^DIR K DIR
     31 I $G(PSOFLAG) W ! D  Q
     32 .I Y["^"!($D(DUOUT))!($D(DTOUT)) S PSOCPZ("DFLG")=1 Q
     33 .S PSOANSQ("MST")=Y
     34 .I $G(PSONEWFF) S PSOANSQD("MST")=Y
     35 I Y["^"!($D(DUOUT))!($D(DTOUT)) D  W !!,"This Renewal has been designated as"_$S($G(PSOUFLAG)="YES":"",1:" NOT")_" being used for treatment of Military",!,"Sexual Trauma." D:$G(PSOSCP)<50 MESSM D PAUSE Q
     36 .S PSOANSQ(PSOX("IRXN"),"MST")=$S($G(PSOUFLAG)="YES":1,1:0)
     37 I $G(PSOX("IRXN")) S PSOANSQ(PSOX("IRXN"),"MST")=Y
     38 E  S PSOANSQ("MST")=Y
     39 Q
     40VEH ;Vietnam-Era Herbicide Question
     41 I $G(PSODFN) I '$$AO^SDCO22(PSODFN) D  Q
     42 . K PSOANSQ("VEH"),PSOANSQD("VEH") I $G(PSOX("IRXN")) K PSOANSQ(PSOX("IRXN"),"VEH")
     43 N PSOUFLAG S PSOUFLAG=0
     44 K DIR S DIR(0)="Y"
     45 S DIR("A")="Was treatment related to Agent Orange exposure"
     46 S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to",DIR("?",2)="Vietnam-Era Herbicide (Agent Orange) exposure. This response will be used to"
     47 S DIR("?",3)="determine whether or not a copay should be applied to the prescription."
     48 I '$G(PSOFLAG) S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"VEH"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"VEH"))=1:"YES",1:"") I DIR("B")="" K DIR("B") S PSOUFLAG=0
     49 I $G(PSOFLAG),$G(PSONEWFF) I $G(PSOANSQD("VEH"))=0!($G(PSOANSQD("VEH"))=1) S DIR("B")=$S($G(PSOANSQD("VEH"))=1:"YES",1:"NO")
     50 W ! D ^DIR K DIR
     51 I $G(PSOFLAG) W ! D  Q
     52 .I Y["^"!($D(DUOUT))!($D(DTOUT)) S PSOCPZ("DFLG")=1 Q
     53 .S PSOANSQ("VEH")=Y
     54 .I $G(PSONEWFF) S PSOANSQD("VEH")=Y
     55 I Y["^"!($D(DUOUT))!($D(DTOUT)) D  W !!,"This Renewal has been designated as"_$S($G(PSOUFLAG)="YES":"",1:" NOT")_" being used for treatment of Vietnam-Era",!,"Herbicide (Agent Orange) exposure." D:$G(PSOSCP)<50 MESSV D PAUSE Q
     56 .S PSOANSQ(PSOX("IRXN"),"VEH")=$S($G(PSOUFLAG)="YES":1,1:0)
     57 I $G(PSOX("IRXN")) S PSOANSQ(PSOX("IRXN"),"VEH")=Y
     58 E  S PSOANSQ("VEH")=Y
     59 Q
     60RAD ;Radiation question
     61 I $G(PSODFN) I '$$IR^SDCO22(PSODFN) D  Q
     62 . K PSOANSQ("RAD"),PSOANSQD("RAD") I $G(PSOX("IRXN")) K PSOANSQ(PSOX("IRXN"),"RAD")
     63 N PSOUFLAG S PSOUFLAG=0
     64 K DIR S DIR(0)="Y"
     65 S DIR("A")="Was treatment related to Ionizing Radiation exposure"
     66 S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to",DIR("?",2)="ionizing radiation exposure during military service. This response will be used"
     67 S DIR("?",3)="to determine whether or not a copay should be applied to the prescription."
     68 I '$G(PSOFLAG) S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"RAD"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"RAD"))=1:"YES",1:"") I DIR("B")="" K DIR("B") S PSOUFLAG=0
     69 I $G(PSOFLAG),$G(PSONEWFF) I $G(PSOANSQD("RAD"))=0!($G(PSOANSQD("RAD"))=1) S DIR("B")=$S($G(PSOANSQD("RAD"))=1:"YES",1:"NO")
     70 W ! D ^DIR K DIR
     71 I $G(PSOFLAG) W ! D  Q
     72 .I Y["^"!($D(DUOUT))!($G(DTOUT)) S PSOCPZ("DFLG")=1 Q
     73 .S PSOANSQ("RAD")=Y
     74 .I $G(PSONEWFF) S PSOANSQD("RAD")=Y
     75 I Y["^"!($D(DUOUT))!($D(DTOUT)) D  W !!,"This Renewal has been designated as"_$S($G(PSOUFLAG)="YES":"",1:" NOT")_" being used for treatment of ionizing",!,"radiation exposure." D:$G(PSOSCP)<50 MESSM D PAUSE Q
     76 .S PSOANSQ(PSOX("IRXN"),"RAD")=$S($G(PSOUFLAG)="YES":1,1:0)
     77 I $G(PSOX("IRXN")) S PSOANSQ(PSOX("IRXN"),"RAD")=Y
     78 E  S PSOANSQ("RAD")=Y
     79 Q
     80PGW ;Persian Gulf War question
     81 I $G(PSODFN) I '$$EC^SDCO22(PSODFN) D  Q
     82 . K PSOANSQ("PGW"),PSOANSQD("PGW") I $G(PSOX("IRXN")) K PSOANSQ(PSOX("IRXN"),"PGW")
     83 N PSOUFLAG S PSOUFLAG=0
     84 K DIR S DIR(0)="Y"
     85 S DIR("A")="Was treatment related to Environmental Contaminant exposure"
     86 S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to",DIR("?",2)="environmental contaminant exposure during the Persian Gulf War. This response"
     87 S DIR("?",3)="will be used to determine whether or not a copay should be applied to the",DIR("?",4)="prescription."
     88 I '$G(PSOFLAG) S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"PGW"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"PGW"))=1:"YES",1:"") I DIR("B")="" K DIR("B") S PSOUFLAG=0
     89 I $G(PSOFLAG),$G(PSONEWFF) I $G(PSOANSQD("PGW"))=0!($G(PSOANSQD("PGW"))=1) S DIR("B")=$S($G(PSOANSQD("PGW"))=1:"YES",1:"NO")
     90 W ! D ^DIR K DIR
     91 I $G(PSOFLAG) W ! D  Q
     92 .I Y["^"!($D(DUOUT))!($D(DTOUT)) S PSOCPZ("DFLG")=1 Q
     93 .S PSOANSQ("PGW")=Y
     94 .I $G(PSONEWFF) S PSOANSQD("PGW")=Y
     95 I Y["^"!($D(DUOUT))!($D(DTOUT)) D  W !!,"This Renewal has been designated as"_$S($G(PSOUFLAG)="YES":"",1:" NOT")_" being used for treatment of",!,"environmental contaminant exposure during the Persian Gulf War." D:$G(PSOSCP)<50 MESS D PAUSE Q
     96 .S PSOANSQ(PSOX("IRXN"),"PGW")=$S($G(PSOUFLAG)="YES":1,1:0)
     97 I $G(PSOX("IRXN")) S PSOANSQ(PSOX("IRXN"),"PGW")=Y
     98 E  S PSOANSQ("PGW")=Y
     99 Q
     100HNC ;Head or Neck Cancer question
     101 I $G(PSODFN) I $T(GETCUR^DGNTAPI)]"" N PSONCP,PSONCPX S PSONCPX=$$GETCUR^DGNTAPI(PSODFN,"PSONCP") I $P($G(PSONCP("IND")),"^")'="Y" D  Q
     102 . K PSOANSQ("HNC"),PSOANSQD("HNC") I $G(PSOX("IRXN")) K PSOANSQ(PSOX("IRXN"),"HNC")
     103 N PSOUFLAG S PSOUFLAG=0
     104 K DIR S DIR(0)="Y"
     105 S DIR("A")="Was treatment related to Head and/or Neck Cancer"
     106 S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat Head and/or Neck Cancer",DIR("?",2)="due to nose or throat radium treatments while in the military. This response"
     107 S DIR("?",3)="will be used to determine whether or not a copay should be applied to the",DIR("?",4)="prescription."
     108 I '$G(PSOFLAG) S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"HNC"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"HNC"))=1:"YES",1:"") I DIR("B")="" K DIR("B") S PSOUFLAG=0
     109 I $G(PSOFLAG),$G(PSONEWFF) I $G(PSOANSQD("HNC"))=0!($G(PSOANSQD("HNC"))=1) S DIR("B")=$S($G(PSOANSQD("HNC"))=1:"YES",1:"NO")
     110 W ! D ^DIR K DIR
     111 I $G(PSOFLAG) W ! D  Q
     112 .I Y["^"!($D(DUOUT))!($D(DTOUT)) S PSOCPZ("DFLG")=1 Q
     113 .S PSOANSQ("HNC")=Y
     114 .I $G(PSONEWFF) S PSOANSQD("HNC")=Y
     115 I Y["^"!($D(DUOUT))!($D(DTOUT)) D  W !!,"This Renewal has been designated as"_$S($G(PSOUFLAG)="YES":"",1:" NOT")_" being used for treatment related to",!,"Head and/or Neck Cancer." D:$G(PSOSCP)<50 MESSV D PAUSE Q
     116 .S PSOANSQ(PSOX("IRXN"),"HNC")=$S($G(PSOUFLAG)="YES":1,1:0)
     117 I $G(PSOX("IRXN")) S PSOANSQ(PSOX("IRXN"),"HNC")=Y
     118 E  S PSOANSQ("HNC")=Y
     119 Q
     120CV ; Combat Veteran Question
     121 I $G(PSODFN) I '(+$P($$CVEDT^DGCV(PSODFN),"^",3)) D  Q
     122 . K PSOANSQ("CV"),PSOANSQD("CV") I $G(PSOX("IRXN")) K PSOANSQ(PSOX("IRXN"),"CV")
     123 N PSOUFLAG S PSOUFLAG=0
     124 K DIR S DIR(0)="Y"
     125 S DIR("A")="Was treatment related to Combat"
     126 S DIR("?")=" "
     127 S DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to"
     128 S DIR("?",2)="active duty in a theater of combat operations during a period of war after the"
     129 S DIR("?",3)="Gulf War. This response will be used to determine whether or not a copay should"
     130 S DIR("?",4)="be applied to the prescription."
     131 S DIR("B")="YES"
     132 I '$G(PSOFLAG) D
     133 .  S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"CV"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"CV"))=1:"YES",1:"")
     134 .  I DIR("B")="" S (PSOUFLAG,DIR("B"))="YES"
     135 I $G(PSOFLAG),$G(PSONEWFF) D
     136 .  I $G(PSOANSQD("CV"))=0!($G(PSOANSQD("CV"))=1) D
     137 .  .  S DIR("B")=$S($G(PSOANSQD("CV"))=1:"YES",1:"NO")
     138 W ! D ^DIR K DIR
     139 I $G(PSOFLAG) W ! D  Q
     140 .  I Y["^"!($D(DUOUT))!($G(DTOUT)) S PSOCPZ("DFLG")=1 Q
     141 .  S PSOANSQ("CV")=Y
     142 .  I $G(PSONEWFF) S PSOANSQD("CV")=Y
     143 I Y["^"!($D(DUOUT))!($D(DTOUT)) D  Q
     144 .  W !!,"This Renewal has been designated as"_$S($G(PSOUFLAG)="YES":"",1:" NOT")_" being used for treatment of military"
     145 .  W !,"combat service." D:$G(PSOSCP)<50 MESSM D PAUSE
     146 .  S PSOANSQ(PSOX("IRXN"),"CV")=$S($G(PSOUFLAG)="YES":1,1:0)
     147 I $G(PSOX("IRXN")) S PSOANSQ(PSOX("IRXN"),"CV")=Y
     148 E  S PSOANSQ("CV")=Y
     149 Q
     150PAUSE ;
     151 K DIR W ! S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
     152 Q
     153MESS ;
     154 Q:$G(PSODRUG("DEA"))["S"!($G(PSODRUG("DEA"))["I")
     155 W !,"Please use the 'Reset Copay Status/Cancel Charges' option to make corrections.",!
     156 Q
     157MESSM ;
     158 Q:$G(PSODRUG("DEA"))["S"!($G(PSODRUG("DEA"))["I")
     159 W " Please use the 'Reset Copay Status/Cancel Charges' option",!,"to make corrections.",!
     160 Q
     161MESSV ;
     162 Q:$G(PSODRUG("DEA"))["S"!($G(PSODRUG("DEA"))["I")
     163 W " Please use the 'Reset Copay Status/Cancel",!,"Charges' option to make corrections.",!

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSON52.m

    r613 r623  
    1 PSON52  ;BIR/DSD - files new entries in prescription file ;08/09/93
    2         ;;7.0;OUTPATIENT PHARMACY;**1,16,23,27,32,46,71,111,124,117,131,139,157,143,219,148,239,201,268,260,225**;DEC 1997;Build 29
    3         ;External reference ^PS(55 supported by DBIA 2228
    4         ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
    5         ;External reference to ^XUSEC supported by DBIA 10076
    6         ;External reference SWSTAT^IBBAPI supported by DBIA 4663
    7         ;External reference SAVNDC^PSSNDCUT supported by DBIA 4707
    8 EN(PSOX)        ;Entry Point
    9 START   ;
    10         D:$D(XRTL) T0^%ZOSV ; Start RT Monitor
    11         D INIT G:PSON52("QFLG") END D NFILE Q:$G(PSONEW("DFLG"))  D PS55,DIK
    12         S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; Stop RT Monitor
    13         D FINISH
    14         I $P(^PSRX(PSOX("IRXN"),0),"^",11)="W",$G(^("IB")) S ^PSRX("ACP",$P(^PSRX(PSOX("IRXN"),0),"^",2),$P(^(2),"^",2),0,PSOX("IRXN"))=""
    15 END     D EOJ
    16         Q
    17 INIT    ;
    18         K X,%DT S:$G(PSOID) PSOX("ISSUE DATE")=PSOID
    19         S PSOX("CS")=0
    20         F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSOX("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSOX("CS"),"^",2)=1
    21         S PSON52("QFLG")=0,X1=PSOX("ISSUE DATE"),X2=PSOX("DAYS SUPPLY")*(PSOX("# OF REFILLS")+1)\1
    22         I $D(CLOZPAT) S X2=$S(X2=14:14,X2=7:7,1:X2) G DT
    23         S X2=$S(PSOX("DAYS SUPPLY")=X2:X2,+$G(PSOX("CS")):184,+$G(DEA("CS")):184,1:366)
    24         I X2<30 D
    25         . N % S %=$P($G(PSORX("PATIENT STATUS")),"^"),X2=30
    26         . S:%?.N %=$P($G(^PS(53,+%,0)),"^") I %["AUTH ABS" S X2=5
    27 DT      D C^%DTC S PSOX("STOP DATE")=$P(X,".") K X
    28         I PSOX("# OF REFILLS")>0 S X1=PSOX("FILL DATE"),X2=$S((PSOX("DAYS SUPPLY")-10\1)<1:1,1:PSOX("DAYS SUPPLY")-10\1) D C^%DTC S PSOX("NEXT POSSIBLE REFILL")=$P(X,".") K X
    29         S PSOX("TYPE OF RX")=0,PSOX("DISPENSED DATE")=PSOX("FILL DATE") D NOW^%DTC S PSOX("LOGIN DATE")=$S($P($G(OR0),"^",12):$P($G(OR0),"^",12),1:%) K %,X
    30         S PSOX("STATUS")=$S($G(PSOX("STATUS"))]"":PSOX("STATUS"),$D(PSORX("VERIFY")):1,1:0)
    31         S PSOX("COPIES")=$S($G(PSOX("COPIES"))]"":PSOX("COPIES"),1:1)
    32         I $G(PSORX("PHARM"))]"" S PSOX("PHARMACIST")=PSORX("PHARM") K PSORX("PHARM")
    33 INITX   Q
    34         ;
    35 NFILE   I $G(OR0) D  Q:$G(PSONEW("DFLG"))
    36         .D NOOR^PSONEW Q:$G(PSONEW("DFLG"))
    37         .I $G(PSOSIGFL)!($G(PSODRUG("OI"))'=$P(OR0,"^",8)) S PSONEW("CLERK CODE")=DUZ,PSONEW("REMARKS")=$G(PSONEW("REMARKS"))_" CPRS Order #"_$P(OR0,"^")_" Edited."
    38         S DIC="^PSRX(",DLAYGO=52,DIC(0)="L",X=PSOX("RX #") K DD,DO D FILE^DICN S PSOX("IRXN")=+Y K DLAYGO,X,Y,DIC,DD,DO D:+$G(DGI) TECH^PSODGDGI
    39         F PSOX1=0:1 S PSON52=$P($T(DD+PSOX1),";;",2,4) Q:PSON52=""  K PSOY S PSOY=$P(PSON52,";;") I $G(@PSOY)]"" S $P(PSON52(PSOX("IRXN"),$P(PSON52,";;",2)),"^",$P(PSON52,";;",3))=@PSOY
    40         F I=1:1:PSOX("ENT") S ^PSRX(PSOX("IRXN"),6,I,0)=PSOX("DOSE",I)_"^"_$G(PSOX("DOSE ORDERED",I))_"^"_$G(PSOX("UNITS",I))_"^"_$G(PSOX("NOUN",I))_"^" D
    41         .S ^PSRX(PSOX("IRXN"),6,I,0)=^PSRX(PSOX("IRXN"),6,I,0)_$G(PSOX("DURATION",I))_"^"_$G(PSOX("CONJUNCTION",I))_"^"_$G(PSOX("ROUTE",I))_"^"_$G(PSOX("SCHEDULE",I))_"^"_$G(PSOX("VERB",I))
    42         .I $G(PSOX("ODOSE",I))]"" S ^PSRX(PSOX("IRXN"),6,I,1)=PSOX("ODOSE",I)
    43         S ^PSRX(PSOX("IRXN"),6,0)="^52.0113^"_PSOX("ENT")_"^"_PSOX("ENT")
    44         K PSOX1,PSOY
    45         S PSOX1="" F  S PSOX1=$O(PSON52(PSOX("IRXN"),PSOX1)) Q:PSOX1=""  S ^PSRX(PSOX("IRXN"),PSOX1)=$G(PSON52(PSOX("IRXN"),PSOX1))
    46         I $O(PSOX("SIG",0)) D
    47         .S D=0 F  S D=$O(PSOX("SIG",D)) Q:'D  S ^PSRX(PSOX("IRXN"),"INS1",D,0)=PSOX("SIG",D),TP=$G(TP)+1
    48         .S ^PSRX(PSOX("IRXN"),"INS1",0)="^52.0115^"_TP_"^"_TP_"^"_DT_"^^" K TP,D
    49         I $G(PSOX("SINS"))]"" S ^PSRX(PSOX("IRXN"),"INSS")=PSOX("SINS")
    50         I $G(SIGOK) D
    51         .S $P(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1,^PSRX(PSOX("IRXN"),"SIG1",0)="^52.04A^^"
    52         .S D=0 F  S D=$O(SIG(D)) Q:'D  S ^PSRX(PSOX("IRXN"),"SIG1",D,0)=SIG(D),$P(^PSRX(PSOX("IRXN"),"SIG1",0),"^",3)=+$P(^PSRX(PSOX("IRXN"),"SIG1",0),"^",3)+1,$P(^(0),"^",4)=+$P(^(0),"^",4)+1 Q:'$O(SIG(D))
    53         .K SIG
    54         I $D(PSOINSFL) S ^PSRX(PSOX("IRXN"),"A",0)="^52.3DA^1^1",^PSRX(PSOX("IRXN"),"A",1,0)=DT_"^G^^0^Patient Instructions "_$S(PSOINSFL=1:"",1:"Not ")_"Sent By Provider."
    55         I $G(OR0) S:$P(OR0,"^",24) ^PSRX(PSOX("IRXN"),"PKI")=1
    56         K PSOX1,PSOFINFL,HLDSIG,D,PSOINSFL,D
    57         D:$G(^TMP("PSODAI",$J,0))
    58         .S $P(^PSRX(PSOX("IRXN"),3),"^",6)=1
    59         .I $O(^TMP("PSODAI",$J,0)) S DAI=0 F  S DAI=$O(^TMP("PSODAI",$J,DAI)) Q:'DAI  D
    60         ..S:'$D(^PSRX(PSOX("IRXN"),"DAI",0)) ^PSRX(PSOX("IRXN"),"DAI",0)="^52.03^^" S ^PSRX(PSOX("IRXN"),"DAI",DAI,0)=^TMP("PSODAI",$J,DAI,0)
    61         ..S $P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)=+$P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)+1,$P(^(0),"^",4)=+$P(^(0),"^",4)+1
    62         .K ^TMP("PSODAI",$J),DAI
    63         I $G(PSOX("CHCS NUMBER"))'="" S $P(^PSRX(PSOX("IRXN"),"EXT"),"^")=$G(PSOX("CHCS NUMBER"))
    64         I $G(PSOX("EXTERNAL SYSTEM"))'="" S $P(^PSRX(PSOX("IRXN"),"EXT"),"^",2)=$G(PSOX("EXTERNAL SYSTEM"))
    65         I $G(PSOX("NEWCOPAY")) S ^PSRX(PSOX("IRXN"),"IB")=$G(PSOX("NEWCOPAY"))
    66         ;Next line, set SC question based on Copay status?
    67 IBQ     ;I $G(PSOBILL)=2 S ^PSRX(PSOX("IRXN"),"IBQ")=$S($G(PSOX("NEWCOPAY")):0,1:1)
    68         N PSOSCFLD S PSOSCFLD=$S(PSOSCP'="":$G(PSOANSQ("SC")),1:"")_"^"_$G(PSOANSQ("MST"))_"^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$G(PSOANSQ("PGW"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV"))_"^"_$G(PSOANSQ("SHAD"))
    69         I PSOSCP<50&($TR(PSOSCFLD,"^")'="")&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1) D
    70         . S ^PSRX(PSOX("IRXN"),"IBQ")=PSOSCFLD K PSOSCFLD  ;don't set if SC % is null or 0, just set it in ICD node
    71         D ICD^PSODIAG
    72         D:$$SWSTAT^IBBAPI() GACT^PSOPFSU0(PSOX("IRXN"),0)
    73         K PSOANSQ,PSOANSQD,PSOX("NEWCOPAY")
    74         L -^PSRX("B",PSOX("IRXN"))
    75         Q
    76         ;
    77 PS55    ;
    78         L +^PS(55,PSODFN,"P"):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
    79         S:'$D(^PS(55,PSODFN,"P",0)) ^(0)="^55.03PA^^"
    80         F PSOX1=$P(^PS(55,PSODFN,"P",0),"^",3):1 Q:'$D(^PS(55,PSODFN,"P",PSOX1))
    81         S PSOX("55 IEN")=PSOX1
    82         S ^PS(55,PSODFN,"P",PSOX1,0)=PSOX("IRXN"),$P(^PS(55,PSODFN,"P",0),"^",3,4)=PSOX1_"^"_($P(^PS(55,PSODFN,"P",0),"^",4)+1)
    83         S ^PS(55,PSODFN,"P","A",PSONEW("STOP DATE"),PSOX("IRXN"))=""
    84 PS55X   L -^PS(55,PSODFN,"P")
    85         K PSOX1
    86         Q
    87 DIK     ;
    88         I $D(^XUSEC("PSORPH",DUZ)) S DA=PSOX("IRXN"),DIE=52,DR="41////"_PSOCOU_";S:'X Y=""@1"";42////"_PSOCOUU_";@1" D ^DIE K DIE,DR
    89         K DIK,DA S DIK="^PSRX(",DA=PSOX("IRXN") D IX1^DIK K DIK
    90         S DA=PSOX("IRXN") D ORC^PSORN52C
    91         Q
    92 FINISH  ;
    93 ANQ     I $G(ANQDATA)]"" D NOW^%DTC G:$D(^PS(52.52,"B",%)) ANQ D
    94         .K DD,DO S DIC="^PS(52.52,",DIC(0)="L",DLAYGO=52.52,X=% D FILE^DICN K DIC,DLAYGO,DD,DO
    95         .S ^PS(52.52,+Y,0)=$P(Y,"^",2)_"^"_PSOX("IRXN")_"^"_ANQDATA,^PS(52.52,"A",PSOX("IRXN"),+Y)="" K ANQDATA,X,Y,%,ANQREM
    96         G:PSOX("STATUS")=4 FINISHP
    97         I $D(PSORX("VERIFY")) D  G FINISHX
    98         .K DIC,DLAYGO,DINUM,DIADD,X,DD,DO S DIC="^PS(52.4,",DLAYGO=52.4,DINUM=PSOX("IRXN"),DIC(0)="ML",X=PSOX("IRXN")
    99         .D FILE^DICN K DD,DO,DIC,DLAYGO,DINUM S ^PS(52.4,PSOX("IRXN"),0)=PSOX("IRXN")_"^"_PSODFN_"^"_DUZ_"^"_"^"_$E(PSOX("LOGIN DATE"),1,7)_"^"_PSOX("IRXN")_"^"_PSOX("STOP DATE")
    100         .K DIK,DA S DIK="^PS(52.4,",DA=PSOX("IRXN") D IX^DIK K DIK,DA
    101         ;
    102         I PSOX("FILL DATE")>DT,$P(PSOPAR,"^",6) S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=0 D SUS^PSORXL K DA G FINISHX
    103         ;
    104         ; - Calling ECME for claims generation and transmission / REJECT handling
    105         N ACTION,PSOERX
    106         S PSOERX=PSOX("IRXN")
    107         I $$SUBMIT^PSOBPSUT(PSOERX,0) D  I ACTION="Q"!(ACTION="^") Q
    108         . S ACTION="" D ECMESND^PSOBPSU1(PSOERX,0,PSOX("FILL DATE"),"OF")
    109         . I $$FIND^PSOREJUT(PSOERX,0) D
    110         . . S ACTION=$$HDLG^PSOREJU1(PSOERX,0,"79,88","OF","IOQ","I")
    111         . I $$STATUS^PSOBPSUT(PSOERX,0)="E PAYABLE" D
    112         . . D SAVNDC^PSSNDCUT(+$$GET1^DIQ(52,PSOERX,6,"I"),$G(PSOSITE),$$GETNDC^PSONDCUT(PSOERX,0))
    113         ;
    114 FINISHP ;
    115         I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSOX("IRXN")_",",RXFL(PSOX("IRXN"))=0 G FINISHX
    116         F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
    117         I $L(PSORX("PSOL",PSOX2))+$L(PSOX("IRXN"))<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSOX("IRXN")_","
    118         E  S PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_","
    119         S RXFL(PSOX("IRXN"))=0
    120 FINISHX ;call to build Rx array for bingo board
    121         I $G(PSORX("MAIL/WINDOW"))["W" S BINGCRT=1,BINGRTE="W",BBFLG=1 D BBRX^PSORN52C
    122         K PSOX1,PSOX2
    123         Q
    124 EOJ     ;
    125         ;B xref locked in routine PSONRXN
    126         L -^PSRX("B",PSOX("IRXN")) K OTHDOS,DA,PSON52,PSOPRC,RTE,SCH,PSOX("INS"),PSONEW("INS"),PSORXED("INS"),PSONEW("ENT"),PSORXED("ENT"),OLENT
    127         D PSOUL^PSSLOCK(PSOX("IRXN"))
    128         Q
    129         ;
    130         ;;PSOX("SIG");;SIG;;1
    131 DD      ;;PSOX("RX #");;0;;1
    132         ;;PSOX("ISSUE DATE");;0;;13
    133         ;;PSODFN;;0;;2
    134         ;;PSOX("PATIENT STATUS");;0;;3
    135         ;;PSOX("PROVIDER");;0;;4
    136         ;;PSOX("CLINIC");;0;;5
    137         ;;PSODRUG("IEN");;0;;6
    138         ;;PSODRUG("TRADE NAME");;TN;;1
    139         ;;PSOX("QTY");;0;;7
    140         ;;PSOX("DAYS SUPPLY");;0;;8
    141         ;;PSOX("# OF REFILLS");;0;;9
    142         ;;PSOX("COPIES");;0;;18
    143         ;;PSOX("MAIL/WINDOW");;0;;11
    144         ;;PSOX("REMARKS");;3;;7
    145         ;;PSOX("CLERK CODE");;0;;16
    146         ;;PSODRUG("COST");;0;;17
    147         ;;PSOSITE;;2;;9
    148         ;;PSOX("LOGIN DATE");;2;;1
    149         ;;PSOX("FILL DATE");;2;;2
    150         ;;PSOX("PHARMACIST");;2;;3
    151         ;;PSOX("LOT #");;2;;4
    152         ;;PSOX("DISPENSED DATE");;2;;5
    153         ;;PSOX("STOP DATE");;2;;6
    154         ;;PSODRUG("NDC");;2;;7
    155         ;;PSODRUG("DAW");;EPH;;1
    156         ;;PSODRUG("MANUFACTURER");;2;;8
    157         ;;PSOX("EXPIRATION DATE");;2;;11
    158         ;;PSOX("GENERIC PROVIDER");;2;;12
    159         ;;PSOX("RELEASED DATE/TIME");;2;;13
    160         ;;PSOX("METHOD OF PICK-UP");;MP;;1
    161         ;;PSOX("STATUS");;STA;;1
    162         ;;PSOX("LAST DISPENSED DATE");;3;;1
    163         ;;PSOX("NEXT POSSIBLE REFILL");;3;;2
    164         ;;PSOX("COSIGNING PROVIDER");;3;;3
    165         ;;PSOX("TYPE OF RX");;TYPE;;1
    166         ;;PSOX("SAND");;SAND;;1
    167         ;;PSOX("POE");;POE;;1
    168         ;;PSOX("INS");;INS;;1
     1PSON52 ;BIR/DSD - files new entries in prescription file ;08/09/93
     2 ;;7.0;OUTPATIENT PHARMACY;**1,16,23,27,32,46,71,111,124,117,131,139,157,143,219,148,239,201,268,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 ;External reference ^PS(55 supported by DBIA 2228
     20 ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
     21 ;External reference to ^XUSEC supported by DBIA 10076
     22 ;External reference SWSTAT^IBBAPI supported by DBIA 4663
     23EN(PSOX) ;Entry Point
     24START ;
     25 D:$D(XRTL) T0^%ZOSV ; Start RT Monitor
     26 D INIT G:PSON52("QFLG") END D NFILE Q:$G(PSONEW("DFLG"))  D PS55,DIK
     27 S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; Stop RT Monitor
     28 D FINISH
     29 I $P(^PSRX(PSOX("IRXN"),0),"^",11)="W",$G(^("IB")) S ^PSRX("ACP",$P(^PSRX(PSOX("IRXN"),0),"^",2),$P(^(2),"^",2),0,PSOX("IRXN"))=""
     30END D EOJ
     31 Q
     32INIT ;
     33 K X,%DT S:$G(PSOID) PSOX("ISSUE DATE")=PSOID
     34 S PSOX("CS")=0
     35 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSOX("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSOX("CS"),"^",2)=1
     36 S PSON52("QFLG")=0,X1=PSOX("ISSUE DATE"),X2=PSOX("DAYS SUPPLY")*(PSOX("# OF REFILLS")+1)\1
     37 I $D(CLOZPAT) S X2=$S(X2=14:14,X2=7:7,1:X2) G DT
     38 S X2=$S(PSOX("DAYS SUPPLY")=X2:X2,+$G(PSOX("CS")):184,+$G(DEA("CS")):184,1:366)
     39 I X2<30 D
     40 . N % S %=$P($G(PSORX("PATIENT STATUS")),"^"),X2=30
     41 . S:%?.N %=$P($G(^PS(53,+%,0)),"^") I %["AUTH ABS" S X2=5
     42DT D C^%DTC S PSOX("STOP DATE")=$P(X,".") K X
     43 I PSOX("# OF REFILLS")>0 S X1=PSOX("FILL DATE"),X2=$S((PSOX("DAYS SUPPLY")-10\1)<1:1,1:PSOX("DAYS SUPPLY")-10\1) D C^%DTC S PSOX("NEXT POSSIBLE REFILL")=$P(X,".") K X
     44 S PSOX("TYPE OF RX")=0,PSOX("DISPENSED DATE")=PSOX("FILL DATE") D NOW^%DTC S PSOX("LOGIN DATE")=$S($P($G(OR0),"^",12):$P($G(OR0),"^",12),1:%) K %,X
     45 S PSOX("STATUS")=$S($G(PSOX("STATUS"))]"":PSOX("STATUS"),$D(PSORX("VERIFY")):1,1:0)
     46 S PSOX("COPIES")=$S($G(PSOX("COPIES"))]"":PSOX("COPIES"),1:1)
     47 I $G(PSORX("PHARM"))]"" S PSOX("PHARMACIST")=PSORX("PHARM") K PSORX("PHARM")
     48INITX Q
     49 ;
     50NFILE I $G(OR0) D  Q:$G(PSONEW("DFLG"))
     51 .D NOOR^PSONEW Q:$G(PSONEW("DFLG"))
     52 .I $G(PSOSIGFL)!($G(PSODRUG("OI"))'=$P(OR0,"^",8)) S PSONEW("CLERK CODE")=DUZ,PSONEW("REMARKS")=$G(PSONEW("REMARKS"))_" CPRS Order #"_$P(OR0,"^")_" Edited."
     53 S DIC="^PSRX(",DLAYGO=52,DIC(0)="L",X=PSOX("RX #") K DD,DO D FILE^DICN S PSOX("IRXN")=+Y K DLAYGO,X,Y,DIC,DD,DO D:+$G(DGI) TECH^PSODGDGI
     54 F PSOX1=0:1 S PSON52=$P($T(DD+PSOX1),";;",2,4) Q:PSON52=""  K PSOY S PSOY=$P(PSON52,";;") I $G(@PSOY)]"" S $P(PSON52(PSOX("IRXN"),$P(PSON52,";;",2)),"^",$P(PSON52,";;",3))=@PSOY
     55 F I=1:1:PSOX("ENT") S ^PSRX(PSOX("IRXN"),6,I,0)=PSOX("DOSE",I)_"^"_$G(PSOX("DOSE ORDERED",I))_"^"_$G(PSOX("UNITS",I))_"^"_$G(PSOX("NOUN",I))_"^" D
     56 .S ^PSRX(PSOX("IRXN"),6,I,0)=^PSRX(PSOX("IRXN"),6,I,0)_$G(PSOX("DURATION",I))_"^"_$G(PSOX("CONJUNCTION",I))_"^"_$G(PSOX("ROUTE",I))_"^"_$G(PSOX("SCHEDULE",I))_"^"_$G(PSOX("VERB",I))
     57 .I $G(PSOX("ODOSE",I))]"" S ^PSRX(PSOX("IRXN"),6,I,1)=PSOX("ODOSE",I)
     58 S ^PSRX(PSOX("IRXN"),6,0)="^52.0113^"_PSOX("ENT")_"^"_PSOX("ENT")
     59 K PSOX1,PSOY
     60 S PSOX1="" F  S PSOX1=$O(PSON52(PSOX("IRXN"),PSOX1)) Q:PSOX1=""  S ^PSRX(PSOX("IRXN"),PSOX1)=$G(PSON52(PSOX("IRXN"),PSOX1))
     61 I $O(PSOX("SIG",0)) D
     62 .S D=0 F  S D=$O(PSOX("SIG",D)) Q:'D  S ^PSRX(PSOX("IRXN"),"INS1",D,0)=PSOX("SIG",D),TP=$G(TP)+1
     63 .S ^PSRX(PSOX("IRXN"),"INS1",0)="^52.0115^"_TP_"^"_TP_"^"_DT_"^^" K TP,D
     64 I $G(PSOX("SINS"))]"" S ^PSRX(PSOX("IRXN"),"INSS")=PSOX("SINS")
     65 I $G(SIGOK) D
     66 .S $P(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1,^PSRX(PSOX("IRXN"),"SIG1",0)="^52.04A^^"
     67 .S D=0 F  S D=$O(SIG(D)) Q:'D  S ^PSRX(PSOX("IRXN"),"SIG1",D,0)=SIG(D),$P(^PSRX(PSOX("IRXN"),"SIG1",0),"^",3)=+$P(^PSRX(PSOX("IRXN"),"SIG1",0),"^",3)+1,$P(^(0),"^",4)=+$P(^(0),"^",4)+1 Q:'$O(SIG(D))
     68 .K SIG
     69 I $D(PSOINSFL) S ^PSRX(PSOX("IRXN"),"A",0)="^52.3DA^1^1",^PSRX(PSOX("IRXN"),"A",1,0)=DT_"^G^^0^Patient Instructions "_$S(PSOINSFL=1:"",1:"Not ")_"Sent By Provider."
     70 I $G(OR0) S:$P(OR0,"^",24) ^PSRX(PSOX("IRXN"),"PKI")=1
     71 K PSOX1,PSOFINFL,HLDSIG,D,PSOINSFL,D
     72 D:$G(^TMP("PSODAI",$J,0))
     73 .S $P(^PSRX(PSOX("IRXN"),3),"^",6)=1
     74 .I $O(^TMP("PSODAI",$J,0)) S DAI=0 F  S DAI=$O(^TMP("PSODAI",$J,DAI)) Q:'DAI  D
     75 ..S:'$D(^PSRX(PSOX("IRXN"),"DAI",0)) ^PSRX(PSOX("IRXN"),"DAI",0)="^52.03^^" S ^PSRX(PSOX("IRXN"),"DAI",DAI,0)=^TMP("PSODAI",$J,DAI,0)
     76 ..S $P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)=+$P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)+1,$P(^(0),"^",4)=+$P(^(0),"^",4)+1
     77 .K ^TMP("PSODAI",$J),DAI
     78 I $G(PSOX("CHCS NUMBER"))'="" S $P(^PSRX(PSOX("IRXN"),"EXT"),"^")=$G(PSOX("CHCS NUMBER"))
     79 I $G(PSOX("EXTERNAL SYSTEM"))'="" S $P(^PSRX(PSOX("IRXN"),"EXT"),"^",2)=$G(PSOX("EXTERNAL SYSTEM"))
     80 I $G(PSOX("NEWCOPAY")) S ^PSRX(PSOX("IRXN"),"IB")=$G(PSOX("NEWCOPAY"))
     81 ;Next line, set SC question based on Copay status?
     82IBQ ;I $G(PSOBILL)=2 S ^PSRX(PSOX("IRXN"),"IBQ")=$S($G(PSOX("NEWCOPAY")):0,1:1)
     83 I $G(PSOAFYN)="Y" S PSOSCP="" ;vfah
     84 N PSOSCFLD S PSOSCFLD=$S(PSOSCP'="":$G(PSOANSQ("SC")),1:"")_"^"_$G(PSOANSQ("MST"))_"^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$G(PSOANSQ("PGW"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV"))
     85 I PSOSCP<50&($TR(PSOSCFLD,"^")'="")&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1) D
     86 . S ^PSRX(PSOX("IRXN"),"IBQ")=PSOSCFLD K PSOSCFLD  ;don't set if SC % is null or 0, just set it in ICD node
     87 D ICD^PSODIAG
     88 D:$$SWSTAT^IBBAPI() GACT^PSOPFSU0(PSOX("IRXN"),0)
     89 K PSOANSQ,PSOANSQD,PSOX("NEWCOPAY")
     90 L -^PSRX("B",PSOX("IRXN"))
     91 Q
     92 ;
     93PS55 ;
     94 L +^PS(55,PSODFN,"P"):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
     95 S:'$D(^PS(55,PSODFN,"P",0)) ^(0)="^55.03PA^^"
     96 F PSOX1=$P(^PS(55,PSODFN,"P",0),"^",3):1 Q:'$D(^PS(55,PSODFN,"P",PSOX1))
     97 S PSOX("55 IEN")=PSOX1
     98 S ^PS(55,PSODFN,"P",PSOX1,0)=PSOX("IRXN"),$P(^PS(55,PSODFN,"P",0),"^",3,4)=PSOX1_"^"_($P(^PS(55,PSODFN,"P",0),"^",4)+1)
     99 S ^PS(55,PSODFN,"P","A",PSONEW("STOP DATE"),PSOX("IRXN"))=""
     100PS55X L -^PS(55,PSODFN,"P")
     101 K PSOX1
     102 Q
     103DIK ;
     104 I $D(^XUSEC("PSORPH",DUZ)) S DA=PSOX("IRXN"),DIE=52,DR="41////"_PSOCOU_";S:'X Y=""@1"";42////"_PSOCOUU_";@1" D ^DIE K DIE,DR
     105 K DIK,DA S DIK="^PSRX(",DA=PSOX("IRXN") D IX1^DIK K DIK
     106 S DA=PSOX("IRXN") D ORC^PSORN52C
     107 Q
     108FINISH ;
     109ANQ I $G(ANQDATA)]"" D NOW^%DTC G:$D(^PS(52.52,"B",%)) ANQ D
     110 .K DD,DO S DIC="^PS(52.52,",DIC(0)="L",DLAYGO=52.52,X=% D FILE^DICN K DIC,DLAYGO,DD,DO
     111 .S ^PS(52.52,+Y,0)=$P(Y,"^",2)_"^"_PSOX("IRXN")_"^"_ANQDATA,^PS(52.52,"A",PSOX("IRXN"),+Y)="" K ANQDATA,X,Y,%,ANQREM
     112 G:PSOX("STATUS")=4 FINISHP
     113 I $D(PSORX("VERIFY")) D  G FINISHX
     114 .K DIC,DLAYGO,DINUM,DIADD,X,DD,DO S DIC="^PS(52.4,",DLAYGO=52.4,DINUM=PSOX("IRXN"),DIC(0)="ML",X=PSOX("IRXN")
     115 .D FILE^DICN K DD,DO,DIC,DLAYGO,DINUM S ^PS(52.4,PSOX("IRXN"),0)=PSOX("IRXN")_"^"_PSODFN_"^"_DUZ_"^"_"^"_$E(PSOX("LOGIN DATE"),1,7)_"^"_PSOX("IRXN")_"^"_PSOX("STOP DATE")
     116 .K DIK,DA S DIK="^PS(52.4,",DA=PSOX("IRXN") D IX^DIK K DIK,DA
     117 ;
     118 I PSOX("FILL DATE")>DT,$P(PSOPAR,"^",6) S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=0 D SUS^PSORXL K DA G FINISHX
     119 ;
     120 ; - Calling ECME for claims generation and transmission / REJECT handling
     121 N ACTION
     122 I $$SUBMIT^PSOBPSUT(PSOX("IRXN"),0) D  I ACTION="Q"!(ACTION="^") Q
     123 . S ACTION="" D ECMESND^PSOBPSU1(PSOX("IRXN"),0,PSOX("FILL DATE"),"OF")
     124 . I $$FIND^PSOREJUT(PSOX("IRXN"),0) D
     125 . . S ACTION=$$HDLG^PSOREJU1(PSOX("IRXN"),0,"79,88","OF","IOQ","I")
     126 ;
     127FINISHP ;
     128 I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSOX("IRXN")_",",RXFL(PSOX("IRXN"))=0 G FINISHX
     129 F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
     130 I $L(PSORX("PSOL",PSOX2))+$L(PSOX("IRXN"))<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSOX("IRXN")_","
     131 E  S PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_","
     132 S RXFL(PSOX("IRXN"))=0
     133FINISHX ;call to build Rx array for bingo board
     134 I $G(PSORX("MAIL/WINDOW"))["W" S BINGCRT=1,BINGRTE="W",BBFLG=1 D BBRX^PSORN52C
     135 K PSOX1,PSOX2
     136 Q
     137EOJ ;
     138 ;B xref locked in routine PSONRXN
     139 L -^PSRX("B",PSOX("IRXN")) K OTHDOS,DA,PSON52,PSOPRC,RTE,SCH,PSOX("INS"),PSONEW("INS"),PSORXED("INS"),PSONEW("ENT"),PSORXED("ENT"),OLENT
     140 D PSOUL^PSSLOCK(PSOX("IRXN"))
     141 Q
     142 ;
     143 ;;PSOX("SIG");;SIG;;1
     144DD ;;PSOX("RX #");;0;;1
     145 ;;PSOX("ISSUE DATE");;0;;13
     146 ;;PSODFN;;0;;2
     147 ;;PSOX("PATIENT STATUS");;0;;3
     148 ;;PSOX("PROVIDER");;0;;4
     149 ;;PSOX("CLINIC");;0;;5
     150 ;;PSODRUG("IEN");;0;;6
     151 ;;PSODRUG("TRADE NAME");;TN;;1
     152 ;;PSOX("QTY");;0;;7
     153 ;;PSOX("DAYS SUPPLY");;0;;8
     154 ;;PSOX("# OF REFILLS");;0;;9
     155 ;;PSOX("COPIES");;0;;18
     156 ;;PSOX("MAIL/WINDOW");;0;;11
     157 ;;PSOX("REMARKS");;3;;7
     158 ;;PSOX("CLERK CODE");;0;;16
     159 ;;PSODRUG("COST");;0;;17
     160 ;;PSOSITE;;2;;9
     161 ;;PSOX("LOGIN DATE");;2;;1
     162 ;;PSOX("FILL DATE");;2;;2
     163 ;;PSOX("PHARMACIST");;2;;3
     164 ;;PSOX("LOT #");;2;;4
     165 ;;PSOX("DISPENSED DATE");;2;;5
     166 ;;PSOX("STOP DATE");;2;;6
     167 ;;PSODRUG("NDC");;2;;7
     168 ;;PSODRUG("DAW");;EPH;;1
     169 ;;PSODRUG("MANUFACTURER");;2;;8
     170 ;;PSOX("EXPIRATION DATE");;2;;11
     171 ;;PSOX("GENERIC PROVIDER");;2;;12
     172 ;;PSOX("RELEASED DATE/TIME");;2;;13
     173 ;;PSOX("METHOD OF PICK-UP");;MP;;1
     174 ;;PSOX("STATUS");;STA;;1
     175 ;;PSOX("LAST DISPENSED DATE");;3;;1
     176 ;;PSOX("NEXT POSSIBLE REFILL");;3;;2
     177 ;;PSOX("COSIGNING PROVIDER");;3;;3
     178 ;;PSOX("TYPE OF RX");;TYPE;;1
     179 ;;PSOX("SAND");;SAND;;1
     180 ;;PSOX("POE");;POE;;1
     181 ;;PSOX("INS");;INS;;1

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEW.m

    r613 r623  
    1 PSONEW  ;BIR/SAB-new rx order main driver ;07/26/96
    2         ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,94,130,268,225**;DEC 1997;Build 29
    3         ;External references L and UL^PSSLOCK supported by DBIA 2789
    4         ;External reference to ^VA(200 supported by DBIA 224
    5         ;External reference to ^XUSEC supported by DBIA 10076
    6         ;External reference to ^ORX1 supported by DBIA 2186
    7         ;External reference to ^ORX2 supported by DBIA 867
    8         ;External reference to ^TIUEDIT supported by DBIA 2410
    9         ;---------------------------------------------------------------
    10 OERR    ;backdoor new rx for v7
    11         K PSOREEDT,COPY,SPEED,PSOEDIT,DUR,DRET
    12         S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
    13         K PSOPLCK S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" D UL^PSSLOCK(PSODFN) Q
    14 AGAIN   N VALMCNT K PSODRUG,PSOCOU,PSOCOUU,PSONOOR,PSORX("FN") W ! D HLDHDR^PSOLMUTL S (PSONEW("QFLG"),PSONEW("DFLG"))=0,PSOFROM="NEW",PSONOEDT=1
    15         K ORD D FULL^VALM1,^PSONEW1 ; Continue order entry
    16         I PSONEW("QFLG") G END
    17         I PSONEW("DFLG") W !,$C(7),"RX DELETED",! S:$G(POERR) POERR("DFLG")=1,VALMBCK="Q" G END
    18         D:$P($G(PSOPAR),"^",7)=1 AUTO^PSONRXN I $P($G(PSOPAR),"^",7)'=1 S PSOX=PSONEW("RX #") D CHECK^PSONRXN
    19         I PSONEW("DFLG")!PSONEW("QFLG") D DEL S:$G(POERR) POERR("DFLG")=1,VALMBCK="R" G END
    20         D NOOR I PSONEW("DFLG") D DEL G END
    21         D ^PSONEW2 I PSONEW("DFLG") D DEL S:$G(POERR) POERR("DFLG")=1,VALMBCK="R" G END ; Asks if correct
    22         G:$G(PSORX("FN")) END
    23         D EN^PSON52(.PSONEW) ; Files entry in File 52
    24         D NPSOSD^PSOUTIL(.PSONEW) ; Adds newly added rx to PSOSD array
    25         S VALMBCK="R"
    26 END     D EOJ ; Clean up         
    27         I '$G(PSORX("FN")) W ! K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="Y",DIR("B")="YES",DIR("A")="Another New Order for "_PSORX("NAME") D ^DIR K DIR,DIRUT,DUOUT,DTOUT I Y K PSONEW,PSDRUG,ORD G AGAIN
    28         D ^PSOBUILD,BLD^PSOORUT1 S X=PSODFN_";DPT(" D ULK^ORX2 D UL^PSSLOCK(PSODFN)
    29         D RV^PSOORFL
    30         S VALMBCK="R" K PSORX("FN") Q
    31         ;----------------------------------------------------------------
    32 DEL     ;
    33         W !,$C(7),"RX DELETED",!
    34         I $P($G(PSOPAR),"^",7)=1 D
    35         . S DIE="^PS(59,",DA=PSOSITE,PSOY=$O(PSONEW("OLD LAST RX#",""))
    36         . S PSOX=PSONEW("OLD LAST RX#",PSOY)
    37         . L +^PS(59,+PSOSITE,PSOY):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
    38         . S DR=$S(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX)
    39         . D:PSOX<$P(^PS(59,+PSOSITE,PSOY),"^",3) ^DIE K DIE,X,Y
    40         . L -^PS(59,+PSOSITE,PSOY)
    41         . K PSOX,PSOY Q
    42 EOJ     ;
    43         I $D(PSONEW("RX #")) L -^PSRX("B",PSONEW("RX #")) ; +Lock set in PSONRXN
    44         K PSONOEDT,PSONEW,PSODRUG,ANQDATA,LSI,C,MAX,MIN,NDF,REF,SIG,SER,PSOFLAG,PSOHI,PSOLO,PSONOOR,PSOCOUU,PSOCOU,PSORX("EDIT")
    45         D CLEAN^PSOVER1
    46         K ^TMP("PSORXDC",$J),RORD,ACOM,ACNT,CRIT,DEF,F1,GG,I1,IEN,INDT,LAST,MSG,NIEN,STA,DUR,DRET,PSOPRC
    47         S RXN=$O(^TMP("PSORXN",$J,0)) I RXN D
    48         .S RXN1=^TMP("PSORXN",$J,RXN) D EN^PSOHLSN1(RXN,$P(RXN1,"^"),$P(RXN1,"^",2),"",$P(RXN1,"^",3))
    49         .I $P(^PSRX(RXN,"STA"),"^")=5 D EN^PSOHLSN1(RXN,"SC","ZS","")
    50         K RXN,RXN1,^TMP("PSORXN",$J)
    51         I $G(PSONOTE) D FULL^VALM1,MAIN^TIUEDIT(3,.TIUDA,PSODFN,"","","","",1)
    52         K PSONOTE
    53         Q
    54 NOOR    ;asks nature of order
    55         N PSONOODF
    56         S PSONOODF=0
    57         I $G(OR0) D  G NOORX ;front door
    58         .S PSOI=$S($G(PSOSIGFL):1,$G(PSODRUG("OI"))'=$P(OR0,"^",8):1,1:0) I 'PSOI S PSONOOR="" D:$D(^XUSEC("PSORPH",DUZ)) COUN Q  ;NoO $P(OR0,"^",7)
    59         .S PSONOODF=1
    60         .D DIR I $D(DIRUT) S PSONEW("DFLG")=1 Q
    61         .S PSONOOR=Y D:$D(^XUSEC("PSORPH",DUZ)) COUN K DIR,DTOUT,DTOUT,DIRUT
    62         ;backdoor order
    63         D DIR I $D(DIRUT) S PSONEW("DFLG")=1 Q
    64         S PSONOOR=Y K DIK,DA,DIE,DR,PSOI,DIR,DUOUT,DTOUT,DIRUT
    65         G:'$D(^XUSEC("PSORPH",DUZ)) NOORX
    66 COUN    ;patient counseling
    67         G:$G(PSORX("EDIT"))&('$G(PSOSIGFL)) NOORX K DIR,DUOUT,DTOUT,DIRUT
    68         S DIR("B")="NO",DIR(0)="52,41" D ^DIR S PSOCOU=$S(Y:Y,1:0)
    69         I $D(DIRUT)!('PSOCOU) S PSOCOUU=0 D:'$G(SPEED) PRONTE Q
    70         K:'$G(PSOCOU) PSOCOUU K DIR,DUOUT,DTOUT,DIRUT I Y S DIR(0)="52,42",DIR("B")="NO" D ^DIR S PSOCOUU=$S(Y:Y,1:0)
    71 PRONTE  K PSONOTE,DIR,DIRUT,DUOUT
    72         I $T(MAIN^TIUEDIT)]"",'$G(SPEED) D  K DIR,DIRUT,DUOUT
    73         .S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to enter a Progress Note",DIR("A",1)="" D ^DIR K DIR
    74         .S PSONOTE=+Y Q  ;I 'Y!($D(DIRUT)) Q
    75 NOORX   K X,Y,DIR,DUOUT,DTOUT,DIRUT
    76         Q
    77 DIR     ;ask nature of order
    78         K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]""  D  Q
    79         .S PSONOOR=$$NA^ORX1($S($G(PSONOODF)!($G(PSONOBCK)):"S",1:"W"),0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:""))
    80         .I +PSONOOR S (Y,PSONOOR)=$P(PSONOOR,"^",3) Q
    81         .S DIRUT=1 K PSONOOR
    82         I $D(PSONOOR) S DF=PSONOOR,PSONODF=$S(DF="E":"PROVIDER ENTERED",DF="V":"VERBAL",DF="P":"TELEPHONE",DF="D":"DUPLICATE",DF="S":"SERVICE CORRECTED",DF="I":"POLICY",DF="R":"SERVICE REJECTED",1:"WRITTEN")
    83         K DIR,DTOUT,DTOUT,DIRUT S DIR("A")="Nature of Order: ",DIR("B")=$S($D(PSONOOR):PSONODF,1:"WRITTEN")
    84         S DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$S(+$G(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"")
    85         D ^DIR K DF,PSONODF Q:$D(DIRUT)  S PSONOOR=Y
    86 DIRX    Q
    87         ;
    88 NOORE(PSONEW)   ;entry point for renew
    89         D NOOR I $D(DIRUT) S PSONEW("DFLG")=1 Q
    90         S PSONEW("NOO")=PSONOOR
    91         Q
     1PSONEW ;BIR/SAB-new rx order main driver ; 11/5/06 6:35pm
     2 ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,94,130,268,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 ;External references L and UL^PSSLOCK supported by DBIA 2789
     20 ;External reference to ^VA(200 supported by DBIA 224
     21 ;External reference to ^XUSEC supported by DBIA 10076
     22 ;External reference to ^ORX1 supported by DBIA 2186
     23 ;External reference to ^ORX2 supported by DBIA 867
     24 ;External reference to ^TIUEDIT supported by DBIA 2410
     25 ;---------------------------------------------------------------
     26OERR ;backdoor new rx for v7
     27 K PSOREEDT,COPY,SPEED,PSOEDIT,DUR,DRET
     28 S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
     29 K PSOPLCK S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" D UL^PSSLOCK(PSODFN) Q
     30AGAIN N VALMCNT K PSODRUG,PSOCOU,PSOCOUU,PSONOOR,PSORX("FN") W ! D HLDHDR^PSOLMUTL S (PSONEW("QFLG"),PSONEW("DFLG"))=0,PSOFROM="NEW",PSONOEDT=1
     31 K ORD D FULL^VALM1,^PSONEW1 ; Continue order entry
     32 I PSONEW("QFLG") G END
     33 I PSONEW("DFLG") W !,$C(7),"RX DELETED",! S:$G(POERR) POERR("DFLG")=1,VALMBCK="Q" G END
     34 D:$P($G(PSOPAR),"^",7)=1 AUTO^PSONRXN I $P($G(PSOPAR),"^",7)'=1 S PSOX=PSONEW("RX #") D CHECK^PSONRXN
     35 I PSONEW("DFLG")!PSONEW("QFLG") D DEL S:$G(POERR) POERR("DFLG")=1,VALMBCK="R" G END
     36 D NOOR I PSONEW("DFLG") D DEL G END
     37 D ^PSONEW2 I PSONEW("DFLG") D DEL S:$G(POERR) POERR("DFLG")=1,VALMBCK="R" G END ; Asks if correct
     38 G:$G(PSORX("FN")) END
     39 D EN^PSON52(.PSONEW) ; Files entry in File 52
     40 D NPSOSD^PSOUTIL(.PSONEW) ; Adds newly added rx to PSOSD array
     41 S VALMBCK="R"
     42END D EOJ ; Clean up         
     43 I '$G(PSORX("FN")) W ! K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="Y",DIR("B")="YES",DIR("A")="Another New Order for "_PSORX("NAME") D ^DIR K DIR,DIRUT,DUOUT,DTOUT I Y K PSONEW,PSDRUG,ORD G AGAIN
     44 D ^PSOBUILD,BLD^PSOORUT1 S X=PSODFN_";DPT(" D ULK^ORX2 D UL^PSSLOCK(PSODFN)
     45 S VALMBCK="R" K PSORX("FN") Q
     46 ;----------------------------------------------------------------
     47DEL ;
     48 W !,$C(7),"RX DELETED",!
     49 I $P($G(PSOPAR),"^",7)=1 D
     50 . S DIE="^PS(59,",DA=PSOSITE,PSOY=$O(PSONEW("OLD LAST RX#",""))
     51 . S PSOX=PSONEW("OLD LAST RX#",PSOY)
     52 . L +^PS(59,+PSOSITE,PSOY):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
     53 . S DR=$S(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX)
     54 . D:PSOX<$P(^PS(59,+PSOSITE,PSOY),"^",3) ^DIE K DIE,X,Y
     55 . L -^PS(59,+PSOSITE,PSOY)
     56 . K PSOX,PSOY Q
     57EOJ ;
     58 I $D(PSONEW("RX #")) L -^PSRX("B",PSONEW("RX #")) ; +Lock set in PSONRXN
     59 K PSONOEDT,PSONEW,PSODRUG,ANQDATA,LSI,C,MAX,MIN,NDF,REF,SIG,SER,PSOFLAG,PSOHI,PSOLO,PSONOOR,PSOCOUU,PSOCOU,PSORX("EDIT")
     60 D CLEAN^PSOVER1
     61 K ^TMP("PSORXDC",$J),RORD,ACOM,ACNT,CRIT,DEF,F1,GG,I1,IEN,INDT,LAST,MSG,NIEN,STA,DUR,DRET,PSOPRC
     62 S RXN=$O(^TMP("PSORXN",$J,0)) I RXN D
     63 .S RXN1=^TMP("PSORXN",$J,RXN) D EN^PSOHLSN1(RXN,$P(RXN1,"^"),$P(RXN1,"^",2),"",$P(RXN1,"^",3))
     64 .I $P(^PSRX(RXN,"STA"),"^")=5 D EN^PSOHLSN1(RXN,"SC","ZS","")
     65 K RXN,RXN1,^TMP("PSORXN",$J)
     66 I $G(PSONOTE) D FULL^VALM1,MAIN^TIUEDIT(3,.TIUDA,PSODFN,"","","","",1)
     67 K PSONOTE
     68 Q
     69NOOR ;asks nature of order
     70 N PSONOODF
     71 S PSONOODF=0
     72 I $G(OR0) D  G NOORX ;front door
     73 .S PSOI=$S($G(PSOSIGFL):1,$G(PSODRUG("OI"))'=$P(OR0,"^",8):1,1:0) I 'PSOI S PSONOOR="" D:$D(^XUSEC("PSORPH",DUZ)) COUN Q  ;NoO $P(OR0,"^",7)
     74 .S PSONOODF=1
     75 .D DIR I $D(DIRUT) S PSONEW("DFLG")=1 Q
     76 .S PSONOOR=Y D:$D(^XUSEC("PSORPH",DUZ)) COUN K DIR,DTOUT,DTOUT,DIRUT
     77 ;backdoor order
     78 D DIR I $D(DIRUT) S PSONEW("DFLG")=1 Q
     79 S PSONOOR=Y K DIK,DA,DIE,DR,PSOI,DIR,DUOUT,DTOUT,DIRUT
     80 G:'$D(^XUSEC("PSORPH",DUZ)) NOORX
     81COUN ;patient counseling
     82 G:$G(PSORX("EDIT"))&('$G(PSOSIGFL)) NOORX K DIR,DUOUT,DTOUT,DIRUT
     83 I $G(PSOAFYN)'="Y" S DIR("B")="NO",DIR(0)="52,41" D ^DIR S PSOCOU=$S(Y:Y,1:0) ;vfam
     84 I $G(PSOAFYN)="Y" S PSOCOU=0 ;vfam No Patient Counseling by AutoFinihs
     85 I $D(DIRUT)!('PSOCOU) S PSOCOUU=0 D:'$G(SPEED) PRONTE Q
     86 K:'$G(PSOCOU) PSOCOUU K DIR,DUOUT,DTOUT,DIRUT I Y S DIR(0)="52,42",DIR("B")="NO" D ^DIR S PSOCOUU=$S(Y:Y,1:0)
     87PRONTE K PSONOTE,DIR,DIRUT,DUOUT
     88 I $T(MAIN^TIUEDIT)]"",'$G(SPEED) D  K DIR,DIRUT,DUOUT
     89 .I $G(PSOAFYN)'="Y" S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to enter a Progress Note",DIR("A",1)="" D ^DIR K DIR ;vfam
     90 .I $G(PSOAFYN)="Y" S Y="0" ;vfam No Progress Notes in AutoFinish
     91 .S PSONOTE=+Y Q  ;I 'Y!($D(DIRUT)) Q
     92NOORX K X,Y,DIR,DUOUT,DTOUT,DIRUT
     93 Q
     94DIR ;ask nature of order
     95 K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]""  D  Q
     96 .S PSONOOR=$$NA^ORX1($S($G(PSONOODF)!($G(PSONOBCK)):"S",1:"W"),0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:""))
     97 .I +PSONOOR S (Y,PSONOOR)=$P(PSONOOR,"^",3) Q
     98 .S DIRUT=1 K PSONOOR
     99 I $D(PSONOOR) S DF=PSONOOR,PSONODF=$S(DF="E":"PROVIDER ENTERED",DF="V":"VERBAL",DF="P":"TELEPHONE",DF="D":"DUPLICATE",DF="S":"SERVICE CORRECTED",DF="I":"POLICY",DF="R":"SERVICE REJECTED",1:"WRITTEN")
     100 K DIR,DTOUT,DTOUT,DIRUT S DIR("A")="Nature of Order: ",DIR("B")=$S($D(PSONOOR):PSONODF,1:"WRITTEN")
     101 S DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$S(+$G(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"")
     102 D ^DIR K DF,PSONODF Q:$D(DIRUT)  S PSONOOR=Y
     103DIRX Q
     104 ;
     105NOORE(PSONEW) ;entry point for renew
     106 D NOOR I $D(DIRUT) S PSONEW("DFLG")=1 Q
     107 S PSONEW("NOO")=PSONOOR
     108 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEW2.m

    r613 r623  
    1 PSONEW2 ;BIR/DSD - displays new rx information for edit ;7/17/06 6:59pm
    2         ;;7.0;OUTPATIENT PHARMACY;**32,37,46,71,94,124,139,157,143,226,237,239,225**;DEC 1997;Build 29
    3         ;External reference to ^PSDRUG supported by DBIA 221
    4         ;External reference to ^DPT supported by DBIA 10035
    5         ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
    6         ;External reference VADPT supported by DBIA 10061
    7         ; This routine displays the entered new rx information and
    8         ; asks if correct, if not allows editing of the data.
    9         ;------------------------------------------------------------
    10         ;PSO*237 issue expired error message
    11         ;
    12 START   ;
    13         S (PSONEW("DFLG"),PSONEW2("QFLG"))=0
    14         D STOP
    15         D DISPLAY ; Displays information
    16         ;Copay exemption checks
    17         D SCP^PSORN52D
    18         S PSONEWFF=1,PSOFLAG=1 K PSOANSQ,PSOANSQD S PSOCPZ("DFLG")=0,PSONEW("NEWCOPAY")=0
    19         ;can't check PSOSCA for <50 here because of PSOBILL check in PSOCPB
    20         I (PSOSCP<50&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1)),$G(DUZ("AG"))="V" D COPAY^PSOCPB W !
    21         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
    22         I $G(PSOCPZ("DFLG")) K PSONEWFF,PSOANSQD,PSOCPZ("DFLG"),PSONEW("NEWCOPAY") S DIRUT="",PSONEW("DFLG")=1 D ASKX G END
    23         ;IF MILL BILL, AND COPAY (*******TEST THE COPAY CHECK)
    24         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
    25         .;New prompts Quit after first '^'
    26         .I $D(PSOIBQS(PSODFN,"CV")) D CV^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("CV"))) K PSONEW("NEWCOPAY")
    27         .I $D(PSOIBQS(PSODFN,"VEH")) D VEH^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("VEH"))) K PSONEW("NEWCOPAY")
    28         .I $D(PSOIBQS(PSODFN,"RAD")) D RAD^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("RAD"))) K PSONEW("NEWCOPAY")
    29         .I $D(PSOIBQS(PSODFN,"PGW")) D PGW^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("PGW"))) K PSONEW("NEWCOPAY")
    30         .I $D(PSOIBQS(PSODFN,"SHAD")) D SHAD^PSOMLLD2 I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("SHAD"))) K PSONEW("NEWCOPAY")
    31         .I $D(PSOIBQS(PSODFN,"MST")) D MST^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("MST"))) K PSONEW("NEWCOPAY")
    32         .I $D(PSOIBQS(PSODFN,"HNC")) D HNC^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("HNC"))) K PSONEW("NEWCOPAY")
    33         K PSOCPZ("DFLG"),PSONEWFF
    34         D ASK K:$G(PSONEW("DFLG")) PSOANSQ G:PSONEW2("QFLG")!PSONEW("DFLG") END
    35         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
    36         G:'$G(PSONEW("DFLG")) START
    37         S PSONEW("QFLG")=1,PSONEW("DFLG")=0
    38 END     D EOJ
    39         Q
    40         ;------------------------------------------------------------
    41 STOP    K PSEXDT,X,%DT S PSON52("QFLG")=0
    42         S X1=PSOID,X2=PSONEW("DAYS SUPPLY")*(PSONEW("# OF REFILLS")+1)\1
    43         S X2=$S(PSONEW("DAYS SUPPLY")=X2:X2,+$G(PSONEW("CS")):184,1:366)
    44         I X2<30 D
    45         . N % S %=$P($G(PSORX("PATIENT STATUS")),"^"),X2=30
    46         . S:%?.N %=$P($G(^PS(53,+%,0)),"^") I %["AUTH ABS" S X2=5
    47         D C^%DTC I PSONEW("FILL DATE")>$P(X,".") S PSEXDT=1_"^"_$P(X,".")
    48         K X1,X2,X,%DT
    49         Q
    50 DISPLAY ;
    51         W !!,"Rx # ",PSONEW("RX #")
    52         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")
    53         I $G(SIGOK),$O(SIG(0)) D  K D G TRN
    54         .F D=0:0 S D=$O(SIG(D)) W !,SIG(D) Q:'$O(SIG(D))
    55         E  S X=PSONEW("SIG") D SIGONE^PSOHELP W !,$G(INS1)
    56 TRN     ;I $G(PSOPRC) F I=0:0 S I=$O(PRC(I)) Q:'I  W !,PRC(I)
    57         W !!,$S($G(PSODRUG("TRADE NAME"))]"":PSODRUG("TRADE NAME"),1:PSODRUG("NAME"))
    58         W !,PSONEW("PROVIDER NAME"),?25,PSORX("CLERK CODE"),!,"# of Refills: ",PSONEW("# OF REFILLS"),!
    59         Q
    60         ;
    61 ASK     ;
    62         K DIR,X,Y S DIR("A")="Is this correct"
    63         S DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR I $D(DIRUT) S PSONEW("DFLG")=1 G ASKX
    64 ASK1    I Y D  S PSONEW2("QFLG")=1
    65         .S:$G(PSONEW("MAIL/WINDOW"))["W" BINGCRT=Y,BINGRTE="W"
    66         .D:+$G(PSEXDT)
    67         ..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_"."
    68         .D DCORD K RORD,^TMP("PSORXDC",$J)
    69 ASKX    I $D(DIRUT) D
    70         .I +$G(PSEXDT) K DIRUT S (PSONEW2("QFLG"),PSONEW2("DFLG"),PSONEW("DFLG"),Y)=1
    71         K X,Y,DIRUT,DTOUT,DUOUT
    72         D:+$G(PSEXDT) PAUSE^VALM1
    73         Q
    74 DCORD   ;dc rxs and pending orders after new order is entered
    75         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")
    76         K RORD
    77         Q
    78 PEN     ;pending ^tmp("psorxdc",$j,rord,0)="p^"_rord_"^"_msg
    79         S $P(^PS(52.41,RORD,0),"^",3)="DC",^PS(52.41,RORD,4)=$P(^TMP("PSORXDC",$J,RORD,0),"^",3)
    80         K ^PS(52.41,"AOR",PSODFN,+$P($G(^PS(52.41,RORD,"INI")),"^"),RORD)
    81         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..."
    82         D PSOUL^PSSLOCK(RORD_"S") K ^TMP("PSORXDC",$J,RORD,0)
    83         Q
    84 RX52    ;rxs in file 52 ^tmp("psorxdc",$j,rord,0)=52^rord^msg^rea^act^sta^dnm
    85         S PSCAN($P(^PSRX(RORD,0),"^"))=RORD_"^"_$P(^TMP("PSORXDC",$J,RORD,0),"^",4)
    86         S MSG=$P(^TMP("PSORXDC",$J,RORD,0),"^",3),REA=$P(^(0),"^",4),ACT=$P(^(0),"^",5)
    87         N PSONOOR S PSONOOR="D",DUP=1,DA=RORD D CAN^PSOCAN K PSONOOR
    88         W !," -Rx "_$P(^PSRX(RORD,0),"^")_" has been discontinued...",!
    89         K PSOSD($P(^TMP("PSORXDC",$J,RORD,0),"^",6),$P(^TMP("PSORXDC",$J,RORD,0),"^",7))
    90         D PSOUL^PSSLOCK(RORD) K ^TMP("PSORXDC",$J,RORD,0)
    91         Q
    92         ;
    93 EDIT    ;
    94         S PSORX("EDIT")=1
    95         D ^PSONEW3
    96         S PSONEW("DFLG")=$S($G(PSORX("DFLG")):1,1:0)
    97         Q
    98         ;
    99 EOJ     ;
    100         K PSONEW2,PSORX("EDIT"),PSORX("DFLG"),PSOEDIT,PSOSCA
    101         Q
    102         ;
    103 EN1(PSONEW2)    ; Entry point to just display and ask if okay
    104         S PSONEW("DFLG")=0
    105         I $G(^PSRX(PSONEW2("IRXN"),0))']"" S PSONEW("DFLG")=1 G EN1X
    106         S PSOX=^PSRX(PSONEW2("IRXN"),0),PSONEW("TRADE NAME")=$G(^("TN")),PSONEW("FILL DATE")=$P($G(^(2)),"^",2)
    107         S PSONEW("RX #")=$P(PSOX,"^"),PSORX("NAME")=$P(^DPT($P(PSOX,"^",2),0),"^")
    108         S PSONEW("QTY")=$P(PSOX,"^",7),PSODRUG("NAME")=$P(^PSDRUG($P(PSOX,"^",6),0),"^"),PSONEW("# OF REFILLS")=$P(PSOX,"^",9)
    109         S PSORX("CLERK CODE")=$P(^VA(200,$P(PSOX,"^",16),0),"^")
    110         S:$G(PSONEW("PROVIDER NAME"))="" PSONEW("PROVIDER NAME")=$P(^VA(200,$P(PSOX,"^",4),0),"^")
    111         S PSONEW("SIG")=$P($G(^PSRX(PSONEW2("IRXN"),"SIG")),"^")
    112         D DISPLAY
    113         D ASK
    114         I PSONEW("DFLG")=1 S PSONEW2("DFLG")=1
    115 EN1X    ;
    116         Q
    117         ;
    118 EXPR    ;Display Expired error message                               ;PSO*237
    119         S PSONEW("DFLG")=1
    120         W $C(7)
    121         S VALMSG="Order is older than 365 days and can't be finished"
    122         S XQORM("B")="DC"
    123         Q
     1PSONEW2 ;BIR/DSD - displays new rx information for edit ;7/17/06 6:59pm
     2 ;;7.0;OUTPATIENT PHARMACY;**32,37,46,71,94,124,139,157,143,226,237,239**;DEC 1997
     3 ;External reference to ^PSDRUG supported by DBIA 221
     4 ;External reference to ^DPT supported by DBIA 10035
     5 ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
     6 ;External reference VADPT supported by DBIA 10061
     7 ; This routine displays the entered new rx information and
     8 ; asks if correct, if not allows editing of the data.
     9 ;------------------------------------------------------------
     10 ;PSO*237 issue expired error message
     11 ;
     12START ;
     13 S (PSONEW("DFLG"),PSONEW2("QFLG"))=0
     14 D STOP
     15 D DISPLAY ; Displays information
     16 ;Copay exemption checks
     17 D SCP^PSORN52D
     18 S PSONEWFF=1,PSOFLAG=1 K PSOANSQ,PSOANSQD S PSOCPZ("DFLG")=0,PSONEW("NEWCOPAY")=0
     19 ;can't check PSOSCA for <50 here because of PSOBILL check in PSOCPB
     20 I (PSOSCP<50&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1)),$G(DUZ("AG"))="V" D COPAY^PSOCPB W !
     21 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
     22 I $G(PSOCPZ("DFLG")) K PSONEWFF,PSOANSQD,PSOCPZ("DFLG"),PSONEW("NEWCOPAY") S DIRUT="",PSONEW("DFLG")=1 D ASKX G END
     23 ;IF MILL BILL, AND COPAY (*******TEST THE COPAY CHECK)
     24 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
     25 .;New prompts Quit after first '^'
     26 .I $D(PSOIBQS(PSODFN,"CV")) D CV^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("CV"))) K PSONEW("NEWCOPAY")
     27 .I $D(PSOIBQS(PSODFN,"VEH")) D VEH^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("VEH"))) K PSONEW("NEWCOPAY")
     28 .I $D(PSOIBQS(PSODFN,"RAD")) D RAD^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("RAD"))) K PSONEW("NEWCOPAY")
     29 .I $D(PSOIBQS(PSODFN,"PGW")) D PGW^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("PGW"))) K PSONEW("NEWCOPAY")
     30 .I $D(PSOIBQS(PSODFN,"MST")) D MST^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("MST"))) K PSONEW("NEWCOPAY")
     31 .I $D(PSOIBQS(PSODFN,"HNC")) D HNC^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("HNC"))) K PSONEW("NEWCOPAY")
     32 K PSOCPZ("DFLG"),PSONEWFF
     33 D ASK K:$G(PSONEW("DFLG")) PSOANSQ G:PSONEW2("QFLG")!PSONEW("DFLG") END
     34 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
     35 G:'$G(PSONEW("DFLG")) START
     36 S PSONEW("QFLG")=1,PSONEW("DFLG")=0
     37END D EOJ
     38 Q
     39 ;------------------------------------------------------------
     40STOP K PSEXDT,X,%DT S PSON52("QFLG")=0
     41 S X1=PSOID,X2=PSONEW("DAYS SUPPLY")*(PSONEW("# OF REFILLS")+1)\1
     42 S X2=$S(PSONEW("DAYS SUPPLY")=X2:X2,+$G(PSONEW("CS")):184,1:366)
     43 I X2<30 D
     44 . N % S %=$P($G(PSORX("PATIENT STATUS")),"^"),X2=30
     45 . S:%?.N %=$P($G(^PS(53,+%,0)),"^") I %["AUTH ABS" S X2=5
     46 D C^%DTC I PSONEW("FILL DATE")>$P(X,".") S PSEXDT=1_"^"_$P(X,".")
     47 K X1,X2,X,%DT
     48 Q
     49DISPLAY ;
     50 W !!,"Rx # ",PSONEW("RX #")
     51 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")
     52 I $G(SIGOK),$O(SIG(0)) D  K D G TRN
     53 .F D=0:0 S D=$O(SIG(D)) W !,SIG(D) Q:'$O(SIG(D))
     54 E  S X=PSONEW("SIG") D SIGONE^PSOHELP W !,$G(INS1)
     55TRN ;I $G(PSOPRC) F I=0:0 S I=$O(PRC(I)) Q:'I  W !,PRC(I)
     56 W !!,$S($G(PSODRUG("TRADE NAME"))]"":PSODRUG("TRADE NAME"),1:PSODRUG("NAME"))
     57 W !,PSONEW("PROVIDER NAME"),?25,PSORX("CLERK CODE"),!,"# of Refills: ",PSONEW("# OF REFILLS"),!
     58 Q
     59 ;
     60ASK ;
     61 K DIR,X,Y S DIR("A")="Is this correct"
     62 S DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR I $D(DIRUT) S PSONEW("DFLG")=1 G ASKX
     63ASK1 I Y D  S PSONEW2("QFLG")=1
     64 .S:$G(PSONEW("MAIL/WINDOW"))["W" BINGCRT=Y,BINGRTE="W"
     65 .D:+$G(PSEXDT)
     66 ..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_"."
     67 .D DCORD K RORD,^TMP("PSORXDC",$J)
     68ASKX I $D(DIRUT) D
     69 .I +$G(PSEXDT) K DIRUT S (PSONEW2("QFLG"),PSONEW2("DFLG"),PSONEW("DFLG"),Y)=1
     70 K X,Y,DIRUT,DTOUT,DUOUT
     71 D:+$G(PSEXDT) PAUSE^VALM1
     72 Q
     73DCORD ;dc rxs and pending orders after new order is entered
     74 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")
     75 K RORD
     76 Q
     77PEN ;pending ^tmp("psorxdc",$j,rord,0)="p^"_rord_"^"_msg
     78 S $P(^PS(52.41,RORD,0),"^",3)="DC",^PS(52.41,RORD,4)=$P(^TMP("PSORXDC",$J,RORD,0),"^",3)
     79 K ^PS(52.41,"AOR",PSODFN,+$P($G(^PS(52.41,RORD,"INI")),"^"),RORD)
     80 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..."
     81 D PSOUL^PSSLOCK(RORD_"S") K ^TMP("PSORXDC",$J,RORD,0)
     82 Q
     83RX52 ;rxs in file 52 ^tmp("psorxdc",$j,rord,0)=52^rord^msg^rea^act^sta^dnm
     84 S PSCAN($P(^PSRX(RORD,0),"^"))=RORD_"^"_$P(^TMP("PSORXDC",$J,RORD,0),"^",4)
     85 S MSG=$P(^TMP("PSORXDC",$J,RORD,0),"^",3),REA=$P(^(0),"^",4),ACT=$P(^(0),"^",5)
     86 N PSONOOR S PSONOOR="D",DUP=1,DA=RORD D CAN^PSOCAN K PSONOOR
     87 W !," -Rx "_$P(^PSRX(RORD,0),"^")_" has been discontinued...",!
     88 K PSOSD($P(^TMP("PSORXDC",$J,RORD,0),"^",6),$P(^TMP("PSORXDC",$J,RORD,0),"^",7))
     89 D PSOUL^PSSLOCK(RORD) K ^TMP("PSORXDC",$J,RORD,0)
     90 Q
     91 ;
     92EDIT ;
     93 S PSORX("EDIT")=1
     94 D ^PSONEW3
     95 S PSONEW("DFLG")=$S($G(PSORX("DFLG")):1,1:0)
     96 Q
     97 ;
     98EOJ ;
     99 K PSONEW2,PSORX("EDIT"),PSORX("DFLG"),PSOEDIT,PSOSCA
     100 Q
     101 ;
     102EN1(PSONEW2) ; Entry point to just display and ask if okay
     103 S PSONEW("DFLG")=0
     104 I $G(^PSRX(PSONEW2("IRXN"),0))']"" S PSONEW("DFLG")=1 G EN1X
     105 S PSOX=^PSRX(PSONEW2("IRXN"),0),PSONEW("TRADE NAME")=$G(^("TN")),PSONEW("FILL DATE")=$P($G(^(2)),"^",2)
     106 S PSONEW("RX #")=$P(PSOX,"^"),PSORX("NAME")=$P(^DPT($P(PSOX,"^",2),0),"^")
     107 S PSONEW("QTY")=$P(PSOX,"^",7),PSODRUG("NAME")=$P(^PSDRUG($P(PSOX,"^",6),0),"^"),PSONEW("# OF REFILLS")=$P(PSOX,"^",9)
     108 S PSORX("CLERK CODE")=$P(^VA(200,$P(PSOX,"^",16),0),"^")
     109 S:$G(PSONEW("PROVIDER NAME"))="" PSONEW("PROVIDER NAME")=$P(^VA(200,$P(PSOX,"^",4),0),"^")
     110 S PSONEW("SIG")=$P($G(^PSRX(PSONEW2("IRXN"),"SIG")),"^")
     111 D DISPLAY
     112 D ASK
     113 I PSONEW("DFLG")=1 S PSONEW2("DFLG")=1
     114EN1X ;
     115 Q
     116 ;
     117EXPR ;Display Expired error message                               ;PSO*237
     118 S PSONEW("DFLG")=1
     119 W $C(7)
     120 S VALMSG="Order is older than 365 days and can't be finished"
     121 S XQORM("B")="DC"
     122 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEWF.m

    r613 r623  
    1 PSONEWF ;BIR/RTR - Copay finish questions ;07/26/96
    2         ;;7.0;OUTPATIENT PHARMACY;**71,157,143,219,226,239,225**;DEC 1997;Build 29
    3         ;External reference VADPT supported by DBIA 10061
    4 START   ;
    5         N PSOPENIB,PSOSCOTH,PSOSCOTX,PSOMESFI
    6         S PSOPENIB=$S($G(ORD):$G(^PS(52.41,+$G(ORD),"IBQ")),1:"")
    7         ;set PSOSCOTH for display of Provider Copay intent, used with PSORX(SC)
    8         S PSOSCOTH=0 I $P(PSOPENIB,"^")=1!($P(PSOPENIB,"^",2)=1)!($P(PSOPENIB,"^",3)=1)!($P(PSOPENIB,"^",4)=1)!($P(PSOPENIB,"^",5)=1)!($P(PSOPENIB,"^",6)=1)!($P(PSOPENIB,"^",7)=1) S PSOSCOTH=1
    9         S PSOSCOTX=0 I $G(PSOSCOTH)!($G(PSORX("SC"))="SC")!($G(PSORX("SC"))="NSC") S PSOSCOTX=1
    10         ;Check for Orderable Item change to display message
    11         S PSOMESFI=0 I $G(OR0),$G(PSODRUG("OI")) D
    12         .I $G(PSODRUG("OI"))'=$P($G(OR0),"^",8) S PSOMESFI=1
    13         S PSONEWFF=1,PSOFLAG=1
    14         ;Copay exemption checks
    15         D SCP^PSORN52D
    16         K PSOANSQ D SET S PSOCPZ("DFLG")=0,PSONEW("NEWCOPAY")=0
    17         I (PSOSCP<50)&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1),$G(DUZ("AG"))="V" D COPAY^PSOCPB W !
    18         I $G(PSOCPZ("DFLG")) K PSONEW("NEWCOPAY"),PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI Q
    19         I PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1))!(PSOSCP>49&(PSOBILL=2)) D  I $G(PSOCPZ("DFLG")) K PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI Q
    20         . I PSOSCP<50 D MESS S:PSOSCP<50 PSOANSQD("SC>50")=$G(PSOANSQD("SC"))
    21         . D SC^PSOMLLD2
    22         . I PSOSCP<50&($D(PSOANSQD("SC"))) S PSOANSQD("SC")=PSOANSQD("SC>50") K PSOANSQD("SC")
    23         ;IF MILL BILL, AND COPAY (*******TEST THE COPAY CHECK)
    24         I $$DT^PSOMLLDT D  I $G(PSOCPZ("DFLG")) K PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI Q
    25         .;New prompts Quit after first '^'
    26         .I $D(PSOIBQS(PSODFN,"CV")) D  D MESSOI,MESS D CV^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("CV"))) K PSONEW("NEWCOPAY")
    27         ..I '$D(PSOANSQD("CV")),($P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1)) S PSOANSQD("CV")=$P(PSOPENIB,"^",6)
    28         .I $D(PSOIBQS(PSODFN,"VEH")) D  D MESSOI,MESS D VEH^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("VEH"))) K PSONEW("NEWCOPAY")
    29         ..I '$D(PSOANSQD("VEH")),($P(PSOPENIB,"^",2)=0!($P(PSOPENIB,"^",2)=1)) S PSOANSQD("VEH")=$P(PSOPENIB,"^",2)
    30         .I $D(PSOIBQS(PSODFN,"RAD")) D  D MESSOI,MESS D RAD^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("RAD"))) K PSONEW("NEWCOPAY")
    31         ..I '$D(PSOANSQD("RAD")),($P(PSOPENIB,"^",3)=0!($P(PSOPENIB,"^",3)=1)) S PSOANSQD("RAD")=$P(PSOPENIB,"^",3)
    32         .I $D(PSOIBQS(PSODFN,"PGW")) D  D MESSOI,MESS D PGW^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("PGW"))) K PSONEW("NEWCOPAY")
    33         ..I '$D(PSOANSQD("PGW")),($P(PSOPENIB,"^",4)=0!($P(PSOPENIB,"^",4)=1)) S PSOANSQD("PGW")=$P(PSOPENIB,"^",4)
    34         .I $D(PSOIBQS(PSODFN,"SHAD")) D  D MESSOI,MESS D SHAD^PSOMLLD2 I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("SHAD"))) K PSONEW("NEWCOPAY")
    35         ..I '$D(PSOANSQD("SHAD")),($P(PSOPENIB,"^",7)=0!($P(PSOPENIB,"^",7)=1)) S PSOANSQD("SHAD")=$P(PSOPENIB,"^",7)
    36         .I $D(PSOIBQS(PSODFN,"MST")) D  D MESSOI,MESS D MST^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("MST"))) K PSONEW("NEWCOPAY")
    37         ..I '$D(PSOANSQD("MST")),($P(PSOPENIB,"^")=0!($P(PSOPENIB,"^")=1)) S PSOANSQD("MST")=$P(PSOPENIB,"^")
    38         .I $D(PSOIBQS(PSODFN,"HNC")) D  D MESSOI,MESS D HNC^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("HNC"))) K PSONEW("NEWCOPAY")
    39         ..I '$D(PSOANSQD("HNC")),($P(PSOPENIB,"^",5)=0!($P(PSOPENIB,"^",5)=1)) S PSOANSQD("HNC")=$P(PSOPENIB,"^",5)
    40         K PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI,PSOSCA
    41         Q
    42 SET     ;Set original answers that were passed from CPRS
    43         Q:'$G(ORD)
    44         Q:'$G(PSOFDR)
    45         I $P($G(^PS(52.41,ORD,0)),"^",16)="SC"!($P($G(^(0)),"^",16)="NSC") D
    46         . I PSOSCP<50 S PSOANSQ("SC")=$S($P($G(^(0)),"^",16)="SC":1,1:0),PSOANSQD("SC")=PSOANSQ("SC") S:PSOANSQ("SC")'="" PSOIBQS(PSODFN,"SC")=PSOANSQ("SC")
    47         . I PSOSCP>49 S PSOANSQ("SC>50")=$S($P($G(^(0)),"^",16)="SC":1,1:0),PSOANSQD("SC>50")=PSOANSQ("SC>50") S:PSOANSQ("SC>50")'="" PSOIBQS(PSODFN,"SC>50")=PSOANSQ("SC>50")
    48         I $G(PSOPENIB)="" G SET2
    49         I '$$DT^PSOMLLDT Q
    50         I $P(PSOPENIB,"^")=0!($P(PSOPENIB,"^")=1) S PSOANSQ("MST")=$P(PSOPENIB,"^")
    51         I $P(PSOPENIB,"^",2)=0!($P(PSOPENIB,"^",2)=1) S PSOANSQ("VEH")=$P(PSOPENIB,"^",2)
    52         I $P(PSOPENIB,"^",3)=0!($P(PSOPENIB,"^",3)=1) S PSOANSQ("RAD")=$P(PSOPENIB,"^",3)
    53         I $P(PSOPENIB,"^",4)=0!($P(PSOPENIB,"^",4)=1) S PSOANSQ("PGW")=$P(PSOPENIB,"^",4)
    54         I $P(PSOPENIB,"^",5)=0!($P(PSOPENIB,"^",5)=1) S PSOANSQ("HNC")=$P(PSOPENIB,"^",5)
    55         I $P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1) S PSOANSQ("CV")=$P(PSOPENIB,"^",6)
    56         I $P(PSOPENIB,"^",7)=0!($P(PSOPENIB,"^",7)=1) S PSOANSQ("SHAD")=$P(PSOPENIB,"^",7)
    57         ;
    58 SET2    ;for when patient status is exempt, null IBQ node was set for exempts or SC>50 - data is in ICD node
    59         N PSOOICD
    60         I $TR($G(^PS(52.41,+$G(ORD),"IBQ")),"^")="" S PSOOICD=$G(^PS(52.41,ORD,"ICD",1,0)) D SET3:PSOOICD'=""
    61         ;
    62 ICD1    ;
    63         N PSONOCHG S PSONOCHG=0
    64         I ('$D(PSORXED("ICD"))) S PSONOCHG=1
    65         I $D(^PS(52.41,ORD,"ICD",0)) D
    66         . N JJ,ICD,II,FLD,RXN S RXN=ORD
    67         . S II=0 F  S II=$O(^PS(52.41,ORD,"ICD",II)) Q:II=""!(II'?1N.N)  D
    68         .. S ICD=^PS(52.41,ORD,"ICD",II,0),FLD=$P(ICD,U) S:$G(PSONEW("IDFLG")) FLD=""  D ICD
    69         Q
    70         ;
    71 SET3    ; called from PSONEWF and PSONEWG; must have PSOOICD.  For SC>50, exempt patient status, etc.
    72         N JJJ
    73         F JJJ=2:1:9 I $P(PSOOICD,"^",JJJ)=0!($P(PSOOICD,"^",JJJ)=1) D
    74         . I JJJ=2 S (PSOANSQD("VEH"),PSOANSQ("VEH"))=$P(PSOOICD,"^",JJJ)
    75         . I JJJ=3 S (PSOANSQD("RAD"),PSOANSQ("RAD"))=$P(PSOOICD,"^",JJJ)
    76         . I JJJ=4 D
    77         .. S:PSOSCP<50 (PSOANSQD("SC"),PSOANSQ("SC"))=$P(PSOOICD,"^",JJJ)
    78         .. S:PSOSCP>49!($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1) (PSOANSQD("SC>50"),PSOANSQ("SC>50"))=$P(PSOOICD,"^",JJJ)
    79         . I JJJ=5 S (PSOANSQD("PGW"),PSOANSQ("PGW"))=$P(PSOOICD,"^",JJJ)
    80         . I JJJ=6 S (PSOANSQD("MST"),PSOANSQ("MST"))=$P(PSOOICD,"^",JJJ)
    81         . I JJJ=7 S (PSOANSQD("HNC"),PSOANSQ("HNC"))=$P(PSOOICD,"^",JJJ)
    82         . I JJJ=8 S (PSOANSQD("CV"),PSOANSQ("CV"))=$P(PSOOICD,"^",JJJ)
    83         . I JJJ=9 S (PSOANSQD("SHAD"),PSOANSQ("SHAD"))=$P(PSOOICD,"^",JJJ)
    84         K PSOOICD
    85         Q
    86 MESS    ;
    87         I $G(PSOSCOTX)=1&(PSOSCP<50) W:$G(PSODRUG("DEA"))'["S"&($G(PSODRUG("DEA"))'["I") !,"This Rx has been flagged by the provider as: "_$S($G(PSOSCOTH):"NO COPAY",$G(PSORX("SC"))="SC":"NO COPAY",1:"COPAY"),! S PSOSCOTX=2
    88         Q
    89 MESSOI  ;
    90         I $G(PSOMESFI)=1 W !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",! S PSOMESFI=2
    91         Q
    92         ;
    93 ICD     ;called from PSONEWG,PSORENW1 and used by PSONEWF
    94         I $G(PSOCOPY)&($D(PSORXED("ICD")))&($D(PSONEW("IDFLG"))) Q:'$D(PSORXED("ICD",II))
    95         I $G(PSOCOPY)&($D(PSORXED("ICD",II))) S PSONEW("ICD",II)=PSORXED("ICD",II) Q
    96         Q:'$G(PSOCOPY)&('$D(PSORXED("ICD",II)))&('$G(PSONOCHG))  ;don't set deleted ones
    97         Q:$G(PSONEW("IDFLG"))
    98         I $D(PSORX("ICD",II)) S PSONEW("ICD",II)=PSORX("ICD",II) Q
    99         S PSONEW("ICD",II)=FLD
    100         Q
    101         ;
     1PSONEWF ;BIR/RTR - Copay finish questions ;07/26/96
     2 ;;7.0;OUTPATIENT PHARMACY;**71,157,143,219,226,239,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 ;External reference VADPT supported by DBIA 10061
     20START ;
     21 I $G(PSOAFYN)="Y" Q  ; vfam
     22 N PSOPENIB,PSOSCOTH,PSOSCOTX,PSOMESFI
     23 S PSOPENIB=$S($G(ORD):$G(^PS(52.41,+$G(ORD),"IBQ")),1:"")
     24 ;set PSOSCOTH for display of Provider Copay intent, used with PSORX(SC)
     25 S PSOSCOTH=0 I $P(PSOPENIB,"^")=1!($P(PSOPENIB,"^",2)=1)!($P(PSOPENIB,"^",3)=1)!($P(PSOPENIB,"^",4)=1)!($P(PSOPENIB,"^",5)=1)!($P(PSOPENIB,"^",6)=1) S PSOSCOTH=1
     26 S PSOSCOTX=0 I $G(PSOSCOTH)!($G(PSORX("SC"))="SC")!($G(PSORX("SC"))="NSC") S PSOSCOTX=1
     27 ;Check for Orderable Item change to display message
     28 S PSOMESFI=0 I $G(OR0),$G(PSODRUG("OI")) D
     29 .I $G(PSODRUG("OI"))'=$P($G(OR0),"^",8) S PSOMESFI=1
     30 S PSONEWFF=1,PSOFLAG=1
     31 ;Copay exemption checks
     32 D SCP^PSORN52D
     33 K PSOANSQ D SET S PSOCPZ("DFLG")=0,PSONEW("NEWCOPAY")=0
     34 I (PSOSCP<50)&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1),$G(DUZ("AG"))="V" D COPAY^PSOCPB W !
     35 I $P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1) S PSOANSQ("CV")=$P(PSOPENIB,"^",6)
     36 I $G(PSOCPZ("DFLG")) K PSONEW("NEWCOPAY"),PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI Q
     37 ;
     38 I PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1))!(PSOSCP>49&(PSOBILL=2)) D  I $G(PSOCPZ("DFLG")) K PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI Q
     39 . I PSOSCP<50 D MESS S:PSOSCP<50 PSOANSQD("SC>50")=$G(PSOANSQD("SC"))
     40 . D SC^PSOMLLD2
     41 . I PSOSCP<50&($D(PSOANSQD("SC"))) S PSOANSQD("SC")=PSOANSQD("SC>50") K PSOANSQD("SC")
     42 ;IF MILL BILL, AND COPAY (*******TEST THE COPAY CHECK)
     43 I $$DT^PSOMLLDT D  I $G(PSOCPZ("DFLG")) K PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI Q
     44 .;New prompts Quit after first '^'
     45 .I $D(PSOIBQS(PSODFN,"CV")) D  D MESSOI,MESS D CV^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("CV"))) K PSONEW("NEWCOPAY")
     46 ..I '$D(PSOANSQD("CV")),($P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1)) S PSOANSQD("CV")=$P(PSOPENIB,"^",6)
     47 .I $D(PSOIBQS(PSODFN,"VEH")) D  D MESSOI,MESS D VEH^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("VEH"))) K PSONEW("NEWCOPAY")
     48 ..I '$D(PSOANSQD("VEH")),($P(PSOPENIB,"^",2)=0!($P(PSOPENIB,"^",2)=1)) S PSOANSQD("VEH")=$P(PSOPENIB,"^",2)
     49 .I $D(PSOIBQS(PSODFN,"RAD")) D  D MESSOI,MESS D RAD^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("RAD"))) K PSONEW("NEWCOPAY")
     50 ..I '$D(PSOANSQD("RAD")),($P(PSOPENIB,"^",3)=0!($P(PSOPENIB,"^",3)=1)) S PSOANSQD("RAD")=$P(PSOPENIB,"^",3)
     51 .I $D(PSOIBQS(PSODFN,"PGW")) D  D MESSOI,MESS D PGW^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("PGW"))) K PSONEW("NEWCOPAY")
     52 ..I '$D(PSOANSQD("PGW")),($P(PSOPENIB,"^",4)=0!($P(PSOPENIB,"^",4)=1)) S PSOANSQD("PGW")=$P(PSOPENIB,"^",4)
     53 .I $D(PSOIBQS(PSODFN,"MST")) D  D MESSOI,MESS D MST^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("MST"))) K PSONEW("NEWCOPAY")
     54 ..I '$D(PSOANSQD("MST")),($P(PSOPENIB,"^")=0!($P(PSOPENIB,"^")=1)) S PSOANSQD("MST")=$P(PSOPENIB,"^")
     55 .I $D(PSOIBQS(PSODFN,"HNC")) D  D MESSOI,MESS D HNC^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("HNC"))) K PSONEW("NEWCOPAY")
     56 ..I '$D(PSOANSQD("HNC")),($P(PSOPENIB,"^",5)=0!($P(PSOPENIB,"^",5)=1)) S PSOANSQD("HNC")=$P(PSOPENIB,"^",5)
     57 K PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI,PSOSCA
     58 Q
     59SET ;Set original answers that were passed from CPRS
     60 Q:'$G(ORD)
     61 Q:'$G(PSOFDR)
     62 I $P($G(^PS(52.41,ORD,0)),"^",16)="SC"!($P($G(^(0)),"^",16)="NSC") D
     63 . I PSOSCP<50 S PSOANSQ("SC")=$S($P($G(^(0)),"^",16)="SC":1,1:0),PSOANSQD("SC")=PSOANSQ("SC") S:PSOANSQ("SC")'="" PSOIBQS(PSODFN,"SC")=PSOANSQ("SC")
     64 . I PSOSCP>49 S PSOANSQ("SC>50")=$S($P($G(^(0)),"^",16)="SC":1,1:0),PSOANSQD("SC>50")=PSOANSQ("SC>50") S:PSOANSQ("SC>50")'="" PSOIBQS(PSODFN,"SC>50")=PSOANSQ("SC>50")
     65 I $G(PSOPENIB)="" G SET2
     66 I '$$DT^PSOMLLDT Q
     67 I $P(PSOPENIB,"^")=0!($P(PSOPENIB,"^")=1) S PSOANSQ("MST")=$P(PSOPENIB,"^")
     68 I $P(PSOPENIB,"^",2)=0!($P(PSOPENIB,"^",2)=1) S PSOANSQ("VEH")=$P(PSOPENIB,"^",2)
     69 I $P(PSOPENIB,"^",3)=0!($P(PSOPENIB,"^",3)=1) S PSOANSQ("RAD")=$P(PSOPENIB,"^",3)
     70 I $P(PSOPENIB,"^",4)=0!($P(PSOPENIB,"^",4)=1) S PSOANSQ("PGW")=$P(PSOPENIB,"^",4)
     71 I $P(PSOPENIB,"^",5)=0!($P(PSOPENIB,"^",5)=1) S PSOANSQ("HNC")=$P(PSOPENIB,"^",5)
     72 I $P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1) S PSOANSQ("CV")=$P(PSOPENIB,"^",6)
     73 ;
     74SET2 ;for when patient status is exempt, null IBQ node was set for exempts or SC>50 - data is in ICD node
     75 N PSOOICD
     76 I $TR($G(^PS(52.41,+$G(ORD),"IBQ")),"^")="" S PSOOICD=$G(^PS(52.41,ORD,"ICD",1,0)) D SET3:PSOOICD'=""
     77 ;
     78ICD1 ;
     79 N PSONOCHG S PSONOCHG=0
     80 I ('$D(PSORXED("ICD"))) S PSONOCHG=1
     81 I $D(^PS(52.41,ORD,"ICD",0)) D
     82 . N JJ,ICD,II,FLD,RXN S RXN=ORD
     83 . S II=0 F  S II=$O(^PS(52.41,ORD,"ICD",II)) Q:II=""!(II'?1N.N)  D
     84 .. S ICD=^PS(52.41,ORD,"ICD",II,0),FLD=$P(ICD,U) S:$G(PSONEW("IDFLG")) FLD=""  D ICD
     85 Q
     86 ;
     87SET3 ; called from PSONEWF and PSONEWG; must have PSOOICD.  For SC>50, exempt patient status, etc.
     88 N JJJ
     89 F JJJ=2:1:8 I $P(PSOOICD,"^",JJJ)=0!($P(PSOOICD,"^",JJJ)=1) D
     90 . I JJJ=2 S (PSOANSQD("VEH"),PSOANSQ("VEH"))=$P(PSOOICD,"^",JJJ)
     91 . I JJJ=3 S (PSOANSQD("RAD"),PSOANSQ("RAD"))=$P(PSOOICD,"^",JJJ)
     92 . I JJJ=4 D
     93 .. S:PSOSCP<50 (PSOANSQD("SC"),PSOANSQ("SC"))=$P(PSOOICD,"^",JJJ)
     94 .. S:PSOSCP>49!($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1) (PSOANSQD("SC>50"),PSOANSQ("SC>50"))=$P(PSOOICD,"^",JJJ)
     95 . I JJJ=5 S (PSOANSQD("PGW"),PSOANSQ("PGW"))=$P(PSOOICD,"^",JJJ)
     96 . I JJJ=6 S (PSOANSQD("MST"),PSOANSQ("MST"))=$P(PSOOICD,"^",JJJ)
     97 . I JJJ=7 S (PSOANSQD("HNC"),PSOANSQ("HNC"))=$P(PSOOICD,"^",JJJ)
     98 . I JJJ=8 S (PSOANSQD("CV"),PSOANSQ("CV"))=$P(PSOOICD,"^",JJJ)
     99 K PSOOICD
     100 Q
     101MESS ;
     102 I $G(PSOSCOTX)=1&(PSOSCP<50) W:$G(PSODRUG("DEA"))'["S"&($G(PSODRUG("DEA"))'["I") !,"This Rx has been flagged by the provider as: "_$S($G(PSOSCOTH):"NO COPAY",$G(PSORX("SC"))="SC":"NO COPAY",1:"COPAY"),! S PSOSCOTX=2
     103 Q
     104MESSOI ;
     105 I $G(PSOMESFI)=1 W !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",! S PSOMESFI=2
     106 Q
     107 ;
     108ICD ;called from PSONEWG,PSORENW1 and used by PSONEWF
     109 I $G(PSOCOPY)&($D(PSORXED("ICD")))&($D(PSONEW("IDFLG"))) Q:'$D(PSORXED("ICD",II))
     110 I $G(PSOCOPY)&($D(PSORXED("ICD",II))) S PSONEW("ICD",II)=PSORXED("ICD",II) Q
     111 Q:'$G(PSOCOPY)&('$D(PSORXED("ICD",II)))&('$G(PSONOCHG))  ;don't set deleted ones
     112 Q:$G(PSONEW("IDFLG"))
     113 I $D(PSORX("ICD",II)) S PSONEW("ICD",II)=PSORX("ICD",II) Q
     114 S PSONEW("ICD",II)=FLD
     115 Q
     116 ;

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEWG.m

    r613 r623  
    1 PSONEWG ;BIR/RTR - Copay copy and edit questions ;07/26/96
    2         ;;7.0;OUTPATIENT PHARMACY;**71,157,143,219,226,239,225**;DEC 1997;Build 29
    3         ;External reference ^PSDRUG( supported by DBIA 221
    4         ;External reference VADPT supported by DBIA 10061
    5 START   ;
    6         N PSOPENIB,PSOMESOI
    7         S PSOPENIB="" I $G(PSORXED)!($G(PSOCOPY)) I $G(PSORXED("IRXN")) S PSOPENIB=$G(^PSRX(PSORXED("IRXN"),"IBQ"))
    8         S PSOMESOI=0 I $G(PSORXED) D
    9         .I $G(PSODRUG("OI")),$P($G(PSORXED("RX0")),"^",6) D
    10         ..I $G(PSODRUG("OI"))'=$P($G(^PSDRUG(+$P($G(PSORXED("RX0")),"^",6),2)),"^") S PSOMESOI=1
    11         S PSONEWFF=1,PSOFLAG=1
    12         ;Copay exemption checks
    13         D SCP^PSORN52D
    14         K PSOANSQ D SET S PSOCPZ("DFLG")=0,PSONEW("NEWCOPAY")=0
    15         I PSOSCP<50&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1),$G(DUZ("AG"))="V" D  D COPAY^PSOCPB W !
    16         .;I $G(PSOANSQD("SC"))=0!($G(PSOANSQD("SC"))=1) Q
    17         .I $G(PSOANSQ("SC"))=0!($G(PSOANSQ("SC"))=1) S PSOANSQD("SC")=$G(PSOANSQ("SC"))
    18         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 I $G(PSOCPZ("DFLG")) K PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOMESOI Q
    19         I $G(PSOCPZ("DFLG")) K PSONEW("NEWCOPAY"),PSONEWFF,PSOMESOI Q
    20         ;IF MILL BILL, AND COPAY (*******TEST THE COPAY CHECK)
    21         I $$DT^PSOMLLDT D  I $G(PSOCPZ("DFLG")) K PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOMESOI Q
    22         .;New prompts Quit after first '^'
    23         .I $D(PSOIBQS(PSODFN,"CV")) D  D MESS D CV^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("CV"))) K PSONEW("NEWCOPAY")
    24         ..I '$D(PSOANSQD("CV")),($P(PSOPENIB,"^",7)=0!($P(PSOPENIB,"^",7)=1)) S PSOANSQD("CV")=$P(PSOPENIB,"^",7)
    25         .I $D(PSOIBQS(PSODFN,"VEH")) D  D MESS D VEH^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("VEH"))) K PSONEW("NEWCOPAY")
    26         ..I '$D(PSOANSQD("VEH")),($P(PSOPENIB,"^",3)=0!($P(PSOPENIB,"^",3)=1)) S PSOANSQD("VEH")=$P(PSOPENIB,"^",3)
    27         .I $D(PSOIBQS(PSODFN,"RAD")) D  D MESS D RAD^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("RAD"))) K PSONEW("NEWCOPAY")
    28         ..I '$D(PSOANSQD("RAD")),($P(PSOPENIB,"^",4)=0!($P(PSOPENIB,"^",4)=1)) S PSOANSQD("RAD")=$P(PSOPENIB,"^",4)
    29         .I $D(PSOIBQS(PSODFN,"PGW")) D  D MESS D PGW^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("PGW"))) K PSONEW("NEWCOPAY")
    30         ..I '$D(PSOANSQD("PGW")),($P(PSOPENIB,"^",5)=0!($P(PSOPENIB,"^",5)=1)) S PSOANSQD("PGW")=$P(PSOPENIB,"^",5)
    31         .I $D(PSOIBQS(PSODFN,"SHAD")) D  D MESS D SHAD^PSOMLLD2 I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("SHAD"))) K PSONEW("NEWCOPAY")
    32         ..I '$D(PSOANSQD("SHAD")),($P(PSOPENIB,"^",8)=0!($P(PSOPENIB,"^",8)=1)) S PSOANSQD("SHAD")=$P(PSOPENIB,"^",8)
    33         .I $D(PSOIBQS(PSODFN,"MST")) D  D MESS D MST^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("MST"))) K PSONEW("NEWCOPAY")
    34         ..I '$D(PSOANSQD("MST")),($P(PSOPENIB,"^",2)=0!($P(PSOPENIB,"^",2)=1)) S PSOANSQD("MST")=$P(PSOPENIB,"^",2)
    35         .I $D(PSOIBQS(PSODFN,"HNC")) D  D MESS D HNC^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("HNC"))) K PSONEW("NEWCOPAY")
    36         ..I '$D(PSOANSQD("HNC")),($P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1)) S PSOANSQD("HNC")=$P(PSOPENIB,"^",6)
    37         K PSONEWFF,PSOMESOI,PSOSCA
    38         Q
    39 SET     ;Set original answers that were passed from CPRS
    40         Q:'$G(PSORXED("IRXN"))
    41         S PSOANSQ("SC")=$S($P($G(^PSRX(PSORXED("IRXN"),"IBQ")),"^")'="":$P($G(^("IBQ")),"^"),$P($G(^PSRX(PSORXED("IRXN"),"IB")),"^"):0,1:"")
    42         I $G(PSOANSQ("SC"))="" K PSOANSQ("SC")
    43         I $G(PSOPENIB)="" G SET2
    44         I '$$DT^PSOMLLDT Q
    45         I $P(PSOPENIB,"^",2)=0!($P(PSOPENIB,"^",2)=1) S PSOANSQ("MST")=$P(PSOPENIB,"^",2)
    46         I $P(PSOPENIB,"^",3)=0!($P(PSOPENIB,"^",3)=1) S PSOANSQ("VEH")=$P(PSOPENIB,"^",3)
    47         I $P(PSOPENIB,"^",4)=0!($P(PSOPENIB,"^",4)=1) S PSOANSQ("RAD")=$P(PSOPENIB,"^",4)
    48         I $P(PSOPENIB,"^",5)=0!($P(PSOPENIB,"^",5)=1) S PSOANSQ("PGW")=$P(PSOPENIB,"^",5)
    49         I $P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1) S PSOANSQ("HNC")=$P(PSOPENIB,"^",6)
    50         I $P(PSOPENIB,"^",7)=0!($P(PSOPENIB,"^",7)=1) S PSOANSQ("CV")=$P(PSOPENIB,"^",7)
    51         I $P(PSOPENIB,"^",8)=0!($P(PSOPENIB,"^",8)=1) S PSOANSQ("SHAD")=$P(PSOPENIB,"^",8)
    52         ;
    53 SET2    ;for when patient status is exempt, null IBQ node was set for exempts or SC>50 - data is in ICD node
    54         N PSOOICD,JJJ
    55         I $TR($G(^PSRX(PSODFN,"IBQ")),"^")="" S PSOOICD=$G(^PSRX(PSORXED("IRXN"),"ICD",1,0)) D SET3^PSONEWF:PSOOICD'=""
    56         ;
    57 ICD     ;
    58         N JJ,ICD,II,FLD,RXN,TNEW,PSONOCHG S PSONOCHG=0
    59         S RXN=PSORXED("IRXN")
    60         I '$D(PSONEW("ICD"))&('$D(PSORXED("ICD"))) S PSONOCHG=1
    61         I $D(^PSRX(RXN,"ICD",0)) D
    62         . S II=0 F  S II=$O(^PSRX(RXN,"ICD",II)) Q:II=""!(II'?1N.N)!($G(PSOCOPY)&(II>1)&('PSONOCHG))  D
    63         .. S ICD=^PSRX(RXN,"ICD",II,0),FLD=$P(ICD,U) S:$G(PSONEW("IDFLG")) FLD="" D ICD^PSONEWF
    64         E  I $G(PSONEW("IDFLG")) K ^PSRX(RXN,"ICD","B") S $P(^PSRX(RXN,"ICD",1,0),"^",1)="",TNEW=2 D
    65         . F TNEW=TNEW:1:8 Q:'$D(^PSRX(RXN,"ICD",TNEW,0))  S DIK="^PSRX("_RXN_","_$C(34)_"ICD"_$C(34)_",",DA=TNEW,DA(1)=RXN D ^DIK K DA,DIK ;user deleted all
    66         K PSONEW("IDFLG"),PSORXED("IDFLG")
    67         Q
    68 MESS    ;
    69         I $G(PSOMESOI)=1,$G(PSORXED) W !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",! S PSOMESOI=2
    70         Q
     1PSONEWG ;BIR/RTR - Copay copy and edit questions ;07/26/96
     2 ;;7.0;OUTPATIENT PHARMACY;**71,157,143,219,226,239**;DEC 1997
     3 ;External reference ^PSDRUG( supported by DBIA 221
     4 ;External reference VADPT supported by DBIA 10061
     5START ;
     6 N PSOPENIB,PSOMESOI
     7 S PSOPENIB="" I $G(PSORXED)!($G(PSOCOPY)) I $G(PSORXED("IRXN")) S PSOPENIB=$G(^PSRX(PSORXED("IRXN"),"IBQ"))
     8 S PSOMESOI=0 I $G(PSORXED) D
     9 .I $G(PSODRUG("OI")),$P($G(PSORXED("RX0")),"^",6) D
     10 ..I $G(PSODRUG("OI"))'=$P($G(^PSDRUG(+$P($G(PSORXED("RX0")),"^",6),2)),"^") S PSOMESOI=1
     11 S PSONEWFF=1,PSOFLAG=1
     12 ;Copay exemption checks
     13 D SCP^PSORN52D
     14 K PSOANSQ D SET S PSOCPZ("DFLG")=0,PSONEW("NEWCOPAY")=0
     15 I PSOSCP<50&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1),$G(DUZ("AG"))="V" D  D COPAY^PSOCPB W !
     16 .;I $G(PSOANSQD("SC"))=0!($G(PSOANSQD("SC"))=1) Q
     17 .I $G(PSOANSQ("SC"))=0!($G(PSOANSQ("SC"))=1) S PSOANSQD("SC")=$G(PSOANSQ("SC"))
     18 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 I $G(PSOCPZ("DFLG")) K PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOMESOI Q
     19 I $G(PSOCPZ("DFLG")) K PSONEW("NEWCOPAY"),PSONEWFF,PSOMESOI Q
     20 ;IF MILL BILL, AND COPAY (*******TEST THE COPAY CHECK)
     21 I $$DT^PSOMLLDT D  I $G(PSOCPZ("DFLG")) K PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOMESOI Q
     22 .;New prompts Quit after first '^'
     23 .I $D(PSOIBQS(PSODFN,"CV")) D  D MESS D CV^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("CV"))) K PSONEW("NEWCOPAY")
     24 ..I '$D(PSOANSQD("CV")),($P(PSOPENIB,"^",7)=0!($P(PSOPENIB,"^",7)=1)) S PSOANSQD("CV")=$P(PSOPENIB,"^",7)
     25 .I $D(PSOIBQS(PSODFN,"VEH")) D  D MESS D VEH^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("VEH"))) K PSONEW("NEWCOPAY")
     26 ..I '$D(PSOANSQD("VEH")),($P(PSOPENIB,"^",3)=0!($P(PSOPENIB,"^",3)=1)) S PSOANSQD("VEH")=$P(PSOPENIB,"^",3)
     27 .I $D(PSOIBQS(PSODFN,"RAD")) D  D MESS D RAD^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("RAD"))) K PSONEW("NEWCOPAY")
     28 ..I '$D(PSOANSQD("RAD")),($P(PSOPENIB,"^",4)=0!($P(PSOPENIB,"^",4)=1)) S PSOANSQD("RAD")=$P(PSOPENIB,"^",4)
     29 .I $D(PSOIBQS(PSODFN,"PGW")) D  D MESS D PGW^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("PGW"))) K PSONEW("NEWCOPAY")
     30 ..I '$D(PSOANSQD("PGW")),($P(PSOPENIB,"^",5)=0!($P(PSOPENIB,"^",5)=1)) S PSOANSQD("PGW")=$P(PSOPENIB,"^",5)
     31 .I $D(PSOIBQS(PSODFN,"MST")) D  D MESS D MST^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("MST"))) K PSONEW("NEWCOPAY")
     32 ..I '$D(PSOANSQD("MST")),($P(PSOPENIB,"^",2)=0!($P(PSOPENIB,"^",2)=1)) S PSOANSQD("MST")=$P(PSOPENIB,"^",2)
     33 .I $D(PSOIBQS(PSODFN,"HNC")) D  D MESS D HNC^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("HNC"))) K PSONEW("NEWCOPAY")
     34 ..I '$D(PSOANSQD("HNC")),($P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1)) S PSOANSQD("HNC")=$P(PSOPENIB,"^",6)
     35 K PSONEWFF,PSOMESOI,PSOSCA
     36 Q
     37SET ;Set original answers that were passed from CPRS
     38 Q:'$G(PSORXED("IRXN"))
     39 S PSOANSQ("SC")=$S($P($G(^PSRX(PSORXED("IRXN"),"IBQ")),"^")'="":$P($G(^("IBQ")),"^"),$P($G(^PSRX(PSORXED("IRXN"),"IB")),"^"):0,1:"")
     40 I $G(PSOANSQ("SC"))="" K PSOANSQ("SC")
     41 I $G(PSOPENIB)="" G SET2
     42 I '$$DT^PSOMLLDT Q
     43 I $P(PSOPENIB,"^",2)=0!($P(PSOPENIB,"^",2)=1) S PSOANSQ("MST")=$P(PSOPENIB,"^",2)
     44 I $P(PSOPENIB,"^",3)=0!($P(PSOPENIB,"^",3)=1) S PSOANSQ("VEH")=$P(PSOPENIB,"^",3)
     45 I $P(PSOPENIB,"^",4)=0!($P(PSOPENIB,"^",4)=1) S PSOANSQ("RAD")=$P(PSOPENIB,"^",4)
     46 I $P(PSOPENIB,"^",5)=0!($P(PSOPENIB,"^",5)=1) S PSOANSQ("PGW")=$P(PSOPENIB,"^",5)
     47 I $P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1) S PSOANSQ("HNC")=$P(PSOPENIB,"^",6)
     48 I $P(PSOPENIB,"^",7)=0!($P(PSOPENIB,"^",7)=1) S PSOANSQ("CV")=$P(PSOPENIB,"^",7)
     49 ;
     50SET2 ;for when patient status is exempt, null IBQ node was set for exempts or SC>50 - data is in ICD node
     51 N PSOOICD,JJJ
     52 I $TR($G(^PSRX(PSODFN,"IBQ")),"^")="" S PSOOICD=$G(^PSRX(PSORXED("IRXN"),"ICD",1,0)) D SET3^PSONEWF:PSOOICD'=""
     53 ;
     54ICD ;
     55 N JJ,ICD,II,FLD,RXN,TNEW,PSONOCHG S PSONOCHG=0
     56 S RXN=PSORXED("IRXN")
     57 I '$D(PSONEW("ICD"))&('$D(PSORXED("ICD"))) S PSONOCHG=1
     58 I $D(^PSRX(RXN,"ICD",0)) D
     59 . S II=0 F  S II=$O(^PSRX(RXN,"ICD",II)) Q:II=""!(II'?1N.N)!($G(PSOCOPY)&(II>1)&('PSONOCHG))  D
     60 .. S ICD=^PSRX(RXN,"ICD",II,0),FLD=$P(ICD,U) S:$G(PSONEW("IDFLG")) FLD="" D ICD^PSONEWF
     61 E  I $G(PSONEW("IDFLG")) K ^PSRX(RXN,"ICD","B") S $P(^PSRX(RXN,"ICD",1,0),"^",1)="",TNEW=2 D
     62 . F TNEW=TNEW:1:8 Q:'$D(^PSRX(RXN,"ICD",TNEW,0))  S DIK="^PSRX("_RXN_","_$C(34)_"ICD"_$C(34)_",",DA=TNEW,DA(1)=RXN D ^DIK K DA,DIK ;user deleted all
     63 K PSONEW("IDFLG"),PSORXED("IDFLG")
     64 Q
     65MESS ;
     66 I $G(PSOMESOI)=1,$G(PSORXED) W !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",! S PSOMESOI=2
     67 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONFI.m

    r613 r623  
    1 PSONFI  ;BIR/MHA - dispense drug/orderable item text display ;09/13/00
    2         ;;7.0;OUTPATIENT PHARMACY;**46,94,131,225**;DEC 1997;Build 29
    3         ;External reference to PSSDIN is supported by DBIA 3166
    4         ;External reference to ^PS(50.606 is supported by DBIA 2174
    5         ;External reference to ^PS(50.7 is supported by DBIA 2223
    6         ;External reference to ^PSDRUG( is supported by DBIA 221
    7         ;
    8 NFI     ;display restriction/guidelines
    9         D EN^PSSDIN(PSODRUG("OI"),PSODRUG("IEN")) S NFI=$$PROMPT^PSSDIN
    10         I NFI]"","ODY"[NFI D TD^PSONFI S DIR(0)="E" D ^DIR K DIR
    11         K NFI Q
    12 DDTX    ;Display drug text for the hidden action DIN
    13         N OI,DD
    14         S:$D(PSODRUG("OI")) OI=PSODRUG("OI") S:$D(PSODRUG("IEN")) DD=PSODRUG("IEN")
    15         I $G(OI),$G(DD) G 1
    16         I $D(PSORNSV),$G(PSORNSV)]"" S OI=+$P(OR0,"^",8),DD=+$P(OR0,"^",9) G 1
    17         S OI=+RXOR,DD=+$P(RX0,"^",6)
    18 1       S OI=$S($G(OI):OI,1:""),DD=$S($G(DD):DD,1:"")
    19         D EN^PSSDIN(OI,DD)
    20         N N1,N2,N3,N4,TX,NX S NX="PSSDIN"
    21         W @IOF,!!,"Drug restriction/guideline info:",!!
    22         W !,"Orderable Item: "_$P(^PS(50.7,OI,0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_$S($P(^PS(50.7,OI,0),"^",12):" ***(N/F)***",1:""),!!
    23         I $O(^TMP("PSSDIN",$J,"OI",0)) S N1="OI" D TXD
    24         W:'$O(^TMP("PSSDIN",$J,"OI",0)) ?5,"No information available ",!!
    25         I $G(DD),$D(^PSDRUG(DD,0)) W !,"Drug: "_$P(^PSDRUG(DD,0),"^")_$S($P(^PSDRUG(DD,0),"^",9):" ***(N/F)***",1:""),!! D
    26         .I $O(^TMP("PSSDIN",$J,"DD",0)) S N1="DD" D TXD
    27         .W:'$O(^TMP("PSSDIN",$J,"DD",0)) ?5,"No information available ",!!
    28 HLD     K DIR S DIR(0)="E" D ^DIR K DIR
    29         Q
    30 DIN(OI,DD)      ;Setup DIN indicator
    31         S (NFIO,NFID)=""
    32         I $D(OI),$G(OI) S:$P($G(^PS(50.7,OI,0)),"^",12) NFIO=" ***(N/F)***"
    33         I $D(DD),$G(DD) S:$P($G(^PSDRUG(DD,0)),"^",9) NFID=" ***(N/F)***"
    34         D EN^PSSDIN(OI,DD)
    35         S:$O(^TMP("PSSDIN",$J,"OI",0)) NFIO=NFIO_" <DIN>"
    36         S:$O(^TMP("PSSDIN",$J,"DD",0)) NFID=NFID_" <DIN>"
    37         K ^TMP("PSSDIN",$J) Q
    38         Q
    39 RV      ;reverse video
    40         I $G(PKID),$G(PKIE)]"" D
    41         .I $O(^PS(52.41,ORD,"OBX",0)) D CNTRL^VALM10(1,1,13,IORVON,IORVOFF,0),RV^PSOPKIV1 Q
    42         .D CNTRL^VALM10(1,1,$L(PKIE),IORVON,IORVOFF,0)
    43         D:$G(NFIO) CNTRL^VALM10(+NFIO,$P(NFIO,",",2),5,IORVON,IORVOFF,0)
    44         D:$G(NFID) CNTRL^VALM10(+NFID,$P(NFID,",",2),5,IORVON,IORVOFF,0)
    45         K NFIO,NFID,PKID
    46         ;- Reverses video for the words "Flagged" and "Unflagged"
    47         N L
    48         F L=1:1:VALMCNT D
    49         . D:$D(FLAGLINE(L)) CNTRL^VALM10(L,1,FLAGLINE(L),IORVON,IORVOFF,0)
    50         Q
    51         ;
    52 TD      N N1,N2,N3,N4,TX,NX S NX="PSSDIN"
    53         W @IOF
    54         I NFI="O" D OIT
    55         I NFI="D" D DDT
    56         I NFI="Y" D DDT,OIT
    57         Q
    58 OIT     ;
    59         S N1="OI",TX="Orderable Item Text:" D TXT
    60         Q
    61 DDT     ;
    62         S N1="DD",TX="Dispense Drug Text:" D TXT
    63         Q
    64 TXT     ;
    65         W !,TX
    66 TXD     K ^UTILITY($J,"W")
    67         S N2="" F  S N2=$O(^TMP(NX,$J,N1,N2)) Q:'N2!($D(DIRUT))  D
    68         .S N3="" F  S N3=$O(^TMP(NX,$J,N1,N2,N3)) Q:'N3!($D(DIRUT))  D
    69         ..S N4="" F  S N4=$O(^TMP(NX,$J,N1,N2,N3,N4)) Q:'N4!($D(DIRUT))  D
    70         ...W !?5,^TMP(NX,$J,N1,N2,N3,N4) I $Y>20 W ! D HLD Q:$D(DIRUT)  W @IOF
    71         W ! K ^UTILITY($J,"W")
    72         Q
     1PSONFI ;BIR/MHA - dispense drug/orderable item text display ; 09/13/00
     2 ;;7.0;OUTPATIENT PHARMACY;**46,94,131**;DEC 1997
     3 ;External reference to PSSDIN is supported by DBIA 3166
     4 ;External reference to ^PS(50.606 is supported by DBIA 2174
     5 ;External reference to ^PS(50.7 is supported by DBIA 2223
     6 ;External reference to ^PSDRUG( is supported by DBIA 221
     7 ;
     8NFI ;display restriction/guidelines
     9 D EN^PSSDIN(PSODRUG("OI"),PSODRUG("IEN")) S NFI=$$PROMPT^PSSDIN
     10 I NFI]"","ODY"[NFI D TD^PSONFI S DIR(0)="E" D ^DIR K DIR
     11 K NFI Q
     12DDTX ;Display drug text for the hidden action DIN
     13 N OI,DD
     14 S:$D(PSODRUG("OI")) OI=PSODRUG("OI") S:$D(PSODRUG("IEN")) DD=PSODRUG("IEN")
     15 I $G(OI),$G(DD) G 1
     16 I $D(PSORNSV),$G(PSORNSV)]"" S OI=+$P(OR0,"^",8),DD=+$P(OR0,"^",9) G 1
     17 S OI=+RXOR,DD=+$P(RX0,"^",6)
     181 S OI=$S($G(OI):OI,1:""),DD=$S($G(DD):DD,1:"")
     19 D EN^PSSDIN(OI,DD)
     20 N N1,N2,N3,N4,TX,NX S NX="PSSDIN"
     21 W @IOF,!!,"Drug restriction/guideline info:",!!
     22 W !,"Orderable Item: "_$P(^PS(50.7,OI,0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_$S($P(^PS(50.7,OI,0),"^",12):" ***(N/F)***",1:""),!!
     23 I $O(^TMP("PSSDIN",$J,"OI",0)) S N1="OI" D TXD
     24 W:'$O(^TMP("PSSDIN",$J,"OI",0)) ?5,"No information available ",!!
     25 I $G(DD),$D(^PSDRUG(DD,0)) W !,"Drug: "_$P(^PSDRUG(DD,0),"^")_$S($P(^PSDRUG(DD,0),"^",9):" ***(N/F)***",1:""),!! D
     26 .I $O(^TMP("PSSDIN",$J,"DD",0)) S N1="DD" D TXD
     27 .W:'$O(^TMP("PSSDIN",$J,"DD",0)) ?5,"No information available ",!!
     28HLD K DIR S DIR(0)="E" D ^DIR K DIR
     29 Q
     30DIN(OI,DD) ;Setup DIN indicator
     31 S (NFIO,NFID)=""
     32 I $D(OI),$G(OI) S:$P($G(^PS(50.7,OI,0)),"^",12) NFIO=" ***(N/F)***"
     33 I $D(DD),$G(DD) S:$P($G(^PSDRUG(DD,0)),"^",9) NFID=" ***(N/F)***"
     34 D EN^PSSDIN(OI,DD)
     35 S:$O(^TMP("PSSDIN",$J,"OI",0)) NFIO=NFIO_" <DIN>"
     36 S:$O(^TMP("PSSDIN",$J,"DD",0)) NFID=NFID_" <DIN>"
     37 K ^TMP("PSSDIN",$J) Q
     38 Q
     39RV ;reverse video
     40 I $G(PKID),$G(PKIE)]"" D
     41 .I $O(^PS(52.41,ORD,"OBX",0)) D CNTRL^VALM10(1,1,13,IORVON,IORVOFF,0),RV^PSOPKIV1 Q
     42 .D CNTRL^VALM10(1,1,$L(PKIE),IORVON,IORVOFF,0)
     43 D:$G(NFIO) CNTRL^VALM10(+NFIO,$P(NFIO,",",2),5,IORVON,IORVOFF,0)
     44 D:$G(NFID) CNTRL^VALM10(+NFID,$P(NFID,",",2),5,IORVON,IORVOFF,0)
     45 K NFIO,NFID,PKID Q
     46TD N N1,N2,N3,N4,TX,NX S NX="PSSDIN"
     47 W @IOF
     48 I NFI="O" D OIT
     49 I NFI="D" D DDT
     50 I NFI="Y" D DDT,OIT
     51 Q
     52OIT ;
     53 S N1="OI",TX="Orderable Item Text:" D TXT
     54 Q
     55DDT ;
     56 S N1="DD",TX="Dispense Drug Text:" D TXT
     57 Q
     58TXT ;
     59 W !,TX
     60TXD K ^UTILITY($J,"W")
     61 S N2="" F  S N2=$O(^TMP(NX,$J,N1,N2)) Q:'N2!($D(DIRUT))  D
     62 .S N3="" F  S N3=$O(^TMP(NX,$J,N1,N2,N3)) Q:'N3!($D(DIRUT))  D
     63 ..S N4="" F  S N4=$O(^TMP(NX,$J,N1,N2,N3,N4)) Q:'N4!($D(DIRUT))  D
     64 ...W !?5,^TMP(NX,$J,N1,N2,N3,N4) I $Y>20 W ! D HLD Q:$D(DIRUT)  W @IOF
     65 W ! K ^UTILITY($J,"W") Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORAL.m

    r613 r623  
    1 PSOORAL ;BHAM-ISC/SAB - activity log list ; 28-APR-1995
    2         ;;7.0;OUTPATIENT PHARMACY;**148,281**;DEC 1997;Build 41
    3 EN      ; -- main entry point for PSO LM ACTIVITY LOGS
    4         D EN^VALM("PSO LM ACTIVITY LOGS")
    5         Q
    6         ;
    7 HDR     ; -- header code
    8         D HDR^PSOLMUTL
    9         Q
    10         ;
    11 INIT    ; -- init variables and list array
    12         I $G(PS)="VIEW"!($G(PS)="DELETE")!($G(PS)="REJECT")!($G(PS)="REJECTMP") D
    13         .I ST<12,$P(RX2,"^",6)<DT S ST=11
    14         .S VALM("TITLE")="Rx View "_"("_$P("Error^Active^Non-Verified^Refill^Hold^Non-Verified^Suspended^^^^^Done^Expired^Discontinued^Deleted^Discontinued^Discontinued (Edit)^Provider Hold^","^",ST+2)_")"
    15         S VALMCNT=PSOAL
    16         Q
    17         ;
    18 HELP    ; -- help code
    19         S X="?" D DISP^XQORM1 W !!
    20         Q
    21         ;
    22 EXIT    ; -- exit code
    23         S VALMBCK="Q" Q
    24         ;
    25 EXPND   ; -- expand code
    26         Q
    27         ;
     1PSOORAL ;BHAM-ISC/SAB - activity log list ; 28-APR-1995
     2 ;;7.0;OUTPATIENT PHARMACY;**148**;DEC 1997
     3EN ; -- main entry point for PSO LM ACTIVITY LOGS
     4 D EN^VALM("PSO LM ACTIVITY LOGS")
     5 Q
     6 ;
     7HDR ; -- header code
     8 D HDR^PSOLMUTL
     9 Q
     10 ;
     11INIT ; -- init variables and list array
     12 I $G(PS)="VIEW"!($G(PS)="DELETE")!($G(PS)="REJECT") D
     13 .I ST<12,$P(RX2,"^",6)<DT S ST=11
     14 .S VALM("TITLE")="Rx View "_"("_$P("Error^Active^Non-Verified^Refill^Hold^Non-Verified^Suspended^^^^^Done^Expired^Discontinued^Deleted^Discontinued^Discontinued (Edit)^Provider Hold^","^",ST+2)_")"
     15 S VALMCNT=PSOAL
     16 Q
     17 ;
     18HELP ; -- help code
     19 S X="?" D DISP^XQORM1 W !!
     20 Q
     21 ;
     22EXIT ; -- exit code
     23 S VALMBCK="Q" Q
     24 ;
     25EXPND ; -- expand code
     26 Q
     27 ;

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORAL1.m

    r613 r623  
    1 PSOORAL1        ;BHAM ISC/SAB - Build Listman activity logs ; 12/4/07 12:25pm
    2         ;;7.0;OUTPATIENT PHARMACY;**71,156,148,247,240**;DEC 1997;Build 5
    3         N RX0,VALMCNT K DIR,DTOUT,DUOUT,DIRUT,^TMP("PSOAL",$J) S DA=$P(PSOLST(ORN),"^",2),RX0=^PSRX(DA,0),J=DA,RX2=$G(^(2)),R3=$G(^(3)),CMOP=$O(^PSRX(DA,4,0))
    4         S IEN=0,DIR(0)="LO^1:"_$S(CMOP:8,1:7),DIR("A",1)=" ",DIR("A",2)="Select Activity Log by  number",DIR("A",3)="1.  Refill      2.  Partial      3.  Activity     4.  Labels"
    5         S DIR("A")=$S(CMOP:"5.  Copay       6.  ECME         7.  CMOP Events  8.  All Logs",1:"5.  Copay       6.  ECME         7.  All Logs")
    6         S DIR("B")=$S(CMOP:8,1:7) D ^DIR S PSOELSE=+Y I +Y S Y=$S(CMOP&(Y[8):"1,2,3,4,5,6,7",'CMOP&(Y[7):"1,2,3,4,5,6",1:Y) S ACT=Y D FULL^VALM1 D
    7         .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Rx #: "_$P(RX0,"^")_"   Original Fill Released: " I $P(RX2,"^",13) S DTT=$P(RX2,"^",13) D DAT S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_DAT K DAT,DTT
    8         .I $P(RX2,"^",15) S DTT=$P(RX2,"^",15) D DAT S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"(Returned to Stock "_DAT_")" K DAT,DTT
    9         .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Routing: "_$S($P(RX0,"^",11)="W":"Window",1:"Mail")_$S($P($G(^PSRX(DA,"OR1")),"^",5):"      Finished by: "_$P(^VA(200,$P(^PSRX(DA,"OR1"),"^",5),0),"^"),1:"")
    10         .D:$G(^PSRX(DA,"H"))]""&($P(PSOLST(ORN),"^",3)="HOLD") HLD^PSOORAL2
    11         .F LOG=1:1:$L(ACT,",") Q:$P(ACT,",",LOG)']""  S LBL=$P(ACT,",",LOG) D @$S(LBL=1:"RF^PSOORAL2",LBL=2:"PAR^PSOORAL2",LBL=3:"ACT",LBL=5:"COPAY",LBL=6:"ECME",LBL=7:"^PSORXVW2",1:"LBL")
    12         I 'PSOELSE S VALMBCK="" K PSOELSE Q
    13         K ST0,RFL,RFLL,RFL1,II,J,N,PHYS,L1,DIRUT,PSDIV,PSEXDT,MED,M1,FFX,DTT,DAT,R3,RTN,SIG,STA,P1,PL,P0,Z0,Z1,EXDT,IFN,DIR,DUOUT,DTOUT,PSOELSE
    14         K LBL,I,RFDATE,%H,%I,RN,RFT
    15         S PSOAL=IEN K IEN,ACT,LBL,LOG D EN^PSOORAL S VALMBCK="R"
    16         Q
    17 ACT     ;activity log
    18         N CNT
    19         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Activity Log:"
    20         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="#   Date        Reason         Rx Ref         Initiator Of Activity",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
    21         I '$O(^PSRX(DA,"A",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There's NO Activity to report" Q
    22         S CNT=0
    23         F N=0:0 S N=$O(^PSRX(DA,"A",N)) Q:'N  S P1=^(N,0),DTT=P1\1 D DAT D
    24         .I $P(P1,"^",2)="M" Q
    25         .S IEN=IEN+1,CNT=CNT+1,^TMP("PSOAL",$J,IEN,0)=CNT_"   "_DAT_"    ",$P(RN," ",15)=" ",REA=$P(P1,"^",2),REA=$F("HUCELPRWSIVDABXGKN",REA)-1
    26         .I REA D
    27         ..S STA=$P("HOLD^UNHOLD^DISCONTINUED^EDIT^RENEWED^PARTIAL^REINSTATE^REPRINT^SUSPENSE^RETURNED^INTERVENTION^DELETED^DRUG INTERACTION^PROCESSED^X-INTERFACE^PATIENT INSTR.^PKI/DEA^DISP COMPLETED^","^",REA)
    28         ..S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA_$E(RN,$L(STA)+1,15)
    29         .E  S $P(STA," ",15)=" ",^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA
    30         .K STA,RN S $P(RN," ",15)=" ",RF=+$P(P1,"^",4)
    31         .S RFT=$S(RF>0&(RF<6):"REFILL "_RF,RF=6:"PARTIAL",RF>6:"REFILL "_(RF-1),1:"ORIGINAL")
    32         .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$E(RN,$L(RFT)+1,15)_$S($D(^VA(200,+$P(P1,"^",3),0)):$P(^(0),"^"),1:$P(P1,"^",3))
    33         .;S:$P(P1,"^",5)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$P(P1,"^",5)
    34         .I $P(P1,"^",5)]"" N PSOACBRK,PSOACBRV D
    35         ..S PSOACBRV=$P(P1,"^",5)
    36         ..;PSO*7*240 Use fileman for parsing
    37         ..K ^UTILITY($J,"W") S X="Comments: "_PSOACBRV,(DIWR,DIWL)=1,DIWF="C80" D ^DIWP F I=1:1:^UTILITY($J,"W",1) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$G(^UTILITY($J,"W",1,I,0))
    38         .I $P($G(^PSRX(DA,"A",N,1)),"^")]"" S IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",5)=$P($G(^PSRX(DA,"A",N,1)),"^") I $P($G(^PSRX(DA,"A",N,1)),"^",2)]"" S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_":"_$P($G(^PSRX(DA,"A",N,1)),"^",2)
    39         .I $O(^PSRX(DA,"A",N,2,0)) F I=0:0 S I=$O(^PSRX(DA,"A",N,2,I)) Q:'I  S MIG=^PSRX(DA,"A",N,2,I,0) D
    40         ..F SG=1:1:$L(MIG) S:$L(^TMP("PSOAL",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",9)=" " S:$P(MIG," ",SG)'="" ^TMP("PSOAL",$J,IEN,0)=$G(^TMP("PSOAL",$J,IEN,0))_" "_$P(MIG," ",SG)
    41         K MIG,SG,I,^UTILITY($J,"W"),DIWF,DIWL,DIWR
    42         Q
    43 LBL     ;label log
    44         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Label Log:"
    45         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="#   Date        Rx Ref                    Printed By",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
    46         I '$O(^PSRX(DA,"L",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There are NO Labels printed." Q
    47         F L1=0:0 S L1=$O(^PSRX(DA,"L",L1)) Q:'L1  S LBL=^PSRX(DA,"L",L1,0),DTT=$P(^(0),"^") D DAT D
    48         .S $P(RN," ",26)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=L1_"   "_DAT_"    ",RFT=$S($P(LBL,"^",2):"REFILL "_$P(LBL,"^",2),1:"ORIGINAL"),RFT=RFT_$E(RN,$L(RFT)+1,26)
    49         .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$P($G(^VA(200,$P(LBL,"^",4),0)),"^"),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$P(LBL,"^",3)
    50         Q
    51         ;
    52 COPAY   ;Copay activity log
    53         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Copay Activity Log:"
    54         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="#   Date        Reason               Rx Ref         Initiator Of Activity",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
    55         I '$O(^PSRX(DA,"COPAY",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There's NO Copay activity to report" Q
    56         F N=0:0 S N=$O(^PSRX(DA,"COPAY",N)) Q:'N  S P1=^(N,0),DTT=P1\1 D DAT D
    57         .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=N_"   "_DAT_"    ",$P(RN," ",21)=" ",REA=$P(P1,"^",2),REA=$F("ARICE",REA)-1
    58         .I REA D
    59         ..S STA=$P("ANNUAL CAP REACHED^COPAY RESET^IB-INITIATED COPAY^REMOVE COPAY CHARGE^RX EDITED^","^",REA)
    60         ..S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA_$E(RN,$L(STA)+1,21)
    61         .E  S $P(STA," ",21)=" ",^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA
    62         .K STA,RN S $P(RN," ",15)=" ",RF=+$P(P1,"^",4)
    63         .S RFT=$S(RF>0:"REFILL "_RF,1:"ORIGINAL")
    64         .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$E(RN,$L(RFT)+1,15)_$S($D(^VA(200,+$P(P1,"^",3),0)):$P(^(0),"^"),1:$P(P1,"^",3))
    65         .S:$P(P1,"^",5)]""!($P(P1,"^",6)]"")!($P(P1,"^",7)]"") IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comment: "_$P(P1,"^",5)
    66         .I $P(P1,"^",6)]"" S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"  Old value="_$P(P1,"^",6)_"   New value="_$P(P1,"^",7)
    67         Q
    68         ;
    69 ECME    ; ECME activity log
    70         N N,P1,RFT,PSOACBRK,PSOACBRV,MIG,SG,I,NOTFND,CNT,LINE
    71         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="ECME Log:"
    72         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="#   Date/Time           Rx Ref          Initiator Of Activity"
    73         S IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
    74         S NOTFND=1,I=0 F  S I=$O(^PSRX(DA,"A",I)) Q:'I  S Z=$G(^PSRX(DA,"A",I,0)) I $P(Z,"^",2)="M" S NOTFND=0 Q
    75         I NOTFND S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There's NO ECME Activity to report" Q
    76         S CNT=0
    77         F N=0:0 S N=$O(^PSRX(DA,"A",N)) Q:'N  S P1=^(N,0) D
    78         .I $P(P1,"^",2)'="M" Q
    79         .S IEN=IEN+1,CNT=CNT+1
    80         .K STA,RN S $P(RN," ",15)=" ",RF=+$P(P1,"^",4)
    81         .S LINE=CNT,$E(LINE,5)=$$FMTE^XLFDT($P(P1,"^"),2),$E(LINE,25)=$S(RF:"REFILL "_RF,1:"ORIGINAL")
    82         .S $E(LINE,41)=$$GET1^DIQ(200,+$P(P1,"^",3),.01)
    83         .S ^TMP("PSOAL",$J,IEN,0)=LINE
    84         .I $P(P1,"^",5)]"" D
    85         ..S PSOACBRV=$P(P1,"^",5)
    86         ..;PSO*7*240 Use fileman for parsing
    87         ..K ^UTILITY($J,"W") S X="Comments: "_PSOACBRV,(DIWR,DIWL)=1,DIWF="C80" D ^DIWP F I=1:1:^UTILITY($J,"W",1) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$G(^UTILITY($J,"W",1,I,0))
    88         .I $O(^PSRX(DA,"A",N,2,0)) F I=0:0 S I=$O(^PSRX(DA,"A",N,2,I)) Q:'I  S MIG=^PSRX(DA,"A",N,2,I,0) D
    89         ..F SG=1:1:$L(MIG) D
    90         ...S:$L(^TMP("PSOAL",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",9)=" "
    91         ...S:$P(MIG," ",SG)'="" ^TMP("PSOAL",$J,IEN,0)=$G(^TMP("PSOAL",$J,IEN,0))_" "_$P(MIG," ",SG)
    92         D DISPREJ
    93         K ^UTILITY($J,"W"),DIWR,DIWF,DIWL
    94         Q
    95         ;
    96 DISPREJ  ;
    97         N LN,SEQ,REJ,PRI,VAR,X,X1,X2,I,RFT
    98         I '$D(^PSRX(DA,"REJ")) Q
    99         S PRI="PSOAL",$P(LN,"=",80)="",SEQ=0
    100         S IEN=$G(IEN)+1,^TMP(PRI,$J,IEN,0)=" "
    101         S IEN=IEN+1,^TMP(PRI,$J,IEN,0)="ECME REJECT Log:"
    102         S IEN=IEN+1,^TMP(PRI,$J,IEN,0)="#  Date/Time Rcvd    Rx Ref    Reject Type     STATUS     Date/Time Resolved"
    103         S IEN=IEN+1,^TMP(PRI,$J,IEN,0)=LN
    104         F REJ=0:0 S REJ=$O(^PSRX(DA,"REJ",REJ)) Q:'REJ  D
    105         . S VAR=$G(^PSRX(DA,"REJ",REJ,0))
    106         . S RFT=+$P(VAR,"^",4)
    107         . S SEQ=SEQ+1,X=SEQ,$E(X,4)=$$FMTE^XLFDT($P(VAR,"^",2),2),$E(X,22)=$S(RFT:"REFILL "_RFT,1:"ORIGINAL")
    108         . S $E(X,32)=$S(+VAR=79:"REFILL TOO SOON",1:"DUR")
    109         . S $E(X,48)=$S($P(VAR,"^",5):"RESOLVED",1:"UNRESOLVED")
    110         . S:$P(VAR,"^",6) $E(X,59)=$$FMTE^XLFDT($P(VAR,"^",6),2)
    111         . ; S:$P(VAR,"^",14) $E(X,67)="(RE-OPENED)"
    112         . S IEN=IEN+1,^TMP(PRI,$J,IEN,0)=X
    113         . I $P(VAR,"^",5) D
    114         . . S IEN=IEN+1,X=$$GET1^DIQ(52.25,REJ_","_DA,12)
    115         . . S X1=$$GET1^DIQ(52.25,REJ_","_DA,13) S:X1'="" X=X1_" ("_X_")"
    116         . . F I=1:1 Q:X=""  D
    117         . . . S ^TMP(PRI,$J,IEN,0)=$S(I=1:"Comments: ",1:"          ")_$E(X,1,69)
    118         . . . S X=$E(X,70,999) S:X'="" IEN=IEN+1
    119         Q
    120         ;
    121 DAT     S DAT="",DTT=DTT\1 Q:DTT'?7N  S DAT=$E(DTT,4,5)_"/"_$E(DTT,6,7)_"/"_$E(DTT,2,3)
    122         Q
     1PSOORAL1 ;BHAM ISC/SAB - Build Listman activity logs ;11/16/92 13:11
     2 ;;7.0;OUTPATIENT PHARMACY;**71,156,148,247**;DEC 1997;Build 18
     3 N RX0,VALMCNT K DIR,DTOUT,DUOUT,DIRUT,^TMP("PSOAL",$J) S DA=$P(PSOLST(ORN),"^",2),RX0=^PSRX(DA,0),J=DA,RX2=$G(^(2)),R3=$G(^(3)),CMOP=$O(^PSRX(DA,4,0))
     4 S IEN=0,DIR(0)="LO^1:"_$S(CMOP:8,1:7),DIR("A",1)=" ",DIR("A",2)="Select Activity Log by  number",DIR("A",3)="1.  Refill      2.  Partial      3.  Activity     4.  Labels"
     5 S DIR("A")=$S(CMOP:"5.  Copay       6.  ECME         7.  CMOP Events  8.  All Logs",1:"5.  Copay       6.  ECME         7.  All Logs")
     6 S DIR("B")=$S(CMOP:8,1:7) D ^DIR S PSOELSE=+Y I +Y S Y=$S(CMOP&(Y[8):"1,2,3,4,5,6,7",'CMOP&(Y[7):"1,2,3,4,5,6",1:Y) S ACT=Y D FULL^VALM1 D
     7 .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Rx #: "_$P(RX0,"^")_"   Original Fill Released: " I $P(RX2,"^",13) S DTT=$P(RX2,"^",13) D DAT S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_DAT K DAT,DTT
     8 .I $P(RX2,"^",15) S DTT=$P(RX2,"^",15) D DAT S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"(Returned to Stock "_DAT_")" K DAT,DTT
     9 .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Routing: "_$S($P(RX0,"^",11)="W":"Window",1:"Mail")_$S($P($G(^PSRX(DA,"OR1")),"^",5):"      Finished by: "_$P(^VA(200,$P(^PSRX(DA,"OR1"),"^",5),0),"^"),1:"")
     10 .D:$G(^PSRX(DA,"H"))]""&($P(PSOLST(ORN),"^",3)="HOLD") HLD^PSOORAL2
     11 .F LOG=1:1:$L(ACT,",") Q:$P(ACT,",",LOG)']""  S LBL=$P(ACT,",",LOG) D @$S(LBL=1:"RF^PSOORAL2",LBL=2:"PAR^PSOORAL2",LBL=3:"ACT",LBL=5:"COPAY",LBL=6:"ECME",LBL=7:"^PSORXVW2",1:"LBL")
     12 I 'PSOELSE S VALMBCK="" K PSOELSE Q
     13 K ST0,RFL,RFLL,RFL1,II,J,N,PHYS,L1,DIRUT,PSDIV,PSEXDT,MED,M1,FFX,DTT,DAT,R3,RTN,SIG,STA,P1,PL,P0,Z0,Z1,EXDT,IFN,DIR,DUOUT,DTOUT,PSOELSE
     14 K LBL,I,RFDATE,%H,%I,RN,RFT
     15 S PSOAL=IEN K IEN,ACT,LBL,LOG D EN^PSOORAL S VALMBCK="R"
     16 Q
     17ACT ;activity log
     18 N CNT
     19 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Activity Log:"
     20 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="#   Date        Reason         Rx Ref         Initiator Of Activity",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
     21 I '$O(^PSRX(DA,"A",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There's NO Activity to report" Q
     22 S CNT=0
     23 F N=0:0 S N=$O(^PSRX(DA,"A",N)) Q:'N  S P1=^(N,0),DTT=P1\1 D DAT D
     24 .I $P(P1,"^",2)="M" Q
     25 .S IEN=IEN+1,CNT=CNT+1,^TMP("PSOAL",$J,IEN,0)=CNT_"   "_DAT_"    ",$P(RN," ",15)=" ",REA=$P(P1,"^",2),REA=$F("HUCELPRWSIVDABXGKN",REA)-1
     26 .I REA D
     27 ..S STA=$P("HOLD^UNHOLD^DISCONTINUED^EDIT^RENEWED^PARTIAL^REINSTATE^REPRINT^SUSPENSE^RETURNED^INTERVENTION^DELETED^DRUG INTERACTION^PROCESSED^X-INTERFACE^PATIENT INSTR.^PKI/DEA^DISP COMPLETED^","^",REA)
     28 ..S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA_$E(RN,$L(STA)+1,15)
     29 .E  S $P(STA," ",15)=" ",^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA
     30 .K STA,RN S $P(RN," ",15)=" ",RF=+$P(P1,"^",4)
     31 .S RFT=$S(RF>0&(RF<6):"REFILL "_RF,RF=6:"PARTIAL",RF>6:"REFILL "_(RF-1),1:"ORIGINAL")
     32 .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$E(RN,$L(RFT)+1,15)_$S($D(^VA(200,+$P(P1,"^",3),0)):$P(^(0),"^"),1:$P(P1,"^",3))
     33 .;S:$P(P1,"^",5)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$P(P1,"^",5)
     34 .I $P(P1,"^",5)]"" N PSOACBRK,PSOACBRV D
     35 ..S PSOACBRV=$P(P1,"^",5)
     36 ..I $L(PSOACBRV)<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_PSOACBRV Q
     37 ..I $E(PSOACBRV,1,70)'[" " S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$E(PSOACBRV,1,70),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$E(PSOACBRV,71,245) Q
     38 ..F PSOACBRK=245:-1 Q:PSOACBRK=0  I $E(PSOACBRV,PSOACBRK)=" ",PSOACBRK<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$E(PSOACBRV,1,PSOACBRK),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$E(PSOACBRV,PSOACBRK,245) Q
     39 .I $P($G(^PSRX(DA,"A",N,1)),"^")]"" S IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",5)=$P($G(^PSRX(DA,"A",N,1)),"^") I $P($G(^PSRX(DA,"A",N,1)),"^",2)]"" S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_":"_$P($G(^PSRX(DA,"A",N,1)),"^",2)
     40 .I $O(^PSRX(DA,"A",N,2,0)) F I=0:0 S I=$O(^PSRX(DA,"A",N,2,I)) Q:'I  S MIG=^PSRX(DA,"A",N,2,I,0) D
     41 ..F SG=1:1:$L(MIG) S:$L(^TMP("PSOAL",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",9)=" " S:$P(MIG," ",SG)'="" ^TMP("PSOAL",$J,IEN,0)=$G(^TMP("PSOAL",$J,IEN,0))_" "_$P(MIG," ",SG)
     42 K MIG,SG,I
     43 Q
     44LBL ;label log
     45 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Label Log:"
     46 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="#   Date        Rx Ref                    Printed By",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
     47 I '$O(^PSRX(DA,"L",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There are NO Labels printed." Q
     48 F L1=0:0 S L1=$O(^PSRX(DA,"L",L1)) Q:'L1  S LBL=^PSRX(DA,"L",L1,0),DTT=$P(^(0),"^") D DAT D
     49 .S $P(RN," ",26)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=L1_"   "_DAT_"    ",RFT=$S($P(LBL,"^",2):"REFILL "_$P(LBL,"^",2),1:"ORIGINAL"),RFT=RFT_$E(RN,$L(RFT)+1,26)
     50 .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$P($G(^VA(200,$P(LBL,"^",4),0)),"^"),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$P(LBL,"^",3)
     51 Q
     52 ;
     53COPAY ;Copay activity log
     54 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Copay Activity Log:"
     55 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="#   Date        Reason               Rx Ref         Initiator Of Activity",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
     56 I '$O(^PSRX(DA,"COPAY",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There's NO Copay activity to report" Q
     57 F N=0:0 S N=$O(^PSRX(DA,"COPAY",N)) Q:'N  S P1=^(N,0),DTT=P1\1 D DAT D
     58 .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=N_"   "_DAT_"    ",$P(RN," ",21)=" ",REA=$P(P1,"^",2),REA=$F("ARICE",REA)-1
     59 .I REA D
     60 ..S STA=$P("ANNUAL CAP REACHED^COPAY RESET^IB-INITIATED COPAY^REMOVE COPAY CHARGE^RX EDITED^","^",REA)
     61 ..S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA_$E(RN,$L(STA)+1,21)
     62 .E  S $P(STA," ",21)=" ",^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA
     63 .K STA,RN S $P(RN," ",15)=" ",RF=+$P(P1,"^",4)
     64 .S RFT=$S(RF>0:"REFILL "_RF,1:"ORIGINAL")
     65 .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$E(RN,$L(RFT)+1,15)_$S($D(^VA(200,+$P(P1,"^",3),0)):$P(^(0),"^"),1:$P(P1,"^",3))
     66 .S:$P(P1,"^",5)]""!($P(P1,"^",6)]"")!($P(P1,"^",7)]"") IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comment: "_$P(P1,"^",5)
     67 .I $P(P1,"^",6)]"" S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"  Old value="_$P(P1,"^",6)_"   New value="_$P(P1,"^",7)
     68 Q
     69 ;
     70ECME ; ECME activity log
     71 N N,P1,RFT,PSOACBRK,PSOACBRV,MIG,SG,I,NOTFND,CNT,LINE
     72 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="ECME Log:"
     73 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="#   Date/Time           Rx Ref          Initiator Of Activity"
     74 S IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
     75 S NOTFND=1,I=0 F  S I=$O(^PSRX(DA,"A",I)) Q:'I  S Z=$G(^PSRX(DA,"A",I,0)) I $P(Z,"^",2)="M" S NOTFND=0 Q
     76 I NOTFND S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There's NO ECME Activity to report" Q
     77 S CNT=0
     78 F N=0:0 S N=$O(^PSRX(DA,"A",N)) Q:'N  S P1=^(N,0) D
     79 .I $P(P1,"^",2)'="M" Q
     80 .S IEN=IEN+1,CNT=CNT+1
     81 .K STA,RN S $P(RN," ",15)=" ",RF=+$P(P1,"^",4)
     82 .S LINE=CNT,$E(LINE,5)=$$FMTE^XLFDT($P(P1,"^"),2),$E(LINE,25)=$S(RF:"REFILL "_RF,1:"ORIGINAL")
     83 .S $E(LINE,41)=$$GET1^DIQ(200,+$P(P1,"^",3),.01)
     84 .S ^TMP("PSOAL",$J,IEN,0)=LINE
     85 .I $P(P1,"^",5)]"" D
     86 ..S PSOACBRV=$P(P1,"^",5)
     87 ..I $L(PSOACBRV)<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_PSOACBRV Q
     88 ..I $E(PSOACBRV,1,70)'[" " S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$E(PSOACBRV,1,70),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$E(PSOACBRV,71,245) Q
     89 ..F PSOACBRK=245:-1 Q:PSOACBRK=0  I $E(PSOACBRV,PSOACBRK)=" ",PSOACBRK<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$E(PSOACBRV,1,PSOACBRK),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$E(PSOACBRV,PSOACBRK,245) Q
     90 .I $O(^PSRX(DA,"A",N,2,0)) F I=0:0 S I=$O(^PSRX(DA,"A",N,2,I)) Q:'I  S MIG=^PSRX(DA,"A",N,2,I,0) D
     91 ..F SG=1:1:$L(MIG) D
     92 ...S:$L(^TMP("PSOAL",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",9)=" "
     93 ...S:$P(MIG," ",SG)'="" ^TMP("PSOAL",$J,IEN,0)=$G(^TMP("PSOAL",$J,IEN,0))_" "_$P(MIG," ",SG)
     94 D DISPREJ
     95 Q
     96 ;
     97DISPREJ  ;
     98 N LN,SEQ,REJ,PRI,VAR,X,X1,X2,I,RFT
     99 I '$D(^PSRX(DA,"REJ")) Q
     100 S PRI="PSOAL",$P(LN,"=",80)="",SEQ=0
     101 S IEN=$G(IEN)+1,^TMP(PRI,$J,IEN,0)=" "
     102 S IEN=IEN+1,^TMP(PRI,$J,IEN,0)="ECME REJECT Log:"
     103 S IEN=IEN+1,^TMP(PRI,$J,IEN,0)="#  Date/Time Rcvd    Rx Ref    Reject Type     STATUS     Date/Time Resolved"
     104 S IEN=IEN+1,^TMP(PRI,$J,IEN,0)=LN
     105 F REJ=0:0 S REJ=$O(^PSRX(DA,"REJ",REJ)) Q:'REJ  D
     106 . S VAR=$G(^PSRX(DA,"REJ",REJ,0))
     107 . S RFT=+$P(VAR,"^",4)
     108 . S SEQ=SEQ+1,X=SEQ,$E(X,4)=$$FMTE^XLFDT($P(VAR,"^",2),2),$E(X,22)=$S(RFT:"REFILL "_RFT,1:"ORIGINAL")
     109 . S $E(X,32)=$S(+VAR=79:"REFILL TOO SOON",1:"DUR")
     110 . S $E(X,48)=$S($P(VAR,"^",5):"RESOLVED",1:"UNRESOLVED")
     111 . S:$P(VAR,"^",6) $E(X,59)=$$FMTE^XLFDT($P(VAR,"^",6),2)
     112 . ; S:$P(VAR,"^",14) $E(X,67)="(RE-OPENED)"
     113 . S IEN=IEN+1,^TMP(PRI,$J,IEN,0)=X
     114 . I $P(VAR,"^",5) D
     115 . . S IEN=IEN+1,X=$$GET1^DIQ(52.25,REJ_","_DA,12)
     116 . . S X1=$$GET1^DIQ(52.25,REJ_","_DA,13) S:X1'="" X=X1_" ("_X_")"
     117 . . F I=1:1 Q:X=""  D
     118 . . . S ^TMP(PRI,$J,IEN,0)=$S(I=1:"Comments: ",1:"          ")_$E(X,1,69)
     119 . . . S X=$E(X,70,999) S:X'="" IEN=IEN+1
     120 Q
     121 ;
     122DAT S DAT="",DTT=DTT\1 Q:DTT'?7N  S DAT=$E(DTT,4,5)_"/"_$E(DTT,6,7)_"/"_$E(DTT,2,3)
     123 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED1.m

    r613 r623  
    1 PSOORED1        ;ISC-BHAM/SAB - edit orders from backdoor ;5/10/07 8:25am
    2         ;;7.0;OUTPATIENT PHARMACY;**5,23,46,78,114,117,131,146,223,148,244,249,268,206**;DEC 1997;Build 39
    3         ;External reference ^PS(55 supported by DBIA 2228
    4         ;External reference ^PS(50.7 supported by DBIA 2223
    5         ;
    6         ;*244 call to remove DC'd Rx's from Rx ien strings
    7         ;
    8 EN(PSORENW)     ;
    9         N LST,ORD,ORN K VALMBCK,PSORX("FN") S PSOAC=1,(PSORX("QFLG"),PSORX("DFLG"))=0 ;D DREN^PSOORNW2,INIT
    10         D INIT
    11         D @$S($P(PSOPAR,"^",7):"AUTO^PSONRXN",1:"MANUAL^PSONRXN")
    12         I '$D(PSONEW("RX #")),'$P(PSOPAR,"^",7) D PAUSE^VALM1 K VALMSG,PSONEW("QFLG") S VALMBCK="Q" Q
    13         I '$D(PSONEW("RX #")) K VALMSG D DEL^PSONEW,PAUSE^VALM1 S VALMBCK="Q" Q
    14         S PSORENW("RX #")=PSONEW("RX #") I '$P(PSOPAR,"^",7) D  Q:$G(PSONEW("DFLG"))!($G(PSONEW("QFLG")))
    15         .S PSOX=PSORENW("RX #") D CHECK^PSONRXN
    16         I $G(PSONEW("DFLG"))!$G(PSONEW("QFLG")) D DEL^PSONEW,PAUSE^VALM1 S VALMBCK="Q" K PSORENW Q
    17         D EN^PSOORNE1(.PSORENW) I '$G(PSORX("FN")) D:$P($G(PSOPAR),"^",7)=1  S VALMBCK="Q" Q
    18         .S DIE="^PS(59,",DA=PSOSITE,PSOY=$O(PSONEW("OLD LAST RX#","")),PSOX=PSONEW("OLD LAST RX#",PSOY)
    19         .L +^PS(59,+PSOSITE,PSOY):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
    20         .S DR=$S(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX)
    21         .D:PSOX<$P(^PS(59,+PSOSITE,PSOY),"^",3) ^DIE K DIE,X,Y L -^PS(59,+PSOSITE,PSOY)
    22         .I $D(PSONEW("RX #")) L -^PSRX("B",PSONEW("RX #"))
    23         .K PSOX,PSOY Q
    24         Q:$G(COPY)
    25 TRY     S $P(^PSRX(PSORENW("OIRXN"),"STA"),"^")=15,DA=PSORENW("OIRXN")
    26         S $P(^PSRX(DA,3),"^",5)=DT,$P(^PSRX(DA,3),"^",10)=$P(^PSRX(DA,3),"^")
    27         D REVERSE^PSOBPSU1(DA,,"DC",7),CAN^PSOTPCAN(DA)
    28         D RMP^PSOCAN3                ;*244
    29         ;cancel/discontinue action
    30         S PHARM="",STAT="RP",COMM="Prescription discontinued due to editing." D EN^PSOHLSN1(DA,STAT,PHARM,COMM,PSONOOR) K STAT,PHARM,COMM
    31         S ACOM="Discontinued due to editing. New Rx created "_$P(^PSRX(PSORENW("IRXN"),0),"^")_"."
    32         I $G(^PSRX(DA,"H"))]"" D
    33         .I $P(^PSRX(DA,"STA"),"^")=3!($P(^("STA"),"^")=16) D
    34         ..S DIE=52,DR="22///"_$P(^PSRX(DA,3),"^") D ^DIE S ACOM="Discontinued due to editing while on hold. " K:$P(^PSRX(DA,"H"),"^") ^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA)
    35         ..S ^PSRX(DA,"H")=""
    36         S RXDA=DA,(DA,SUSDA)=$O(^PS(52.5,"B",RXDA,0)) D:DA
    37         .S SUSD=$P($G(^PS(52.5,DA,0)),"^",2)
    38         .S:+$G(^PS(52.5,DA,"P"))'=1 ACOM="Discontinued due to editing while suspended."
    39         .I $O(^PSRX(RXDA,1,0)) S DA=RXDA D:'$G(^PS(52.5,+SUSDA,"P")) REF^PSOCAN2
    40         .S DA=SUSDA,DIK="^PS(52.5," D ^DIK K DIK
    41         K SUSD,SUSDA S DA=RXDA,RXREF=0,PSODFN=+$P(^PSRX(DA,0),"^",2) D
    42         .S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(DA,"A",SUB)) Q:'SUB  S ACNT=SUB
    43         .S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF  S RFCNT=RF S:RF>5 RFCNT=RF+1
    44         .D NOW^%DTC S ^PSRX(DA,"A",0)="^52.3DA^"_(ACNT+1)_"^"_(ACNT+1),^PSRX(DA,"A",ACNT+1,0)=%_"^C^"_DUZ_"^"_RFCNT_"^"_$G(ACOM)
    45         .I $G(PSOOIFLG),'$G(PSOMRFLG) S $P(^PSRX(DA,"A",ACNT+1,1),"^")="Pharmacy Orderable Item Edited."
    46         .I '$G(PSOOIFLG),$G(PSOMRFLG) S $P(^PSRX(DA,"A",ACNT+1,1),"^")="Medication Route/Schedule Edited."
    47         .I $G(PSOOIFLG),$G(PSOMRFLG) S $P(^PSRX(DA,"A",ACNT+1,1),"^")="Pharmacy Orderable Item and Medication Route/Schedule Edited."
    48         .S REA="C" D EXP^PSOHELP1
    49         I $G(^PS(52.4,DA,0))]"" S PSCDA=DA,DIK="^PS(52.4," D ^DIK S DA=PSCDA K DIK,PSCDA
    50         Q
    51 INS     K X,QUIT,Y,DIR,DIRUT,DUOUT,DTOUT,DIC,INSDEL,UPMI,^TMP($J,"INS1")
    52         I '$O(^PSRX(PSORXED("IRXN"),6,0)),'$O(PSORXED("DOSE",0)) D UPMI Q:$G(QUIT)  ;G INS1
    53         I $G(^PSRX(PSORXED("IRXN"),"INS"))]"" S PSORXED("FLD",114)=^PSRX(PSORXED("IRXN"),"INS") K UPMI G INS1
    54         K DD,GG F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"INS1",I)) Q:'I  S DD=$G(DD)+1
    55         I $G(DD)=1 S PSORXED("FLD",114)=^PSRX(PSORXED("IRXN"),"INS1",$O(^PSRX(PSORXED("IRXN"),"INS1",0)),0) K UPMI,DD G INS1
    56         I $O(^PSRX(PSORXED("IRXN"),"INS1",0)) D  G INSX
    57         .F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"INS1",I)) Q:'I  S ^TMP($J,"INS1",I,0)=^PSRX(PSORXED("IRXN"),"INS1",I,0)
    58         .S ^TMP($J,"INS1",0)=^PSRX(PSORXED("IRXN"),"INS1",0)
    59         .S DIC="^TMP($J,""INS1"",",DWPK=2,DWLW=80 D EN^DIWE I $G(X)="^" K ^TMP($J,"INS1") Q
    60         .I '$O(^TMP($J,"INS1",0)) S INSDEL=1
    61         .S D=0 F  S D=$O(^PSRX(PSORXED("IRXN"),"INS1",D)) Q:'D  S PSORXED("SIG",D)=^PSRX(PSORXED("IRXN"),"INS1",D,0)
    62 INS1    K Y,DIR,DIRUT,DUOUT,DTOUT,DIC,X
    63         I $G(UPMI) K UPMI I $G(^PS(50.7,PSODRUG("OI"),"INS"))]"" S PSORXED("FLD",114)=^PS(50.7,PSODRUG("OI"),"INS")
    64         S:$G(PSORXED("FLD",114))]"" DIR("B")=PSORXED("FLD",114)
    65         S DIR("?")="Enter Quick codes or Free Text",DIR(0)="52,114" D ^DIR
    66         I $D(DTOUT)!($D(DUOUT))!($G(PSORXED("FLD",114))=X) K PSORXED("FLD",114) G INSX
    67         I X'="",X'="@" D SIG^PSOHELP G INS1:'$D(X)
    68         S PSORXED("FLD",114)=X
    69         I $G(INS1)]"" W " ("_$E(INS1,2,9999999)_")"
    70         G:(X']""!(X="@")) INSX
    71         S (PSORXED("INS"),PSORXED("SIG",1))=$E(INS1,2,9999999) D EN^PSOFSIG(.PSORXED)
    72 INSX    I $P($G(^PS(55,PSODFN,"LAN")),"^") K DIR D
    73         .I $G(^PSRX(PSORXED("IRXN"),"INSS"))]"" S PSORXED("SINS")=^PSRX(PSORXED("IRXN"),"INSS")
    74         .D SINS^PSODIR(.PSORXED) I $G(PSORXED("SINS"))']"" K ^PSRX(PSORXED("IRXN"),"INSS") Q
    75         .S PSORXED("FLD",114.1)=PSORXED("SINS")
    76         K DIRUT,DUOUT,DTOUT,DIR,X,Y,DIC,DWPK
    77         Q
    78 INIT    ;setup psorenw array
    79         S PSORENW("RX0")=^PSRX(PSORENW("IRXN"),0),PSORENW("RX2")=^(2),PSORENW("RX3")=^(3),PSORENW("STA")=^("STA"),PSORENW("TN")=$G(^("TN"))
    80         I $G(PSOSIGFL),$G(PSORX("SIG"))]"" S PSORENW("SIG")=PSORX("SIG"),SIGOK=0
    81         E  D
    82         .I '$P($G(^PSRX(PSORENW("IRXN"),"SIG")),"^",2) S PSORENW("SIG")=$P($G(^("SIG")),"^")
    83         .E  D
    84         ..S SIGOK=1 Q:$O(SIG(0))
    85         ..S D=0 F I=0:0 S D=D+1,I=$O(^PSRX(PSORENW("IRXN"),"SIG1",I)) Q:'I  S SIG(D)=^PSRX(PSORENW("IRXN"),"SIG1",I,0)
    86         ..K PSOX1,D
    87         S PSORENW("OIRXN")=PSORENW("IRXN")
    88         S PSORENW("PROVIDER")=$S($G(PSORENW("PROVIDER")):PSORENW("PROVIDER"),1:$P(PSORENW("RX0"),"^",4))
    89         S (PSORENW("PROVIDER NAME"),PSORX("PROVIDER NAME"))=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^")
    90         I $P($G(^VA(200,PSORENW("PROVIDER"),"PS")),"^",7),$P($G(^("PS")),"^",8) S PSORENW("COSIGNING PROVIDER")=$P($G(^("PS")),"^",8)
    91         S PSORENW("CLINIC")=$S($G(PSORENW("CLINIC")):PSORENW("CLINIC"),1:$P(PSORENW("RX0"),"^",5))
    92         S PSORENW("REMARKS")="New Order Created by "_$S($G(COPY)&('$G(PSOEDIT)):"copying",1:"editing")_" Rx # "_$P(PSORENW("RX0"),"^")_"."
    93         S PSORENW("COSIGNER")=$S($G(PSORENW("COSIGNER")):PSORENW("COSIGNER"),$P(PSORENW("RX3"),"^",3):$P(PSORENW("RX3"),"^",3),1:"")
    94         K:PSORENW("COSIGNER")="" PSORENW("COSIGNER")
    95         S PSORENW("PSODFN")=$P(PSORENW("RX0"),"^",2)
    96         S PSORENW("ORX #")=$P(PSORENW("RX0"),"^")
    97         S:$G(PSODRUG("IEN")) PSORENW("DRUG IEN")=PSODRUG("IEN")
    98         I $G(PSORENW("DAYS SUPPLY")) G QTY
    99         S PSORENW("DAYS SUPPLY")=$S($D(CLOZPAT):7,1:$P(PSORENW("RX0"),"^",8))
    100 QTY     S PSORENW("QTY")=$S($G(PSORENW("QTY")):PSORENW("QTY"),1:$P(PSORENW("RX0"),"^",7))
    101 RFN     S PSORENW("# OF REFILLS")=$S($D(CLOZPAT):0,$G(PSORENW("# OF REFILLS")):PSORENW("# OF REFILLS"),1:$P(PSORENW("RX0"),"^",9))
    102         S (PSOID,Y,PSORENW("FILL DATE"),PSORENW("ISSUE DATE"))=DT
    103         S:PSORENW("CLINIC") PSORX("CLINIC")=$P(^SC(+PSORENW("CLINIC"),0),"^")
    104         S PSORENW("PATIENT STATUS")=$S($G(PSORENW("PATIENT STATUS")):PSORENW("PATIENT STATUS"),'$P(PSORENW("RX0"),"^",3):$G(^PS(55,PSORENW("PSODFN"),"PS")),1:$P(PSORENW("RX0"),"^",3))
    105         S PSORENW("PTST NODE")=$G(^PS(53,PSORENW("PATIENT STATUS"),0))
    106         S PSDAYS=$S($G(PSORENW("DAYS SUPPLY")):PSORENW("DAYS SUPPLY"),'$P(PSORENW("RX0"),"^",8):$P(PSORENW("PTST NODE"),"^",3),1:$P(PSORENW("RX0"),"^",8))
    107         I $G(PSODRUG("IEN")) S DREN=PSODRUG("IEN"),POERR=1 D DRG^PSOORDRG K POERR
    108         D:$G(PSORENW("# OF REFILLS"))']"" RF
    109         S PSORENW("MAIL/WINDOW")=$S($G(PSORENW("MAIL/WINDOW"))]"":PSORENW("MAIL/WINDOW"),1:$P(PSORENW("RX0"),"^",11))
    110         S PSORX("MAIL/WINDOW")=$S(PSORENW("MAIL/WINDOW")="W":"WINDOW",1:"MAIL")
    111         S PSORENW("COPIES")=$S($G(PSORENW("COPIES")):PSORENW("COPIES"),$P(PSORENW("RX0"),"^",18):$P(PSORENW("RX0"),"^",18),1:1)
    112         S PSORENW("CLERK CODE")=DUZ
    113         S:$G(PSORX("CLERK CODE"))']"" PSORX("CLERK CODE")=$P($G(^VA(200,DUZ,0)),"^")
    114         Q:$D(COPY)  S PSORENW("ENT")=0 ;Q:$G(PSOSIGFL)!($D(COPY))
    115         K PSORENW("ENT") F I=0:0 S I=$O(PSORENW("DOSE",I)) Q:'I  S PSORENW("ENT")=$G(PSORENW("ENT"))+1
    116         I $O(^TMP($J,"INS1",0)) D
    117         .K PSORXED("SIG"),DD
    118         .F I=0:0 S I=$O(^TMP($J,"INS1",I)) Q:'I  S PSORENW("SIG",I)=^TMP($J,"INS1",I,0)
    119         .K ^TMP($J,"INS1")
    120         I $G(^PSRX(PSORENW("IRXN"),"INS"))]"" S PSORENW("INS")=^PSRX(PSORENW("IRXN"),"INS")
    121         I $G(^PSRX(PSORENW("IRXN"),"INSS"))]"" S PSORENW("SINS")=^PSRX(PSORENW("IRXN"),"INSS")
    122         I '$G(PSORENW("ENT")),'$G(PSOSIGFL) D DOLST1^PSOORED3(.PSORENW) S PSORENW("ENT")=+$G(OLENT)
    123         Q
    124 RF      ;# of refills
    125         S PTRF=$S($P(PSORENW("PTST NODE"),"^",4)]"":$P(PSORENW("PTST NODE"),"^",4),1:11)
    126         S CS=0 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S CS=1
    127         I CS D
    128         .S PSOX1=$S(PTRF>5:5,1:PTRF),PSOX=$S(PSOX1=5:5,1:PSOX1)
    129         .S PSOX=$S('PSOX:0,PSDAYS=90:1,1:PSOX),PSDY1=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0) S PSORENW("# OF REFILLS")=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
    130         E  D
    131         .S PSOX1=PTRF,PSOX=$S(PSOX1=11:11,1:PSOX1),PSOX=$S('PSOX:0,PSDAYS=90:3,1:PSOX)
    132         .S PSDY1=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0) S PSORENW("# OF REFILLS")=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
    133         I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) S PSORENW("# OF REFILLS")=0
    134         K PSDY,PSDY1,PTRF,PSOX,PSOX1,PSDAYS,CS
    135         Q
    136 UPMI    ;add dosing data for pre-poe rxs
    137         W !! K PSONEW("DFLG"),DIR,DIRUT,DTOUT,DUOUT S DIR(0)="Y",DIR("B")="No",DIR("A")="Dosing Instructions Are Missing!! Do You Want to Add Them"
    138         D ^DIR I 'Y!($D(DIRUT)) S QUIT=1 K DIR,DIRUT,DUOT,DUOUT Q
    139         S UPMI=1,EDTHLD=$G(PSORX("EDIT")) K PSORX("EDIT")
    140         D DOSE1^PSOORED5(.PSORXED) S (PSORXED,PSORX("EDIT"))=EDTHLD K EDTHLD I $G(PSONEW("DFLG")) S QUIT=1
    141         Q
     1PSOORED1 ;ISC-BHAM/SAB - edit orders from backdoor ;6/30/06 10:21am
     2 ;;7.0;OUTPATIENT PHARMACY;**5,23,46,78,114,117,131,146,223,148,244,249,268**;DEC 1997;Build 9
     3 ;External reference ^PS(55 supported by DBIA 2228
     4 ;External reference ^PS(50.7 supported by DBIA 2223
     5 ;
     6 ;*244 call to remove DC'd Rx's from Rx ien strings
     7 ;
     8EN(PSORENW) ;
     9 N LST,ORD,ORN K VALMBCK,PSORX("FN") S PSOAC=1,(PSORX("QFLG"),PSORX("DFLG"))=0 ;D DREN^PSOORNW2,INIT
     10 D INIT
     11 D @$S($P(PSOPAR,"^",7):"AUTO^PSONRXN",1:"MANUAL^PSONRXN")
     12 I '$D(PSONEW("RX #")),'$P(PSOPAR,"^",7) D PAUSE^VALM1 K VALMSG,PSONEW("QFLG") S VALMBCK="Q" Q
     13 I '$D(PSONEW("RX #")) K VALMSG D DEL^PSONEW,PAUSE^VALM1 S VALMBCK="Q" Q
     14 S PSORENW("RX #")=PSONEW("RX #") I '$P(PSOPAR,"^",7) D  Q:$G(PSONEW("DFLG"))!($G(PSONEW("QFLG")))
     15 .S PSOX=PSORENW("RX #") D CHECK^PSONRXN
     16 I $G(PSONEW("DFLG"))!$G(PSONEW("QFLG")) D DEL^PSONEW,PAUSE^VALM1 S VALMBCK="Q" K PSORENW Q
     17 D EN^PSOORNE1(.PSORENW) I '$G(PSORX("FN")) D:$P($G(PSOPAR),"^",7)=1  S VALMBCK="Q" Q
     18 .S DIE="^PS(59,",DA=PSOSITE,PSOY=$O(PSONEW("OLD LAST RX#","")),PSOX=PSONEW("OLD LAST RX#",PSOY)
     19 .L +^PS(59,+PSOSITE,PSOY):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
     20 .S DR=$S(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX)
     21 .D:PSOX<$P(^PS(59,+PSOSITE,PSOY),"^",3) ^DIE K DIE,X,Y L -^PS(59,+PSOSITE,PSOY)
     22 .I $D(PSONEW("RX #")) L -^PSRX("B",PSONEW("RX #"))
     23 .K PSOX,PSOY Q
     24 Q:$G(COPY)
     25TRY S $P(^PSRX(PSORENW("OIRXN"),"STA"),"^")=15,DA=PSORENW("OIRXN")
     26 S $P(^PSRX(DA,3),"^",5)=DT,$P(^PSRX(DA,3),"^",10)=$P(^PSRX(DA,3),"^")
     27 D REVERSE^PSOBPSU1(DA,,"DC",7),CAN^PSOTPCAN(DA)
     28 D RMP^PSOCAN3                ;*244
     29 ;cancel/discontinue action
     30 S PHARM="",STAT="RP",COMM="Prescription discontinued due to editing." D EN^PSOHLSN1(DA,STAT,PHARM,COMM,PSONOOR) K STAT,PHARM,COMM
     31 S ACOM="Discontinued due to editing. New Rx created "_$P(^PSRX(PSORENW("IRXN"),0),"^")_"."
     32 I $G(^PSRX(DA,"H"))]"" D
     33 .I $P(^PSRX(DA,"STA"),"^")=3!($P(^("STA"),"^")=16) D
     34 ..S DIE=52,DR="22///"_$P(^PSRX(DA,3),"^") D ^DIE S ACOM="Discontinued due to editing while on hold. " K:$P(^PSRX(DA,"H"),"^") ^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA)
     35 ..S ^PSRX(DA,"H")=""
     36 S RXDA=DA,(DA,SUSDA)=$O(^PS(52.5,"B",RXDA,0)) D:DA
     37 .S SUSD=$P($G(^PS(52.5,DA,0)),"^",2)
     38 .S:+$G(^PS(52.5,DA,"P"))'=1 ACOM="Discontinued due to editing while suspended."
     39 .I $O(^PSRX(RXDA,1,0)) S DA=RXDA D:'$G(^PS(52.5,+SUSDA,"P")) REF^PSOCAN2
     40 .S DA=SUSDA,DIK="^PS(52.5," D ^DIK K DIK
     41 K SUSD,SUSDA S DA=RXDA,RXREF=0,PSODFN=+$P(^PSRX(DA,0),"^",2) D
     42 .S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(DA,"A",SUB)) Q:'SUB  S ACNT=SUB
     43 .S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF  S RFCNT=RF S:RF>5 RFCNT=RF+1
     44 .D NOW^%DTC S ^PSRX(DA,"A",0)="^52.3DA^"_(ACNT+1)_"^"_(ACNT+1),^PSRX(DA,"A",ACNT+1,0)=%_"^C^"_DUZ_"^"_RFCNT_"^"_$G(ACOM)
     45 .I $G(PSOOIFLG),'$G(PSOMRFLG) S $P(^PSRX(DA,"A",ACNT+1,1),"^")="Pharmacy Orderable Item Edited."
     46 .I '$G(PSOOIFLG),$G(PSOMRFLG) S $P(^PSRX(DA,"A",ACNT+1,1),"^")="Medication Route/Schedule Edited."
     47 .I $G(PSOOIFLG),$G(PSOMRFLG) S $P(^PSRX(DA,"A",ACNT+1,1),"^")="Pharmacy Orderable Item and Medication Route/Schedule Edited."
     48 .S REA="C" D EXP^PSOHELP1
     49 I $G(^PS(52.4,DA,0))]"" S PSCDA=DA,DIK="^PS(52.4," D ^DIK S DA=PSCDA K DIK,PSCDA
     50 Q
     51INS K X,QUIT,Y,DIR,DIRUT,DUOUT,DTOUT,DIC,INSDEL,UPMI,^TMP($J,"INS1")
     52 I '$O(^PSRX(PSORXED("IRXN"),6,0)),'$O(PSORXED("DOSE",0)) D UPMI Q:$G(QUIT)  ;G INS1
     53 I $G(^PSRX(PSORXED("IRXN"),"INS"))]"" S PSORXED("FLD",114)=^PSRX(PSORXED("IRXN"),"INS") K UPMI G INS1
     54 K DD,GG F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"INS1",I)) Q:'I  S DD=$G(DD)+1
     55 I $G(DD)=1 S PSORXED("FLD",114)=^PSRX(PSORXED("IRXN"),"INS1",$O(^PSRX(PSORXED("IRXN"),"INS1",0)),0) K UPMI,DD G INS1
     56 I $O(^PSRX(PSORXED("IRXN"),"INS1",0)) D  G INSX
     57 .F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"INS1",I)) Q:'I  S ^TMP($J,"INS1",I,0)=^PSRX(PSORXED("IRXN"),"INS1",I,0)
     58 .S ^TMP($J,"INS1",0)=^PSRX(PSORXED("IRXN"),"INS1",0)
     59 .S DIC="^TMP($J,""INS1"",",DWPK=2,DWLW=80 D EN^DIWE I $G(X)="^" K ^TMP($J,"INS1") Q
     60 .I '$O(^TMP($J,"INS1",0)) S INSDEL=1
     61 .S D=0 F  S D=$O(^PSRX(PSORXED("IRXN"),"INS1",D)) Q:'D  S PSORXED("SIG",D)=^PSRX(PSORXED("IRXN"),"INS1",D,0)
     62INS1 K Y,DIR,DIRUT,DUOUT,DTOUT,DIC,X
     63 I $G(UPMI) K UPMI I $G(^PS(50.7,PSODRUG("OI"),"INS"))]"" S PSORXED("FLD",114)=^PS(50.7,PSODRUG("OI"),"INS")
     64 S:$G(PSORXED("FLD",114))]"" DIR("B")=PSORXED("FLD",114)
     65 S DIR("?")="Enter Quick codes or Free Text",DIR(0)="52,114" D ^DIR
     66 I $D(DTOUT)!($D(DUOUT))!($G(PSORXED("FLD",114))=X) K PSORXED("FLD",114) G INSX
     67 I X'="",X'="@" D SIG^PSOHELP G INS1:'$D(X)
     68 S PSORXED("FLD",114)=X
     69 I $G(INS1)]"" W " ("_$E(INS1,2,9999999)_")"
     70 G:(X']""!(X="@")) INSX
     71 S (PSORXED("INS"),PSORXED("SIG",1))=$E(INS1,2,9999999) D EN^PSOFSIG(.PSORXED)
     72INSX I $P($G(^PS(55,PSODFN,"LAN")),"^") K DIR D
     73 .I $G(^PSRX(PSORXED("IRXN"),"INSS"))]"" S PSORXED("SINS")=^PSRX(PSORXED("IRXN"),"INSS")
     74 .D SINS^PSODIR(.PSORXED) I $G(PSORXED("SINS"))']"" K ^PSRX(PSORXED("IRXN"),"INSS") Q
     75 .S PSORXED("FLD",114.1)=PSORXED("SINS")
     76 K DIRUT,DUOUT,DTOUT,DIR,X,Y,DIC,DWPK
     77 Q
     78INIT ;setup psorenw array
     79 S PSORENW("RX0")=^PSRX(PSORENW("IRXN"),0),PSORENW("RX2")=^(2),PSORENW("RX3")=^(3),PSORENW("STA")=^("STA"),PSORENW("TN")=$G(^("TN"))
     80 I $G(PSOSIGFL),$G(PSORX("SIG"))]"" S PSORENW("SIG")=PSORX("SIG"),SIGOK=0
     81 E  D
     82 .I '$P($G(^PSRX(PSORENW("IRXN"),"SIG")),"^",2) S PSORENW("SIG")=$P($G(^("SIG")),"^")
     83 .E  D
     84 ..S SIGOK=1 Q:$O(SIG(0))
     85 ..S D=0 F I=0:0 S D=D+1,I=$O(^PSRX(PSORENW("IRXN"),"SIG1",I)) Q:'I  S SIG(D)=^PSRX(PSORENW("IRXN"),"SIG1",I,0)
     86 ..K PSOX1,D
     87 S PSORENW("OIRXN")=PSORENW("IRXN")
     88 S PSORENW("PROVIDER")=$S($G(PSORENW("PROVIDER")):PSORENW("PROVIDER"),1:$P(PSORENW("RX0"),"^",4))
     89 S (PSORENW("PROVIDER NAME"),PSORX("PROVIDER NAME"))=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^")
     90 I $P($G(^VA(200,PSORENW("PROVIDER"),"PS")),"^",7),$P($G(^("PS")),"^",8) S PSORENW("COSIGNING PROVIDER")=$P($G(^("PS")),"^",8)
     91 S PSORENW("CLINIC")=$S($G(PSORENW("CLINIC")):PSORENW("CLINIC"),1:$P(PSORENW("RX0"),"^",5))
     92 S PSORENW("REMARKS")="New Order Created by "_$S($G(COPY)&('$G(PSOEDIT)):"copying",1:"editing")_" Rx # "_$P(PSORENW("RX0"),"^")_"."
     93 S PSORENW("COSIGNER")=$S($G(PSORENW("COSIGNER")):PSORENW("COSIGNER"),$P(PSORENW("RX3"),"^",3):$P(PSORENW("RX3"),"^",3),1:"")
     94 K:PSORENW("COSIGNER")="" PSORENW("COSIGNER")
     95 S PSORENW("PSODFN")=$P(PSORENW("RX0"),"^",2)
     96 S PSORENW("ORX #")=$P(PSORENW("RX0"),"^")
     97 S:$G(PSODRUG("IEN")) PSORENW("DRUG IEN")=PSODRUG("IEN")
     98 I $G(PSORENW("DAYS SUPPLY")) G QTY
     99 S PSORENW("DAYS SUPPLY")=$S($D(CLOZPAT):7,1:$P(PSORENW("RX0"),"^",8))
     100QTY S PSORENW("QTY")=$S($G(PSORENW("QTY")):PSORENW("QTY"),1:$P(PSORENW("RX0"),"^",7))
     101RFN S PSORENW("# OF REFILLS")=$S($D(CLOZPAT):0,$G(PSORENW("# OF REFILLS")):PSORENW("# OF REFILLS"),1:$P(PSORENW("RX0"),"^",9))
     102 S (PSOID,Y,PSORENW("FILL DATE"),PSORENW("ISSUE DATE"))=DT
     103 S:PSORENW("CLINIC") PSORX("CLINIC")=$P(^SC(+PSORENW("CLINIC"),0),"^")
     104 S PSORENW("PATIENT STATUS")=$S($G(PSORENW("PATIENT STATUS")):PSORENW("PATIENT STATUS"),'$P(PSORENW("RX0"),"^",3):$G(^PS(55,PSORENW("PSODFN"),"PS")),1:$P(PSORENW("RX0"),"^",3))
     105 S PSORENW("PTST NODE")=$G(^PS(53,PSORENW("PATIENT STATUS"),0))
     106 S PSDAYS=$S($G(PSORENW("DAYS SUPPLY")):PSORENW("DAYS SUPPLY"),'$P(PSORENW("RX0"),"^",8):$P(PSORENW("PTST NODE"),"^",3),1:$P(PSORENW("RX0"),"^",8))
     107 I $G(PSODRUG("IEN")) S DREN=PSODRUG("IEN"),POERR=1 D DRG^PSOORDRG K POERR
     108 D:$G(PSORENW("# OF REFILLS"))']"" RF
     109 S PSORENW("MAIL/WINDOW")=$S($G(PSORENW("MAIL/WINDOW"))]"":PSORENW("MAIL/WINDOW"),1:$P(PSORENW("RX0"),"^",11))
     110 S PSORX("MAIL/WINDOW")=$S(PSORENW("MAIL/WINDOW")="W":"WINDOW",1:"MAIL")
     111 S PSORENW("COPIES")=$S($G(PSORENW("COPIES")):PSORENW("COPIES"),$P(PSORENW("RX0"),"^",18):$P(PSORENW("RX0"),"^",18),1:1)
     112 S PSORENW("CLERK CODE")=DUZ
     113 S:$G(PSORX("CLERK CODE"))']"" PSORX("CLERK CODE")=$P($G(^VA(200,DUZ,0)),"^")
     114 Q:$D(COPY)  S PSORENW("ENT")=0 ;Q:$G(PSOSIGFL)!($D(COPY))
     115 K PSORENW("ENT") F I=0:0 S I=$O(PSORENW("DOSE",I)) Q:'I  S PSORENW("ENT")=$G(PSORENW("ENT"))+1
     116 I $O(^TMP($J,"INS1",0)) D
     117 .K PSORXED("SIG"),DD
     118 .F I=0:0 S I=$O(^TMP($J,"INS1",I)) Q:'I  S PSORENW("SIG",I)=^TMP($J,"INS1",I,0)
     119 .K ^TMP($J,"INS1")
     120 I $G(^PSRX(PSORENW("IRXN"),"INS"))]"" S PSORENW("INS")=^PSRX(PSORENW("IRXN"),"INS")
     121 I $G(^PSRX(PSORENW("IRXN"),"INSS"))]"" S PSORENW("SINS")=^PSRX(PSORENW("IRXN"),"INSS")
     122 I '$G(PSORENW("ENT")),'$G(PSOSIGFL) D DOLST1^PSOORED3(.PSORENW) S PSORENW("ENT")=+$G(OLENT)
     123 Q
     124RF ;# of refills
     125 S PTRF=$S($P(PSORENW("PTST NODE"),"^",4)]"":$P(PSORENW("PTST NODE"),"^",4),1:11)
     126 S CS=0 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S CS=1
     127 I CS D
     128 .S PSOX1=$S(PTRF>5:5,1:PTRF),PSOX=$S(PSOX1=5:5,1:PSOX1)
     129 .S PSOX=$S('PSOX:0,PSDAYS=90:1,1:PSOX),PSDY1=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0) S PSORENW("# OF REFILLS")=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
     130 E  D
     131 .S PSOX1=PTRF,PSOX=$S(PSOX1=11:11,1:PSOX1),PSOX=$S('PSOX:0,PSDAYS=90:3,1:PSOX)
     132 .S PSDY1=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0) S PSORENW("# OF REFILLS")=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
     133 I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") S PSORENW("# OF REFILLS")=0
     134 K PSDY,PSDY1,PTRF,PSOX,PSOX1,PSDAYS,CS
     135 Q
     136UPMI ;add dosing data for pre-poe rxs
     137 W !! K PSONEW("DFLG"),DIR,DIRUT,DTOUT,DUOUT S DIR(0)="Y",DIR("B")="No",DIR("A")="Dosing Instructions Are Missing!! Do You Want to Add Them"
     138 D ^DIR I 'Y!($D(DIRUT)) S QUIT=1 K DIR,DIRUT,DUOT,DUOUT Q
     139 S UPMI=1,EDTHLD=$G(PSORX("EDIT")) K PSORX("EDIT")
     140 D DOSE1^PSOORED5(.PSORXED) S (PSORXED,PSORX("EDIT"))=EDTHLD K EDTHLD I $G(PSONEW("DFLG")) S QUIT=1
     141 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED2.m

    r613 r623  
    1 PSOORED2        ;ISC-BHAM/SAB-edit orders from backdoor con't ;03/06/95 10:24
    2         ;;7.0;OUTPATIENT PHARMACY;**2,51,46,78,102,114,117,133,159,148,247,260,281**;DEC 1997;Build 41
    3         ;Reference to $$DIVNCPDP^BPSBUTL supported by IA 4719
    4         ;Reference to $$ECMEON^BPSUTIL supported by IA 4410
    5         ;called from psooredt. cmop edit checks.
    6         Q
    7 ISDT    D CHK K RF I $G(CMRL) W !,"Released by CMOP.  No editing allowed on Issue Date." D PAUSE^VALM1 K CMRL Q
    8         S %DT="AEX",%DT(0)=-$P(^PSRX(DA,2),"^",2),Y=$P(RX0,"^",13) X ^DD("DD") S %DT("A")="ISSUE DATE: ",%DT("B")=Y D ^%DT I "^"[$E(X) K X,Y,%DT,DTOUT,DUOUT Q
    9         G:Y=-1 ISDT S PSORXED("FLD",1)=Y
    10         ;S DR="1///"_Y,DIE=52 D ^DIE
    11         D KV K X,Y,%DT
    12         Q
    13 FLDT    D CHK K RF I $G(CMRL) W !,"Released by CMOP.  No editing allowed on Fill Date." D PAUSE^VALM1 K CMRL Q
    14         D KV S Y=$P(^PSRX(DA,2),"^",2) X ^DD("DD") S DIR("A")="FILL DATE",DIR("B")=Y
    15         S DIR(0)="D^"_$P(RX0,"^",13)_":"_$P(PSORXED("RX2"),"^",6)_":EX"
    16         S DIR("?",1)="The earliest fill date allowed is determined by the Issue Date,",DIR("?",2)="the Fill Date cannot be before the Issue Date or past the Expiration Date."
    17         S DIR("?")="Both the month and day are required." D ^DIR
    18         I $D(DIRUT) D KV K PSORXED("FLD",22),X,Y Q
    19         S PSORXED("FLD",22)=Y ;S DR="22R///"_Y,DIE=52 D ^DIE
    20         K X,Y
    21 KV      K DIR,DUOUT,DTOUT,DIRUT
    22         Q
    23 CHK     I $D(^PSRX("AR",+$P(PSORXED("RX2"),"^",13),PSORXED("IRXN"))) S CMRL=1 Q
    24         F RF=0:0 S RF=$O(^PSRX(PSORXED("IRXN"),1,RF)) Q:'RF  I $D(^PSRX("AR",+$P(^PSRX(PSORXED("IRXN"),1,RF,0),"^",18),PSORXED("IRXN"))) S CMRL=1
    25         Q
    26 CHK1    I +^PSRX(PSORXED("IRXN"),"STA")=5 D  Q:'$G(CMRL)
    27         .S SURX=$O(^PS(52.5,PSORXED("IRXN"),0)) Q:'SURX  I $P(^PS(52.5,SURX,0),"^",7)']""!($P(^(0),"^",7)="Q") S CMRL=1
    28         .E  S CMRL=0
    29         F FEV=0:0 S FEV=$O(^PSRX(PSORXED("IRXN"),4,FEV)) Q:'FEV  I '$P(^PSRX(PSORXED("IRXN"),4,FEV,0),"^",3),$P(^(0),"^",4)<3 S CMRL=0
    30         Q
    31 REF     ;shows refill info
    32         S RFN=0 F N=0:0 S N=$O(^PSRX(PSORXED("IRXN"),1,N)) Q:'N  S RFM=N,RFN=RFN+1
    33         ;G:RFM=1 SRF
    34         W ! K DA,DR D KV S DIR(0)="Y",DIR("B")="No",DIR("A")="There "_$S(RFN>1:"are ",1:"is ")_RFN_" refill"_$S(RFN>1:"s.",1:".")_"  Do you want to edit"
    35         D ^DIR D KV Q:'Y
    36 SRF     W !!,"#  Log Date   Refill Date  Qty               Routing  Lot #       Pharmacist",! F I=1:1:80 W "="
    37         F N=0:0 S N=$O(^PSRX(PSORXED("IRXN"),1,N)) Q:'N  S P1=^(N,0) D
    38         .S DTT=$P(P1,"^",8)\1 D DAT S LOG=DAT,DTT=$P(P1,"^"),$P(RN," ",10)=" " D DAT
    39         .W !,N_"  "_LOG_"   "_DAT_"      "_$P(P1,"^",4)_$E("               ",$L($P(P1,"^",4))+1,15)_"  "_$S($P(P1,"^",2)="M":"MAIL  ",1:"WINDOW")_"   "_$P(P1,"^",6)_$E(RN,$L($P(P1,"^",6))+1,12)
    40         .W $E($S($D(^VA(200,+$P(P1,"^",5),0)):$P(^(0),"^"),1:""),1,16)
    41         .S PSDIV=$S($D(^PS(59,+$P(P1,"^",9),0)):$P(^(0),"^",6),1:"Unknown") W !,"Division: "_PSDIV_$E("        ",$L(PSDIV)+1,8)_"  "
    42         .W "Dispensed: "_$S($P(P1,"^",19):$E($P(P1,"^",19),4,5)_"/"_$E($P(P1,"^",19),6,7)_"/"_$E($P(P1,"^",19),2,3),1:"")_"  "
    43         .S RTS=$S($P(P1,"^",16):" Returned to Stock: "_$E($P(P1,"^",16),4,5)_"/"_$E($P(P1,"^",16),6,7)_"/"_$E($P(P1,"^",16),2,3),1:" Released: "_$S($P(P1,"^",18):$E($P(P1,"^",18),4,5)_"/"_$E($P(P1,"^",18),6,7)_"/"_$E($P(P1,"^",18),2,3),1:""))
    44         .W RTS W:$P(P1,"^",3)]"" !,"   Remarks: "_$P(P1,"^",3)
    45         S DA(1)=PSORXED("IRXN") I RFN=1 S Y=RFM G RFM
    46         W ! D KV S DIR("A")="Select a Refill",DIR(0)="NO^1:"_RFM_":0" D ^DIR Q:$D(DIRUT)
    47 RFM     I '$D(^PSRX(PSORXED("IRXN"),1,Y,0)) W !,$C(7),"Invalid selection.",! G SRF
    48         S CMRL=0 I $D(^PSRX("AR",+$P(^PSRX(PSORXED("IRXN"),1,Y,0),"^",18),PSORXED("IRXN"),Y)) S CMRL=1 G RFX
    49         F FEV=0:0 S FEV=$O(^PSRX(PSORXED("IRXN"),4,FEV)) Q:'FEV  I $P(^PSRX(PSORXED("IRXN"),4,FEV,0),"^",3)=Y,$P(^(0),"^",4)<3 S CMRL=1
    50 RFX     N RFL,NDC,DAW,FLDS,QUIT,CHGNDC,CHANGED
    51         W ! S DA=Y,DIE="^PSRX("_DA(1)_",1,",DR=$S('CMRL:".01;1.1",1:"1.2:5;8")
    52         D GETS^DIQ(52.1,DA_","_DA(1)_",",".01;1;1.1;8;11;81","I","FLDS")
    53         S:$D(^PSRX(DA(1),1,DA,0)) PSORXED("RX1")=^PSRX(DA(1),1,DA,0),(RFED,RFL)=DA
    54         I $G(ST)=11!($G(ST)=12),$$STATUS^PSOBPSUT(PSORXED("IRXN"),RFL)'="" S QUIT=0 D RFE Q  ;short circuit for DC'd/Expired ECME RXs
    55         D ^DIE S QUIT=$D(Y) K FEV,RFN,RFM,X,Y,DR
    56         I '$G(DA) D REVERSE^PSOBPSU1(PSORXED("IRXN"),RFL,"DE",5) K CMRL,RFED D:$D(PSORX("PSOL"))&($G(DI)=.01) RFD Q
    57         I 'CMRL,'QUIT S DR="1;1.2:5;8" D ^DIE S QUIT=$D(Y)
    58 RFE     I '$D(^PSRX(PSORXED("IRXN"),1,RFL)) Q
    59         I 'QUIT,$$STATUS^PSOBPSUT(PSORXED("IRXN"),RFL)'="" D
    60         . S NDC=$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL)
    61         . D EDTDAW^PSODAWUT(PSORXED("IRXN"),RFL,.DAW) I $G(DAW)="^" Q
    62         . D SAVDAW^PSODAWUT(PSORXED("IRXN"),RFL,+$G(DAW))
    63         . D NDC^PSODRG(PSORXED("IRXN"),RFL,,.NDC) I $G(NDC)="^",$G(NDC)="" Q
    64         . I NDC'=$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL) D
    65         . . S CHGNDC=1 D RXACT^PSOBPSU2(PSORXED("IRXN"),RFL,"NDC changed from "_$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL)_" to "_NDC_".","E")
    66         . D SAVNDC^PSONDCUT(PSORXED("IRXN"),RFL,NDC)
    67         S CHANGED=$$CHANGED(PSORXED("IRXN"),RFL,.FLDS)
    68         I CHANGED D
    69         . I $P(CHANGED,"^",2),'$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(PSORXED("IRXN"),RFL)) D  Q
    70         . . D REVERSE^PSOBPSU1(PSORXED("IRXN"),RFL,"DC",99,"REFILL DIVISION CHANGED",1)
    71         . I $$SUBMIT^PSOBPSUT(PSORXED("IRXN"),RFL,1,1) D
    72         . . N RX S RX=PSORXED("IRXN")
    73         . . I '$P(CHANGED,"^",2),$$STATUS^PSOBPSUT(RX,RFL)="" Q
    74         . . D ECMESND^PSOBPSU1(RX,RFL,,"ED",$$GETNDC^PSONDCUT(RX,RFL),,$S($P(CHANGED,"^",2):"REFILL DIVISION CHANGED",1:"REFILL EDITED"),,+$G(CHGNDC))
    75         . . ;- Checking/Handling DUR/79 Rejects
    76         . . I $$FIND^PSOREJUT(RX,RFL) S X=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","Q")
    77         K DIE,CMRL,DA,DR
    78         Q
    79 CHANGED(RX,RFL,PRIOR)   ; - Check if fields have changed and should for 3rd Party Claim resubmission
    80         ;Input:  (r) RX    - Rx IEN
    81         ;        (r) RFL   - Refill #
    82         ;        (r) PRIOR - Array with fields
    83         ;Output:  CHANGED  - 0 - Not changed / 1 - Refill field changed ^ Rx Division changed (1 - YES)
    84         N CHANGED,SAVED
    85         S CHANGED=0 D GETS^DIQ(52.1,RFL_","_RX_",",".01;1;1.1;8;11;81","I","SAVED")
    86         F I=.01,1,1.1,11,81 I $G(PRIOR(52.1,RFL_","_RX_",",I,"I"))'=$G(SAVED(52.1,RFL_","_RX_",",I,"I")) S CHANGED=1 Q
    87         I $$DIVNCPDP^BPSBUTL(+$G(PRIOR(52.1,RFL_","_RX_",",8,"I")))'=$$DIVNCPDP^BPSBUTL(+$G(SAVED(52.1,RFL_","_RX_",",8,"I"))) S CHANGED="1^1"
    88         Q CHANGED
    89         ;
    90 DAT     S DAT="",DTT=DTT\1 Q:DTT'?7N  S DAT=$E(DTT,4,5)_"/"_$E(DTT,6,7)_"/"_$E(DTT,2,3)
    91         Q
    92 DIE     S DIE=52 D ^DIE I $D(Y) S PSORXED("DFLG")=1
    93         K DIE,DR,X,Y
    94         Q
    95 RFD     ;check for deleted refill
    96         M PSOZ1("PSOL")=PSORX("PSOL") N I,J,K,PSOX2,PSOX3,PSOX9 S (I,K)=0 D
    97         .F  S I=$O(PSOZ1("PSOL",I)) Q:'I!(K)  S PSOX2=PSOZ1("PSOL",I) I PSOX2[(PSORXED("IRXN")_",") S PSOX9="" D
    98         ..F J=1:1 S PSOX3=$P(PSOX2,",",J) Q:'PSOX3  D
    99         ...I 'K,PSOX3=PSORXED("IRXN") S K=1
    100         ...E  S PSOX9=PSOX9_$S('PSOX9:"",1:",")_PSOX3
    101         ..I K S:PSOX9]"" PSORX("PSOL",I)=PSOX9_"," K:PSOX9="" PSORX("PSOL",I)
    102         K PSOZ1("PSOL")
    103         Q
    104 EDTDOSE ;edit med instructions fields
    105         I '$O(^PSRX(PSORXED("IRXN"),6,0)) D DOSE^PSOORED5 Q
    106         D ^PSOORED3
    107         Q
    108 UPD     ;updates dosing array
    109         S HENT=ENT
    110 UPD1    I $G(PSORXED("CONJUNCTION",(HENT+1)))]"",'$D(PSORXED("DOSE",(HENT+2))) K PSORXED("CONJUNCTION",(HENT+1)) Q
    111         I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" S PSORXED("CONJUNCTION",HENT)=PSORXED("CONJUNCTION",(HENT+1)) D  G UPD1
    112         .K PSORXED("CONJUNCTION",(HENT+1))
    113         .F  Q:'$D(PSORXED("DOSE",(HENT+2)))  D
    114         ..S PSORXED("DOSE",(HENT+1))=PSORXED("DOSE",(HENT+2))
    115         ..S PSORXED("DOSE ORDERED",(HENT+1))=$G(PSORXED("DOSE ORDERED",(HENT+2)))
    116         ..S PSORXED("UNITS",(HENT+1))=$G(PSORXED("UNITS",(HENT+2)))
    117         ..S PSORXED("NOUN",(HENT+1))=$G(PSORXED("NOUN",(HENT+2)))
    118         ..S PSORXED("DURATION",(HENT+1))=$G(PSORXED("DURATION",(HENT+2)))
    119         ..S PSORXED("CONJUNCTION",(HENT+1))=$G(PSORXED("CONJUNCTION",(HENT+2)))
    120         ..S PSORXED("ROUTE",(HENT+1))=$G(PSORXED("ROUTE",(HENT+2)))
    121         ..S PSORXED("SCHEDULE",(HENT+1))=$G(PSORXED("SCHEDULE",(HENT+2)))
    122         ..S PSORXED("ODOSE",(HENT+1))=$G(PSORXED("ODOSE",(HENT+2)))
    123         ..S HENT=HENT+1
    124         ..I $G(PSORXED("CONJUNCTION",(HENT+2)))]"" Q
    125         ..K PSORXED("UNITS",(HENT+1)),PSORXED("NOUN",(HENT+1)),PSORXED("DURATION",(HENT+1)),PSORXED("CONJUNCTION",(HENT+1)),PSORXED("ROUTE",(HENT+1)),PSORXED("SCHEDULE",(HENT+1)),PSORXED("DOSE",(HENT+1)),PSORXED("DOSE ORDERED",(HENT+1))
    126         ..K PSORXED("VERB",(HENT+1)),PSORXED("ODOSE",(HENT+1))
    127         S PSORXED("ENT")=HENT K HENT,SENT D EN^PSOFSIG(.PSORXED)
    128         Q
    129 UPD2    I $G(PSORXED("CONJUNCTION",(HENT+1)))]"",'$D(PSORXED("DOSE",(HENT+2))) K PSORXED("CONJUNCTION",(HENT+1)) Q
    130         I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" S PSORXED("CONJUNCTION",HENT)=PSORXED("CONJUNCTION",(HENT+1)) D  G UPD1
    131         .K PSORXED("CONJUNCTION",(HENT+1)) I $D(PSORXED("DOSE",(HENT+2))) D
    132         ..S PSORXED("DOSE",(HENT+1))=PSORXED("DOSE",(HENT+2))
    133         ..S PSORXED("DOSE ORDERED",(HENT+1))=$G(PSORXED("DOSE ORDERED",(HENT+2)))
    134         ..S PSORXED("UNITS",(HENT+1))=$G(PSORXED("UNITS",(HENT+2)))
    135         ..S PSORXED("NOUN",(HENT+1))=$G(PSORXED("NOUN",(HENT+2)))
    136         ..S PSORXED("VERB",(HENT+1))=$G(PSORXED("VERB",(HENT+2)))
    137         ..S PSORXED("DURATION",(HENT+1))=$G(PSORXED("DURATION",(HENT+2)))
    138         ..S PSORXED("CONJUNCTION",(HENT+1))=$G(PSORXED("CONJUNCTION",(HENT+2)))
    139         ..S PSORXED("ROUTE",(HENT+1))=$G(PSORXED("ROUTE",(HENT+2)))
    140         ..S PSORXED("SCHEDULE",(HENT+1))=$G(PSORXED("SCHEDULE",(HENT+2)))
    141         ..S PSORXED("ODOSE",(HENT+1))=$G(PSORXED("ODOSE",(HENT+2)))
    142         ..S HENT=HENT+1
    143         ..I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" Q
    144         ..K PSORXED("UNITS",(HENT+1)),PSORXED("NOUN",(HENT+1)),PSORXED("DURATION",(HENT+1)),PSORXED("ROUTE",(HENT+1)),PSORXED("SCHEDULE",(HENT+1)),PSORXED("DOSE",(HENT+1)),PSORXED("DOSE ORDERED",(HENT+1)),PSORXED("VERB",(HENT+1))
    145         ..K PSORXED("ODOSE",(HENT+1))
    146         F I=0:0 S I=$O(PSORXED("DOSE",I)) Q:'I  S SENT=$G(SENT)+1
    147         S PSORXED("ENT")=SENT K HENT,SENT D EN^PSOFSIG(.PSORXED)
    148         Q
     1PSOORED2 ;ISC-BHAM/SAB-edit orders from backdoor con't ;03/06/95 10:24
     2 ;;7.0;OUTPATIENT PHARMACY;**2,51,46,78,102,114,117,133,159,148,247,260**;DEC 1997;Build 84
     3 ;Reference to $$DIVNCPDP^BPSBUTL supported by IA 4719
     4 ;Reference to $$ECMEON^BPSUTIL supported by IA 4410
     5 ;called from psooredt. cmop edit checks.
     6 Q
     7ISDT D CHK K RF I $G(CMRL) W !,"Released by CMOP.  No editing allowed on Issue Date." D PAUSE^VALM1 K CMRL Q
     8 S %DT="AEX",%DT(0)=-$P(^PSRX(DA,2),"^",2),Y=$P(RX0,"^",13) X ^DD("DD") S %DT("A")="ISSUE DATE: ",%DT("B")=Y D ^%DT I "^"[$E(X) K X,Y,%DT,DTOUT,DUOUT Q
     9 G:Y=-1 ISDT S PSORXED("FLD",1)=Y
     10 ;S DR="1///"_Y,DIE=52 D ^DIE
     11 D KV K X,Y,%DT
     12 Q
     13FLDT D CHK K RF I $G(CMRL) W !,"Released by CMOP.  No editing allowed on Fill Date." D PAUSE^VALM1 K CMRL Q
     14 D KV S Y=$P(^PSRX(DA,2),"^",2) X ^DD("DD") S DIR("A")="FILL DATE",DIR("B")=Y
     15 S DIR(0)="D^"_$P(RX0,"^",13)_":"_$P(PSORXED("RX2"),"^",6)_":EX"
     16 S DIR("?",1)="The earliest fill date allowed is determined by the Issue Date,",DIR("?",2)="the Fill Date cannot be before the Issue Date or past the Expiration Date."
     17 S DIR("?")="Both the month and day are required." D ^DIR
     18 I $D(DIRUT) D KV K PSORXED("FLD",22),X,Y Q
     19 S PSORXED("FLD",22)=Y ;S DR="22R///"_Y,DIE=52 D ^DIE
     20 K X,Y
     21KV K DIR,DUOUT,DTOUT,DIRUT
     22 Q
     23CHK I $D(^PSRX("AR",+$P(PSORXED("RX2"),"^",13),PSORXED("IRXN"))) S CMRL=1 Q
     24 F RF=0:0 S RF=$O(^PSRX(PSORXED("IRXN"),1,RF)) Q:'RF  I $D(^PSRX("AR",+$P(^PSRX(PSORXED("IRXN"),1,RF,0),"^",18),PSORXED("IRXN"))) S CMRL=1
     25 Q
     26CHK1 I +^PSRX(PSORXED("IRXN"),"STA")=5 D  Q:'$G(CMRL)
     27 .S SURX=$O(^PS(52.5,PSORXED("IRXN"),0)) Q:'SURX  I $P(^PS(52.5,SURX,0),"^",7)']""!($P(^(0),"^",7)="Q") S CMRL=1
     28 .E  S CMRL=0
     29 F FEV=0:0 S FEV=$O(^PSRX(PSORXED("IRXN"),4,FEV)) Q:'FEV  I '$P(^PSRX(PSORXED("IRXN"),4,FEV,0),"^",3),$P(^(0),"^",4)<3 S CMRL=0
     30 Q
     31REF ;shows refill info
     32 S RFN=0 F N=0:0 S N=$O(^PSRX(PSORXED("IRXN"),1,N)) Q:'N  S RFM=N,RFN=RFN+1
     33 ;G:RFM=1 SRF
     34 W ! K DA,DR D KV S DIR(0)="Y",DIR("B")="No",DIR("A")="There "_$S(RFN>1:"are ",1:"is ")_RFN_" refill"_$S(RFN>1:"s.",1:".")_"  Do you want to edit"
     35 D ^DIR D KV Q:'Y
     36SRF W !!,"#  Log Date   Refill Date  Qty               Routing  Lot #       Pharmacist",! F I=1:1:80 W "="
     37 F N=0:0 S N=$O(^PSRX(PSORXED("IRXN"),1,N)) Q:'N  S P1=^(N,0) D
     38 .S DTT=$P(P1,"^",8)\1 D DAT S LOG=DAT,DTT=$P(P1,"^"),$P(RN," ",10)=" " D DAT
     39 .W !,N_"  "_LOG_"   "_DAT_"      "_$P(P1,"^",4)_$E("               ",$L($P(P1,"^",4))+1,15)_"  "_$S($P(P1,"^",2)="M":"MAIL  ",1:"WINDOW")_"   "_$P(P1,"^",6)_$E(RN,$L($P(P1,"^",6))+1,12)
     40 .W $E($S($D(^VA(200,+$P(P1,"^",5),0)):$P(^(0),"^"),1:""),1,16)
     41 .S PSDIV=$S($D(^PS(59,+$P(P1,"^",9),0)):$P(^(0),"^",6),1:"Unknown") W !,"Division: "_PSDIV_$E("        ",$L(PSDIV)+1,8)_"  "
     42 .W "Dispensed: "_$S($P(P1,"^",19):$E($P(P1,"^",19),4,5)_"/"_$E($P(P1,"^",19),6,7)_"/"_$E($P(P1,"^",19),2,3),1:"")_"  "
     43 .S RTS=$S($P(P1,"^",16):" Returned to Stock: "_$E($P(P1,"^",16),4,5)_"/"_$E($P(P1,"^",16),6,7)_"/"_$E($P(P1,"^",16),2,3),1:" Released: "_$S($P(P1,"^",18):$E($P(P1,"^",18),4,5)_"/"_$E($P(P1,"^",18),6,7)_"/"_$E($P(P1,"^",18),2,3),1:""))
     44 .W RTS W:$P(P1,"^",3)]"" !,"   Remarks: "_$P(P1,"^",3)
     45 S DA(1)=PSORXED("IRXN") I RFN=1 S Y=RFM G RFM
     46 W ! D KV S DIR("A")="Select a Refill",DIR(0)="NO^1:"_RFM_":0" D ^DIR Q:$D(DIRUT)
     47RFM I '$D(^PSRX(PSORXED("IRXN"),1,Y,0)) W !,$C(7),"Invalid selection.",! G SRF
     48 S CMRL=0 I $D(^PSRX("AR",+$P(^PSRX(PSORXED("IRXN"),1,Y,0),"^",18),PSORXED("IRXN"),Y)) S CMRL=1 G RFX
     49 F FEV=0:0 S FEV=$O(^PSRX(PSORXED("IRXN"),4,FEV)) Q:'FEV  I $P(^PSRX(PSORXED("IRXN"),4,FEV,0),"^",3)=Y,$P(^(0),"^",4)<3 S CMRL=1
     50RFX N RFL,NDC,DAW,FLDS,QUIT,CHGNDC,CHANGED
     51 W ! S DA=Y,DIE="^PSRX("_DA(1)_",1,",DR=$S('CMRL:".01;1.1",1:"1.2:5;8")
     52 D GETS^DIQ(52.1,DA_","_DA(1)_",",".01;1;1.1;8;11;81","I","FLDS")
     53 S:$D(^PSRX(DA(1),1,DA,0)) PSORXED("RX1")=^PSRX(DA(1),1,DA,0),(RFED,RFL)=DA
     54 D ^DIE S QUIT=$D(Y) K FEV,RFN,RFM,X,Y,DR
     55 I '$G(DA) D REVERSE^PSOBPSU1(PSORXED("IRXN"),RFL,"DE",5) K CMRL,RFED D:$D(PSORX("PSOL"))&($G(DI)=.01) RFD Q
     56 I 'CMRL,'QUIT S DR="1;1.2:5;8" D ^DIE S QUIT=$D(Y)
     57 I '$D(^PSRX(PSORXED("IRXN"),1,RFL)) Q
     58 I 'QUIT,$$STATUS^PSOBPSUT(PSORXED("IRXN"),RFL)'="" D
     59 . S NDC=$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL)
     60 . D EDTDAW^PSODAWUT(PSORXED("IRXN"),RFL,.DAW) I $G(DAW)="^" Q
     61 . D SAVDAW^PSODAWUT(PSORXED("IRXN"),RFL,+$G(DAW))
     62 . D NDC^PSODRG(PSORXED("IRXN"),RFL,,.NDC) I $G(NDC)="^",$G(NDC)="" Q
     63 . I NDC'=$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL) D
     64 . . S CHGNDC=1 D RXACT^PSOBPSU2(PSORXED("IRXN"),RFL,"NDC changed from "_$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL)_" to "_NDC_".","E")
     65 . D SAVNDC^PSONDCUT(PSORXED("IRXN"),RFL,NDC)
     66 S CHANGED=$$CHANGED(PSORXED("IRXN"),RFL,.FLDS)
     67 I CHANGED D
     68 . I $P(CHANGED,"^",2),'$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(PSORXED("IRXN"),RFL)) D  Q
     69 . . D REVERSE^PSOBPSU1(PSORXED("IRXN"),RFL,"DC",99,"REFILL DIVISION CHANGED",1)
     70 . I $$SUBMIT^PSOBPSUT(PSORXED("IRXN"),RFL,1,1) D
     71 . . N RX S RX=PSORXED("IRXN")
     72 . . I '$P(CHANGED,"^",2),$$STATUS^PSOBPSUT(RX,RFL)="" Q
     73 . . D ECMESND^PSOBPSU1(RX,RFL,,"ED",$$GETNDC^PSONDCUT(RX,RFL),,$S($P(CHANGED,"^",2):"REFILL DIVISION CHANGED",1:"REFILL EDITED"),,+$G(CHGNDC))
     74 . . ;- Checking/Handling DUR/79 Rejects
     75 . . I $$FIND^PSOREJUT(RX,RFL) S X=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","I")
     76 K DIE,CMRL,DA,DR
     77 Q
     78CHANGED(RX,RFL,PRIOR) ; - Check if fields have changed and should for 3rd Party Claim resubmission
     79 ;Input:  (r) RX    - Rx IEN
     80 ;        (r) RFL   - Refill #
     81 ;        (r) PRIOR - Array with fields
     82 ;Output:  CHANGED  - 0 - Not changed / 1 - Refill field changed ^ Rx Division changed (1 - YES)
     83 N CHANGED,SAVED
     84 S CHANGED=0 D GETS^DIQ(52.1,RFL_","_RX_",",".01;1;1.1;8;11;81","I","SAVED")
     85 F I=.01,1,1.1,11,81 I $G(PRIOR(52.1,RFL_","_RX_",",I,"I"))'=$G(SAVED(52.1,RFL_","_RX_",",I,"I")) S CHANGED=1 Q
     86 I $$DIVNCPDP^BPSBUTL(+$G(PRIOR(52.1,RFL_","_RX_",",8,"I")))'=$$DIVNCPDP^BPSBUTL(+$G(SAVED(52.1,RFL_","_RX_",",8,"I"))) S CHANGED="1^1"
     87 Q CHANGED
     88 ;
     89DAT S DAT="",DTT=DTT\1 Q:DTT'?7N  S DAT=$E(DTT,4,5)_"/"_$E(DTT,6,7)_"/"_$E(DTT,2,3)
     90 Q
     91DIE S DIE=52 D ^DIE I $D(Y) S PSORXED("DFLG")=1
     92 K DIE,DR,X,Y
     93 Q
     94RFD ;check for deleted refill
     95 M PSOZ1("PSOL")=PSORX("PSOL") N I,J,K,PSOX2,PSOX3,PSOX9 S (I,K)=0 D
     96 .F  S I=$O(PSOZ1("PSOL",I)) Q:'I!(K)  S PSOX2=PSOZ1("PSOL",I) I PSOX2[(PSORXED("IRXN")_",") S PSOX9="" D
     97 ..F J=1:1 S PSOX3=$P(PSOX2,",",J) Q:'PSOX3  D
     98 ...I 'K,PSOX3=PSORXED("IRXN") S K=1
     99 ...E  S PSOX9=PSOX9_$S('PSOX9:"",1:",")_PSOX3
     100 ..I K S:PSOX9]"" PSORX("PSOL",I)=PSOX9_"," K:PSOX9="" PSORX("PSOL",I)
     101 K PSOZ1("PSOL")
     102 Q
     103EDTDOSE ;edit med instructions fields
     104 I '$O(^PSRX(PSORXED("IRXN"),6,0)) D DOSE^PSOORED5 Q
     105 D ^PSOORED3
     106 Q
     107UPD ;updates dosing array
     108 S HENT=ENT
     109UPD1 I $G(PSORXED("CONJUNCTION",(HENT+1)))]"",'$D(PSORXED("DOSE",(HENT+2))) K PSORXED("CONJUNCTION",(HENT+1)) Q
     110 I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" S PSORXED("CONJUNCTION",HENT)=PSORXED("CONJUNCTION",(HENT+1)) D  G UPD1
     111 .K PSORXED("CONJUNCTION",(HENT+1))
     112 .F  Q:'$D(PSORXED("DOSE",(HENT+2)))  D
     113 ..S PSORXED("DOSE",(HENT+1))=PSORXED("DOSE",(HENT+2))
     114 ..S PSORXED("DOSE ORDERED",(HENT+1))=$G(PSORXED("DOSE ORDERED",(HENT+2)))
     115 ..S PSORXED("UNITS",(HENT+1))=$G(PSORXED("UNITS",(HENT+2)))
     116 ..S PSORXED("NOUN",(HENT+1))=$G(PSORXED("NOUN",(HENT+2)))
     117 ..S PSORXED("DURATION",(HENT+1))=$G(PSORXED("DURATION",(HENT+2)))
     118 ..S PSORXED("CONJUNCTION",(HENT+1))=$G(PSORXED("CONJUNCTION",(HENT+2)))
     119 ..S PSORXED("ROUTE",(HENT+1))=$G(PSORXED("ROUTE",(HENT+2)))
     120 ..S PSORXED("SCHEDULE",(HENT+1))=$G(PSORXED("SCHEDULE",(HENT+2)))
     121 ..S PSORXED("ODOSE",(HENT+1))=$G(PSORXED("ODOSE",(HENT+2)))
     122 ..S HENT=HENT+1
     123 ..I $G(PSORXED("CONJUNCTION",(HENT+2)))]"" Q
     124 ..K PSORXED("UNITS",(HENT+1)),PSORXED("NOUN",(HENT+1)),PSORXED("DURATION",(HENT+1)),PSORXED("CONJUNCTION",(HENT+1)),PSORXED("ROUTE",(HENT+1)),PSORXED("SCHEDULE",(HENT+1)),PSORXED("DOSE",(HENT+1)),PSORXED("DOSE ORDERED",(HENT+1))
     125 ..K PSORXED("VERB",(HENT+1)),PSORXED("ODOSE",(HENT+1))
     126 S PSORXED("ENT")=HENT K HENT,SENT D EN^PSOFSIG(.PSORXED)
     127 Q
     128UPD2 I $G(PSORXED("CONJUNCTION",(HENT+1)))]"",'$D(PSORXED("DOSE",(HENT+2))) K PSORXED("CONJUNCTION",(HENT+1)) Q
     129 I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" S PSORXED("CONJUNCTION",HENT)=PSORXED("CONJUNCTION",(HENT+1)) D  G UPD1
     130 .K PSORXED("CONJUNCTION",(HENT+1)) I $D(PSORXED("DOSE",(HENT+2))) D
     131 ..S PSORXED("DOSE",(HENT+1))=PSORXED("DOSE",(HENT+2))
     132 ..S PSORXED("DOSE ORDERED",(HENT+1))=$G(PSORXED("DOSE ORDERED",(HENT+2)))
     133 ..S PSORXED("UNITS",(HENT+1))=$G(PSORXED("UNITS",(HENT+2)))
     134 ..S PSORXED("NOUN",(HENT+1))=$G(PSORXED("NOUN",(HENT+2)))
     135 ..S PSORXED("VERB",(HENT+1))=$G(PSORXED("VERB",(HENT+2)))
     136 ..S PSORXED("DURATION",(HENT+1))=$G(PSORXED("DURATION",(HENT+2)))
     137 ..S PSORXED("CONJUNCTION",(HENT+1))=$G(PSORXED("CONJUNCTION",(HENT+2)))
     138 ..S PSORXED("ROUTE",(HENT+1))=$G(PSORXED("ROUTE",(HENT+2)))
     139 ..S PSORXED("SCHEDULE",(HENT+1))=$G(PSORXED("SCHEDULE",(HENT+2)))
     140 ..S PSORXED("ODOSE",(HENT+1))=$G(PSORXED("ODOSE",(HENT+2)))
     141 ..S HENT=HENT+1
     142 ..I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" Q
     143 ..K PSORXED("UNITS",(HENT+1)),PSORXED("NOUN",(HENT+1)),PSORXED("DURATION",(HENT+1)),PSORXED("ROUTE",(HENT+1)),PSORXED("SCHEDULE",(HENT+1)),PSORXED("DOSE",(HENT+1)),PSORXED("DOSE ORDERED",(HENT+1)),PSORXED("VERB",(HENT+1))
     144 ..K PSORXED("ODOSE",(HENT+1))
     145 F I=0:0 S I=$O(PSORXED("DOSE",I)) Q:'I  S SENT=$G(SENT)+1
     146 S PSORXED("ENT")=SENT K HENT,SENT D EN^PSOFSIG(.PSORXED)
     147 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED6.m

    r613 r623  
    1 PSOORED6        ;BIR/SAB - edit orders from backdoor ;03/06/96
    2         ;;7.0;OUTPATIENT PHARMACY;**78,104,117,133,143,219,148,247,268,260,269**;DEC 1997;Build 4
    3         ;External reference to ^PSDRUG supported by DBIA 221
    4         ;External reference to ^PS(50.7 supported by DBIA 2223
    5         ;External reference ^PS(50.606 supported by DBIA 2174
    6 DRG     ;select drug
    7         S PSORX("EDIT")=1,RX0HLD=RX0
    8         S PSODRUG("IEN")=$S($G(PSODRUG("IEN"))]"":PSODRUG("IEN"),1:$P(RX0,"^",6)),PSODRUG("NAME")=$S($G(PSODRUG("NAME"))]"":PSODRUG("NAME"),1:$P(^PSDRUG($P(RX0,"^",6),0),"^"))
    9         D ^PSODRG I PSODRUG("IEN")=$P(RX0,"^",6) K PSORXED("FLD",6)
    10         D:PSODRUG("IEN")'=$P(RX0,"^",6)  I $G(PSORX("DFLG")) K PSORXED("FLD",6) S PSORXED("DFLG")=1 Q
    11         .D POST^PSODRG
    12         .I '$O(^PSRX(PSORXED("IRXN"),1,0)) S PSORXED("FLD",17)=$G(PSODRUG("COST"))
    13         .I $G(PSORX("DFLG")) K PSORXED("FLD",6),PSODRUG,PSOOIFLG,PSOSIGFL,VALMSG Q
    14         .D KV S DIR(0)="Y",DIR("B")="YES"
    15         .S DIR("A",1)="You have changed the dispense drug from"
    16         .S DIR("A",2)=$P(^PSDRUG($P(PSORXED("RX0"),"^",6),0),"^")_" to "_$P(^PSDRUG(PSODRUG("IEN"),0),"^")_"."
    17         .I $P($G(^PSRX(PSORXED("IRXN"),"SIG")),"^",2),$O(^PSRX(PSORXED("IRXN"),"SIG1",0)) S DIR("A",3)="" D
    18         ..F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"SIG1",I)) Q:'I  S DIR("A",3+I)=$S(I=1:"Current SIG: ",1:"")_$G(^PSRX(PSORXED("IRXN"),"SIG1",I,0))
    19         .S DIR("A")="Do You want to Edit the SIG"
    20         .D ^DIR K DIR I $D(DIRUT) S PSORX("DFLG")=1 D M1
    21         .Q:$D(DIRUT)!('Y)
    22         .S PSOREEDQ=1 D DOLST^PSOORED3,DOSE^PSOORED3 K PSOREEDQ
    23         .I '$O(PSORXED("DOSE",0)) S PSORX("DFLG")=1 Q
    24         .D:$G(PSOSIGFL) M2
    25         S RX0=RX0HLD K RX0HLD I $G(PSODRUG("OI"))=$G(PSOI) D  Q
    26         .D:$O(^TMP("PSORXDC",$J,0))
    27         ..W !!,"This edit will discontinue the duplicate Rx & change the dispensed drug!"
    28         ..K DIR,X,Y S DIR("A")="Do You Want to Proceed",DIR("B")="NO",DIR(0)="Y"
    29         ..D ^DIR K DIR S:'Y!($D(DIRUT)) PSORXED("DFLG")=1 D:Y DCORD^PSONEW2
    30         .Q:$G(PSORXED("DFLG"))
    31         .I PSODRUG("IEN")'=$P(RX0,"^",6) D
    32         ..S PSORXED("FLD",6)=PSODRUG("IEN"),PSORXED("FLD",39.2)=PSOI
    33         .S:$G(PSODRUG("TRADE NAME"))]"" PSORXED("FLD",6.5)=PSODRUG("TRADE NAME")
    34         .S:$G(PSODRUG("NDC"))]"" PSORXED("FLD",27)=PSODRUG("NDC")
    35         .S:$G(PSODRUG("DAW"))]"" PSORXED("FLD",81)=PSODRUG("DAW")
    36         W !!,"New Orderable Item selected. This edit will create a new prescription!",! D PAUSE^VALM1 S VALMSG="New Orderable Item selected. This edit will create a new prescription!" S (PSOOIFLG,PSOSIGFL)=1
    37         Q
    38 PSOCOU  ;patient counseling
    39         K DIC,DIQ S DIC=52,DA=PSORXED("IRXN"),DIQ="PSORXED",DR=41 D EN^DIQ1 K DIC,DIQ
    40         D KV S DIR(0)="52,41" S:$G(PSORXED(52,DA,DR))]"" DIR("B")=PSORXED(52,DA,DR) D ^DIR K DIR,PSORXED(52,DA,DR)
    41         I $D(DIRUT) K PSORXED("FLD",41) D KV Q
    42         S PSORXED("FLD",DR)=Y D  K DIRUT
    43         .I Y D  Q
    44         ..K DIC,DIQ S DIC=52,DA=PSORXED("IRXN"),DIQ="PSORXED",DR=42 D EN^DIQ1 K DIC,DIQ
    45         ..K DIR,DIRUT S DIR(0)="52,42" S:$G(PSORXED(52,DA,DR))]"" DIR("B")=PSORXED(52,DA,DR) D ^DIR K DIR,PSORXED(52,DA,DR)
    46         ..I $D(DIRUT) K PSORXED("FLD",41),DUOUT,DTOUT Q
    47         ..S PSORXED("FLD",42)=Y
    48         .S PSORXED("FLD",41)=0,PSORXED("FLD",42)="@"
    49         Q
    50 PSOI    ;select orderable item
    51         W !!,"Current Orderable Item: "_$P(^PS(50.7,PSOI,0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")
    52         S DIC("B")=$P(^PS(50.7,PSOI,0),"^"),DIC="^PS(50.7,",DIC(0)="AEMQZ"
    53         S DIC("S")="I '$P(^PS(50.7,+Y,0),""^"",4)!($P(^(0),""^"",4)'<DT) N PSOF,PSOL S (PSOF,PSOL)=0 F  S PSOL=$O(^PSDRUG(""ASP"",+Y,PSOL)) Q:PSOF!'PSOL  "
    54         S DIC("S")=DIC("S")_"I $P($G(^PSDRUG(PSOL,2)),U,3)[""O"",'$G(^(""I""))!($G(^(""I""))'<DT) S PSOF=1"
    55         ;BHW;PSO*7*269;Modify ^DIC call to call MIX^DIC to use only the B and C Cross-References.
    56         S D="B^C" D MIX^DIC1 I "^"[X S PSORXED("DFLG")=1 Q
    57         G:Y<1 PSOI Q:PSOI=+Y
    58         S PSODRUG("OI")=+Y,PSODRUG("OIN")=Y(0,0) K DIC
    59         I PSOI'=PSODRUG("OI") W !!,"New Orderable Item selected. This edit will create a new prescription!",! D  K PSHOLDD Q
    60         .D PAUSE^VALM1,M2
    61         .S PSHOLDD=$G(PSODRUG("IEN")) K PSODRUG("IEN"),PSODRUG("NAME") S PSODRUG("DEA")="",(PSOOIFLG,PSOSIGFL)=1
    62         .D DREN^PSOORNW2
    63         .I $G(PSHOLDD),$G(PSODRUG("IEN")),$G(PSHOLDD)'=$G(PSODRUG("IEN")) D  Q:$G(PSORX("DFLG"))
    64         ..D FULL^VALM1,POST^PSODRG S VALMBCK="R"
    65         ..I $G(PSORX("DFLG")) K PSODRUG S PSODRUG("IEN")=$G(PSHOLDD),PSODRUG("NAME")=$P($G(^PSDRUG(PSODRUG("IEN"),0)),"^") K PSOOIFLG,PSOSIGFL S VALMSG=""
    66         .I '$G(PSODRUG("IEN")) W !!,"DRUG NAME REQUIRED!" D 2^PSOORNW1
    67         .I '$G(PSODRUG("IEN")) K PSORXED("FLD"),INDEL,^TMP($J,"INS1"),PSOSIGFL,VALMSG S PSORXED("DFLG")=1,VALMSG="Dispense Drug NOT Selected!" Q
    68         .D KV S DIR(0)="Y",DIR("B")="NO",DIR("A",1)="You have changed the Orderable Item from",DIR("A",2)=$P(^PS(50.7,PSOI,0),"^")_" to "_PSODRUG("OIN")_".",DIR("A")="Do You want to Edit the SIG"
    69         .D ^DIR K DIR I $D(DIRUT) K PSODRUG("OIN"),PSOOIFLG,PSOSIGFL S PSODRUG("OI")=PSOI,VALMSG="",PSORX("DFLG")=1 Q
    70         .I 'Y S PSORX("DFLG")=1 Q
    71         .S PSOREEDQ=1 D DOLST^PSOORED3,DOSE^PSOORED3 K PSOREEDQ
    72         .I '$O(PSORXED("DOSE",0)) S PSORX("DFLG")=1 Q
    73         .D:$G(PSOSIGFL) M2
    74         S PSORXED("FLD",39.2)=PSOI
    75         Q
    76 NCPDP   ;Reverse previously billed Rx on an edited orderable item or drug.
    77         N RX,NPSOY
    78         S RX=$G(PSORXED("IRXN")) I RX="" D
    79         . S NPSOY=$O(PSONEW("OLD LAST RX#","")),NPSOY=$G(PSONEW("OLD LAST RX#",NPSOY)),RX=$O(^PSRX("B",NPSOY,RX))
    80         I 'RX Q
    81         D REVERSE^PSOBPSU1(RX,,"DC",7) S NCPDPFLG=0
    82         Q
    83 UPDATE  ;add new data to file
    84         N RXREF,UPDATE,FLDS,CHGNDC
    85         Q:'$G(PSORXED("IRXN"))
    86         I $O(PSORXED("FLD",0))!($G(^TMP($J,"INS1",0))]"")!($G(INSDEL))!($O(PSORXED("ODOSE",0))) D  G:'Y UPDX
    87         .K DIR,DIRUT,DTOUT,DUOUT
    88         .S DIR(0)="Y",DIR("A")="Are You Sure You Want to Update Rx "_$P(^PSRX(PSORXED("IRXN"),0),"^"),DIR("B")="Yes"
    89         .D ^DIR K DIR I 'Y D M1 Q
    90         .I $D(^PSRX(PSORXED("IRXN"),1,0))  D
    91         ..S RXREF=$P(^PSRX(PSORXED("IRXN"),0),"^",9)-$P(^PSRX(PSORXED("IRXN"),1,0),"^",4)
    92         .E  S RXREF=0
    93         .K X,DIRUT,DUOUT,DTOUT
    94         I $D(PSORXED("FLD",39.3)) D UPDATE^PSODIAG  ;update ICD's after edit
    95         ; - Retrieving fields before changes that are relevant for 3rd Party Billing
    96         D GETS^DIQ(52,PSORXED("IRXN")_",","4;7;8;20;22;27;81","I","FLDS")
    97         K Y S DA=PSORXED("IRXN"),DIE="^PSRX(",FLD=0
    98         F  S FLD=$O(PSORXED("FLD",FLD)) Q:'FLD  D
    99         .I FLD=12!(FLD=24)!(FLD=35) D  Q
    100         ..I FLD=12,PSORXED("FLD",12)="@" S $P(^PSRX(DA,3),"^",7)="" Q
    101         ..I FLD=12,PSORXED("FLD",12)]"" S $P(^PSRX(DA,3),"^",7)=PSORXED("FLD",12) Q
    102         ..I FLD=24,PSORXED("FLD",24)="@" S $P(^PSRX(DA,2),"^",4)="" Q
    103         ..I FLD=24,PSORXED("FLD",24)]"" S $P(^PSRX(DA,2),"^",4)=PSORXED("FLD",24) Q
    104         ..I FLD=35,PSORXED("FLD",35)="@" S $P(^PSRX(DA,"MP"),"^")="" Q
    105         ..I FLD=35,PSORXED("FLD",35)]"" S $P(^PSRX(DA,"MP"),"^")=PSORXED("FLD",35) Q
    106         .I FLD=114 D  Q
    107         ..I PSORXED("FLD",114)="@" K ^PSRX(DA,"INS"),^PSRX(DA,"INS1")
    108         ..I PSORXED("FLD",114)'="@" D
    109         ...S ^PSRX(DA,"INS")=PSORXED("FLD",114)
    110         ...S X=PSORXED("FLD",114) D SIG^PSOHELP Q:$G(INS1)']""
    111         ...S PSORXED("SIG",1)=$E(INS1,2,9999999) K ^PSRX(DA,"INS1")
    112         ...S ^PSRX(DA,"INS1",0)="^52.0115^1^1^"_DT_"^^"
    113         ...S ^PSRX(DA,"INS1",1,0)=PSORXED("SIG",1)
    114         ..D DOLST^PSOORED3 K:PSORXED("FLD",114)="@" PSORXED("SIG") D EN^PSOFSIG(.PSORXED),UPDSIG^PSOORED3
    115         .I FLD=27 D  Q
    116         ..I PSORXED("FLD",27)'=$$GETNDC^PSONDCUT(DA,0) D
    117         ...S CHGNDC=1 D RXACT^PSOBPSU2(DA,0,"NDC changed from "_$$GETNDC^PSONDCUT(DA,0)_" to "_PSORXED("FLD",27)_".","E")
    118         ..D SAVNDC^PSONDCUT(DA,0,PSORXED("FLD",27),0,1)
    119         .I FLD=81 D SAVDAW^PSODAWUT(DA,0,PSORXED("FLD",81)) Q
    120         .S DR=FLD_"////"_PSORXED("FLD",FLD) D ^DIE
    121         .I FLD=4 D UDPROV^PSOOREDT Q
    122         ;
    123         ; - Re-submitting Rx to ECME due to edits
    124         D RESUB^PSOORED7
    125         ;
    126         I $G(INSDEL) K ^PSRX(DA,"INS"),^PSRX(DA,"INS1") D DOLST^PSOORED3 K PSORXED("SIG") D EN^PSOFSIG(.PSORXED),UPDSIG^PSOORED3 G UPDX
    127         I $O(^TMP($J,"INS1",0)) D
    128         .K ^PSRX(DA,"INS"),^PSRX(DA,"INS1"),DD,PSORXED("SIG")
    129         .F I=0:0 S I=$O(^TMP($J,"INS1",I)) Q:'I  S (PSORXED("SIG",I),^PSRX(DA,"INS1",I,0))=^TMP($J,"INS1",I,0),DD=$G(DD)+1
    130         .S ^PSRX(DA,"INS1",0)=^TMP($J,"INS1",0)
    131         .I DD=1 S ^PSRX(DA,"INS")=^PSRX(DA,"INS1",1,0)
    132         .D DOLST^PSOORED3,EN^PSOFSIG(.PSORXED),UPDSIG^PSOORED3
    133         ;
    134 UPDX    ;
    135         K DIE,DA,DR,FLD,X,Y,PSORXED("FLD"),DD,^TMP($J,"INS1")
    136 KV      K DIR,DIRUT,DTOUT,DUOUT
    137         Q
    138 UPD     ;updates dosing array
    139         S HENT=ENT
    140 UPD1    ;
    141         I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" S PSORXED("CONJUNCTION",HENT)=PSORXED("CONJUNCTION",(HENT+1)) D  G UPD
    142         .K PSORXED("CONJUNCTION",(HENT+1))
    143         .I $D(PSORXED("DOSE",(HENT+2))) D
    144         ..S PSORXED("DOSE",(HENT+1))=PSORXED("DOSE",(HENT+2))
    145         ..S PSORXED("ODOSE",(HENT+1))=$G(PSORXED("ODOSE",(HENT+2)))
    146         ..S PSORXED("DOSE ORDERED",(HENT+1))=$G(PSORXED("DOSE ORDERED",(HENT+2)))
    147         ..S PSORXED("UNITS",(HENT+1))=$G(PSORXED("UNITS",(HENT+2)))
    148         ..S PSORXED("NOUN",(HENT+1))=$G(PSORXED("NOUN",(HENT+2)))
    149         ..S PSORXED("DURATION",(HENT+1))=$G(PSORXED("DURATION",(HENT+2)))
    150         ..S PSORXED("CONJUNCTION",(HENT+1))=$G(PSORXED("CONJUNCTION",(HENT+2)))
    151         ..S PSORXED("ROUTE",(HENT+1))=$G(PSORXED("ROUTE",(HENT+2)))
    152         ..S PSORXED("SCHEDULE",(HENT+1))=$G(PSORXED("SCHEDULE",(HENT+2)))
    153         ..S PSORXED("VERB",(HENT+1))=$G(PSORXED("VERB",(HENT+2)))
    154         ..K PSORXED("DOSE",(HENT+2)),PSORXED("ODOSE",(HENT+2)),PSORXED("DOSE ORDERED",(HENT+2))
    155         ..K PSORXED("UNITS",(HENT+2)),PSORXED("NOUN",(HENT+2)),PSORXED("DURATION",(HENT+2)),PSORXED("ROUTE",(HENT+2)),PSORXED("SCHEDULE",(HENT+2)),PSORXED("VERB",(HENT+2))
    156         .S HENT=HENT+1
    157         F I=0:0 S I=$O(PSORXED("DOSE",I)) Q:'I  S SENT=$G(SENT)+1
    158         Q
    159         ;
    160 M1      D M1^PSOOREDX
    161         Q
    162 M2      D M2^PSOOREDX
    163         Q
     1PSOORED6 ;BIR/SAB - edit orders from backdoor ;03/06/96
     2 ;;7.0;OUTPATIENT PHARMACY;**78,104,117,133,143,219,148,247,268,260**;DEC 1997;Build 84
     3 ;External reference to ^PSDRUG supported by DBIA 221
     4 ;External reference to ^PS(50.7 supported by DBIA 2223
     5 ;External reference ^PS(50.606 supported by DBIA 2174
     6DRG ;select drug
     7 S PSORX("EDIT")=1,RX0HLD=RX0
     8 S PSODRUG("IEN")=$S($G(PSODRUG("IEN"))]"":PSODRUG("IEN"),1:$P(RX0,"^",6)),PSODRUG("NAME")=$S($G(PSODRUG("NAME"))]"":PSODRUG("NAME"),1:$P(^PSDRUG($P(RX0,"^",6),0),"^"))
     9 D ^PSODRG I PSODRUG("IEN")=$P(RX0,"^",6) K PSORXED("FLD",6)
     10 D:PSODRUG("IEN")'=$P(RX0,"^",6)  I $G(PSORX("DFLG")) K PSORXED("FLD",6) S PSORXED("DFLG")=1 Q
     11 .D POST^PSODRG
     12 .I '$O(^PSRX(PSORXED("IRXN"),1,0)) S PSORXED("FLD",17)=$G(PSODRUG("COST"))
     13 .I $G(PSORX("DFLG")) K PSORXED("FLD",6),PSODRUG,PSOOIFLG,PSOSIGFL,VALMSG Q
     14 .D KV S DIR(0)="Y",DIR("B")="YES"
     15 .S DIR("A",1)="You have changed the dispense drug from"
     16 .S DIR("A",2)=$P(^PSDRUG($P(PSORXED("RX0"),"^",6),0),"^")_" to "_$P(^PSDRUG(PSODRUG("IEN"),0),"^")_"."
     17 .I $P($G(^PSRX(PSORXED("IRXN"),"SIG")),"^",2),$O(^PSRX(PSORXED("IRXN"),"SIG1",0)) S DIR("A",3)="" D
     18 ..F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"SIG1",I)) Q:'I  S DIR("A",3+I)=$S(I=1:"Current SIG: ",1:"")_$G(^PSRX(PSORXED("IRXN"),"SIG1",I,0))
     19 .S DIR("A")="Do You want to Edit the SIG"
     20 .D ^DIR K DIR I $D(DIRUT) S PSORX("DFLG")=1 D M1
     21 .Q:$D(DIRUT)!('Y)
     22 .S PSOREEDQ=1 D DOLST^PSOORED3,DOSE^PSOORED3 K PSOREEDQ
     23 .I '$O(PSORXED("DOSE",0)) S PSORX("DFLG")=1 Q
     24 .D:$G(PSOSIGFL) M2
     25 S RX0=RX0HLD K RX0HLD I $G(PSODRUG("OI"))=$G(PSOI) D  Q
     26 .D:$O(^TMP("PSORXDC",$J,0))
     27 ..W !!,"This edit will discontinue the duplicate Rx & change the dispensed drug!"
     28 ..K DIR,X,Y S DIR("A")="Do You Want to Proceed",DIR("B")="NO",DIR(0)="Y"
     29 ..D ^DIR K DIR S:'Y!($D(DIRUT)) PSORXED("DFLG")=1 D:Y DCORD^PSONEW2
     30 .Q:$G(PSORXED("DFLG"))
     31 .I PSODRUG("IEN")'=$P(RX0,"^",6) D
     32 ..S PSORXED("FLD",6)=PSODRUG("IEN"),PSORXED("FLD",39.2)=PSOI
     33 .S:$G(PSODRUG("TRADE NAME"))]"" PSORXED("FLD",6.5)=PSODRUG("TRADE NAME")
     34 .S:$G(PSODRUG("NDC"))]"" PSORXED("FLD",27)=PSODRUG("NDC")
     35 .S:$G(PSODRUG("DAW"))]"" PSORXED("FLD",81)=PSODRUG("DAW")
     36 W !!,"New Orderable Item selected. This edit will create a new prescription!",! D PAUSE^VALM1 S VALMSG="New Orderable Item selected. This edit will create a new prescription!" S (PSOOIFLG,PSOSIGFL)=1
     37 Q
     38PSOCOU ;patient counseling
     39 K DIC,DIQ S DIC=52,DA=PSORXED("IRXN"),DIQ="PSORXED",DR=41 D EN^DIQ1 K DIC,DIQ
     40 D KV S DIR(0)="52,41" S:$G(PSORXED(52,DA,DR))]"" DIR("B")=PSORXED(52,DA,DR) D ^DIR K DIR,PSORXED(52,DA,DR)
     41 I $D(DIRUT) K PSORXED("FLD",41) D KV Q
     42 S PSORXED("FLD",DR)=Y D  K DIRUT
     43 .I Y D  Q
     44 ..K DIC,DIQ S DIC=52,DA=PSORXED("IRXN"),DIQ="PSORXED",DR=42 D EN^DIQ1 K DIC,DIQ
     45 ..K DIR,DIRUT S DIR(0)="52,42" S:$G(PSORXED(52,DA,DR))]"" DIR("B")=PSORXED(52,DA,DR) D ^DIR K DIR,PSORXED(52,DA,DR)
     46 ..I $D(DIRUT) K PSORXED("FLD",41),DUOUT,DTOUT Q
     47 ..S PSORXED("FLD",42)=Y
     48 .S PSORXED("FLD",41)=0,PSORXED("FLD",42)="@"
     49 Q
     50PSOI ;select orderable item
     51 W !!,"Current Orderable Item: "_$P(^PS(50.7,PSOI,0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")
     52 S DIC("B")=$P(^PS(50.7,PSOI,0),"^"),DIC="^PS(50.7,",DIC(0)="AEMQZ"
     53 S DIC("S")="I '$P(^PS(50.7,+Y,0),""^"",4)!($P(^(0),""^"",4)'<DT) N PSOF,PSOL S (PSOF,PSOL)=0 F  S PSOL=$O(^PSDRUG(""ASP"",+Y,PSOL)) Q:PSOF!'PSOL  "
     54 S DIC("S")=DIC("S")_"I $P($G(^PSDRUG(PSOL,2)),U,3)[""O"",'$G(^(""I""))!($G(^(""I""))'<DT) S PSOF=1" D ^DIC I "^"[X S PSORXED("DFLG")=1 Q
     55 G:Y<1 PSOI Q:PSOI=+Y
     56 S PSODRUG("OI")=+Y,PSODRUG("OIN")=Y(0,0) K DIC
     57 I PSOI'=PSODRUG("OI") W !!,"New Orderable Item selected. This edit will create a new prescription!",! D  K PSHOLDD Q
     58 .D PAUSE^VALM1,M2
     59 .S PSHOLDD=$G(PSODRUG("IEN")) K PSODRUG("IEN"),PSODRUG("NAME") S PSODRUG("DEA")="",(PSOOIFLG,PSOSIGFL)=1
     60 .D DREN^PSOORNW2
     61 .I $G(PSHOLDD),$G(PSODRUG("IEN")),$G(PSHOLDD)'=$G(PSODRUG("IEN")) D  Q:$G(PSORX("DFLG"))
     62 ..D FULL^VALM1,POST^PSODRG S VALMBCK="R"
     63 ..I $G(PSORX("DFLG")) K PSODRUG S PSODRUG("IEN")=$G(PSHOLDD),PSODRUG("NAME")=$P($G(^PSDRUG(PSODRUG("IEN"),0)),"^") K PSOOIFLG,PSOSIGFL S VALMSG=""
     64 .I '$G(PSODRUG("IEN")) W !!,"DRUG NAME REQUIRED!" D 2^PSOORNW1
     65 .I '$G(PSODRUG("IEN")) K PSORXED("FLD"),INDEL,^TMP($J,"INS1"),PSOSIGFL,VALMSG S PSORXED("DFLG")=1,VALMSG="Dispense Drug NOT Selected!" Q
     66 .D KV S DIR(0)="Y",DIR("B")="NO",DIR("A",1)="You have changed the Orderable Item from",DIR("A",2)=$P(^PS(50.7,PSOI,0),"^")_" to "_PSODRUG("OIN")_".",DIR("A")="Do You want to Edit the SIG"
     67 .D ^DIR K DIR I $D(DIRUT) K PSODRUG("OIN"),PSOOIFLG,PSOSIGFL S PSODRUG("OI")=PSOI,VALMSG="",PSORX("DFLG")=1 Q
     68 .I 'Y S PSORX("DFLG")=1 Q
     69 .S PSOREEDQ=1 D DOLST^PSOORED3,DOSE^PSOORED3 K PSOREEDQ
     70 .I '$O(PSORXED("DOSE",0)) S PSORX("DFLG")=1 Q
     71 .D:$G(PSOSIGFL) M2
     72 S PSORXED("FLD",39.2)=PSOI
     73 Q
     74NCPDP ;Reverse previously billed Rx on an edited orderable item or drug.
     75 N RX,NPSOY
     76 S RX=$G(PSORXED("IRXN")) I RX="" D
     77 . S NPSOY=$O(PSONEW("OLD LAST RX#","")),NPSOY=$G(PSONEW("OLD LAST RX#",NPSOY)),RX=$O(^PSRX("B",NPSOY,RX))
     78 I 'RX Q
     79 D REVERSE^PSOBPSU1(RX,,"DC",7) S NCPDPFLG=0
     80 Q
     81UPDATE ;add new data to file
     82 N RXREF,UPDATE,FLDS,CHGNDC
     83 Q:'$G(PSORXED("IRXN"))
     84 I $O(PSORXED("FLD",0))!($G(^TMP($J,"INS1",0))]"")!($G(INSDEL))!($O(PSORXED("ODOSE",0))) D  G:'Y UPDX
     85 .K DIR,DIRUT,DTOUT,DUOUT
     86 .S DIR(0)="Y",DIR("A")="Are You Sure You Want to Update Rx "_$P(^PSRX(PSORXED("IRXN"),0),"^"),DIR("B")="Yes"
     87 .D ^DIR K DIR I 'Y D M1 Q
     88 .I $D(^PSRX(PSORXED("IRXN"),1,0))  D
     89 ..S RXREF=$P(^PSRX(PSORXED("IRXN"),0),"^",9)-$P(^PSRX(PSORXED("IRXN"),1,0),"^",4)
     90 .E  S RXREF=0
     91 .K X,DIRUT,DUOUT,DTOUT
     92 I $D(PSORXED("FLD",39.3)) D UPDATE^PSODIAG  ;update ICD's after edit
     93 ; - Retrieving fields before changes that are relevant for 3rd Party Billing
     94 D GETS^DIQ(52,PSORXED("IRXN")_",","4;7;8;20;22;27;81","I","FLDS")
     95 K Y S DA=PSORXED("IRXN"),DIE="^PSRX(",FLD=0
     96 F  S FLD=$O(PSORXED("FLD",FLD)) Q:'FLD  D
     97 .I FLD=12!(FLD=24)!(FLD=35) D  Q
     98 ..I FLD=12,PSORXED("FLD",12)="@" S $P(^PSRX(DA,3),"^",7)="" Q
     99 ..I FLD=12,PSORXED("FLD",12)]"" S $P(^PSRX(DA,3),"^",7)=PSORXED("FLD",12) Q
     100 ..I FLD=24,PSORXED("FLD",24)="@" S $P(^PSRX(DA,2),"^",4)="" Q
     101 ..I FLD=24,PSORXED("FLD",24)]"" S $P(^PSRX(DA,2),"^",4)=PSORXED("FLD",24) Q
     102 ..I FLD=35,PSORXED("FLD",35)="@" S $P(^PSRX(DA,"MP"),"^")="" Q
     103 ..I FLD=35,PSORXED("FLD",35)]"" S $P(^PSRX(DA,"MP"),"^")=PSORXED("FLD",35) Q
     104 .I FLD=114 D  Q
     105 ..I PSORXED("FLD",114)="@" K ^PSRX(DA,"INS"),^PSRX(DA,"INS1")
     106 ..I PSORXED("FLD",114)'="@" D
     107 ...S ^PSRX(DA,"INS")=PSORXED("FLD",114)
     108 ...S X=PSORXED("FLD",114) D SIG^PSOHELP Q:$G(INS1)']""
     109 ...S PSORXED("SIG",1)=$E(INS1,2,9999999) K ^PSRX(DA,"INS1")
     110 ...S ^PSRX(DA,"INS1",0)="^52.0115^1^1^"_DT_"^^"
     111 ...S ^PSRX(DA,"INS1",1,0)=PSORXED("SIG",1)
     112 ..D DOLST^PSOORED3 K:PSORXED("FLD",114)="@" PSORXED("SIG") D EN^PSOFSIG(.PSORXED),UPDSIG^PSOORED3
     113 .I FLD=27 D  Q
     114 ..I PSORXED("FLD",27)'=$$GETNDC^PSONDCUT(DA,0) D
     115 ...S CHGNDC=1 D RXACT^PSOBPSU2(DA,0,"NDC changed from "_$$GETNDC^PSONDCUT(DA,0)_" to "_PSORXED("FLD",27)_".","E")
     116 ..D SAVNDC^PSONDCUT(DA,0,PSORXED("FLD",27),0,1)
     117 .I FLD=81 D SAVDAW^PSODAWUT(DA,0,PSORXED("FLD",81)) Q
     118 .S DR=FLD_"////"_PSORXED("FLD",FLD) D ^DIE
     119 .I FLD=4 D UDPROV^PSOOREDT Q
     120 ;
     121 ; - Re-submitting Rx to ECME due to edits
     122 D RESUB^PSOORED7
     123 ;
     124 I $G(INSDEL) K ^PSRX(DA,"INS"),^PSRX(DA,"INS1") D DOLST^PSOORED3 K PSORXED("SIG") D EN^PSOFSIG(.PSORXED),UPDSIG^PSOORED3 G UPDX
     125 I $O(^TMP($J,"INS1",0)) D
     126 .K ^PSRX(DA,"INS"),^PSRX(DA,"INS1"),DD,PSORXED("SIG")
     127 .F I=0:0 S I=$O(^TMP($J,"INS1",I)) Q:'I  S (PSORXED("SIG",I),^PSRX(DA,"INS1",I,0))=^TMP($J,"INS1",I,0),DD=$G(DD)+1
     128 .S ^PSRX(DA,"INS1",0)=^TMP($J,"INS1",0)
     129 .I DD=1 S ^PSRX(DA,"INS")=^PSRX(DA,"INS1",1,0)
     130 .D DOLST^PSOORED3,EN^PSOFSIG(.PSORXED),UPDSIG^PSOORED3
     131 ;
     132UPDX ;
     133 K DIE,DA,DR,FLD,X,Y,PSORXED("FLD"),DD,^TMP($J,"INS1")
     134KV K DIR,DIRUT,DTOUT,DUOUT
     135 Q
     136UPD ;updates dosing array
     137 S HENT=ENT
     138UPD1 ;
     139 I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" S PSORXED("CONJUNCTION",HENT)=PSORXED("CONJUNCTION",(HENT+1)) D  G UPD
     140 .K PSORXED("CONJUNCTION",(HENT+1))
     141 .I $D(PSORXED("DOSE",(HENT+2))) D
     142 ..S PSORXED("DOSE",(HENT+1))=PSORXED("DOSE",(HENT+2))
     143 ..S PSORXED("ODOSE",(HENT+1))=$G(PSORXED("ODOSE",(HENT+2)))
     144 ..S PSORXED("DOSE ORDERED",(HENT+1))=$G(PSORXED("DOSE ORDERED",(HENT+2)))
     145 ..S PSORXED("UNITS",(HENT+1))=$G(PSORXED("UNITS",(HENT+2)))
     146 ..S PSORXED("NOUN",(HENT+1))=$G(PSORXED("NOUN",(HENT+2)))
     147 ..S PSORXED("DURATION",(HENT+1))=$G(PSORXED("DURATION",(HENT+2)))
     148 ..S PSORXED("CONJUNCTION",(HENT+1))=$G(PSORXED("CONJUNCTION",(HENT+2)))
     149 ..S PSORXED("ROUTE",(HENT+1))=$G(PSORXED("ROUTE",(HENT+2)))
     150 ..S PSORXED("SCHEDULE",(HENT+1))=$G(PSORXED("SCHEDULE",(HENT+2)))
     151 ..S PSORXED("VERB",(HENT+1))=$G(PSORXED("VERB",(HENT+2)))
     152 ..K PSORXED("DOSE",(HENT+2)),PSORXED("ODOSE",(HENT+2)),PSORXED("DOSE ORDERED",(HENT+2))
     153 ..K PSORXED("UNITS",(HENT+2)),PSORXED("NOUN",(HENT+2)),PSORXED("DURATION",(HENT+2)),PSORXED("ROUTE",(HENT+2)),PSORXED("SCHEDULE",(HENT+2)),PSORXED("VERB",(HENT+2))
     154 .S HENT=HENT+1
     155 F I=0:0 S I=$O(PSORXED("DOSE",I)) Q:'I  S SENT=$G(SENT)+1
     156 Q
     157 ;
     158M1 D M1^PSOOREDX
     159 Q
     160M2 D M2^PSOOREDX
     161 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED7.m

    r613 r623  
    1 PSOORED7        ;ISC-BHAM/MFR-edit orders from backdoor con't ;03/06/95 10:24
    2         ;;7.0;OUTPATIENT PHARMACY;**148,247,281**;DEC 1997;Build 41
    3         ;called from psooredt. cmop edit checks.
    4         ;Reference to file #50 supported by IA 221
    5         ;Reference to $$ECMEON^BPSUTIL supported by IA 4410
    6         ;Reference to $$DIVNCPDP^BPSBUTL supported by IA 4719
    7         ;
    8 NOCHG   S CMRL=1 D CHK1^PSOORED2 I '$G(CMRL) W !,"No editing allowed of "_$S(FLN=9:"Day Supply",FLN=10:"Quantity",1:"# of Refills")_" (CMOP)." D PAUSE^VALM1 K CMRL Q
    9         K CMRL,DIC,DIQ
    10         S DIC=52,DA=PSORXED("IRXN"),DIQ="PSORXED" D EN^DIQ1 K DIC,DIQ
    11         S PSORXED($S(FLN=9:"DAYS SUPPLY",FLN=10:"QTY",1:"# OF REFILLS"))=PSORXED(52,DA,DR)
    12         D:'$O(PSORXED("DOSE",0)) DOLST^PSOORED3
    13         I FLN=9 D  Q
    14         .D DAYS^PSODIR1(.PSORXED) I $G(PSORXED("DFLG")) K PSORXED("FLD",8) Q
    15         .S PSORXED("FLD",8)=PSORXED("DAYS SUPPLY")
    16         I FLN=10 D  Q
    17         .D QTY^PSODIR1(.PSORXED) I $G(PSORXED("DFLG")) K PSORXED("FLD",7) Q
    18         .S:$G(PSORXED("QTY")) PSORXED("FLD",7)=PSORXED("QTY")
    19         I FLN=11 D  Q
    20         .S X=$G(PSORXED("PATIENT STATUS")) S:'X X=$P(RX0,"^",3)
    21         .S DIC=53,DIC(0)="QXZ" D ^DIC K DIC
    22         .S:+Y PSORXED("PTST NODE")=Y(0)
    23         .S:'$G(PSORXED("PATIENT STATUS")) PSORXED("PATIENT STATUS")=+Y
    24         .K X,Y
    25         .I $G(PSODRUG("IEN"))=$P(RX0,"^",6) K PSODRUG S X="`"_$P(RX0,"^",6),DIC=50,DIC(0)="QXZ" D ^DIC K PSOY S PSOY=Y,PSOY(0)=Y(0) D SET^PSODRG
    26         .S:'$G(PSORXED("DAYS SUPPLY")) PSORXED("DAYS SUPPLY")=$P(RX0,"^",8)
    27         .F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'I  S RFTT=$G(RFTT)+1
    28         .D REFILL^PSODIR1(.PSORXED) K RFTT
    29         .I $G(PSORXED("DFLG")) K PSORXED("FLD",9) Q
    30         .I PSORXED("# OF REFILLS")=$P(RX0,"^",9) Q
    31         .S PSORXED("FLD",9)=PSORXED("# OF REFILLS")
    32         Q
    33 VER     ;checks for changes to dosing instructions
    34         S ENTS=0
    35         F I=0:0 S I=$O(PSORXED("DOSE",I)) Q:'I  S ENTS=$G(ENTS)+1
    36         I ENTS<OLENT!(ENTS>OLENT) S PSOSIGFL=1 Q
    37         F I=1:1:OLENT D:$D(^PSRX(PSORXED("IRXN"),6,I,0))
    38         .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^")'=PSORXED("DOSE",I) S PSOSIGFL=1
    39         .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^")=PSORXED("DOSE",I) D
    40         ..I $G(PSORXED("DOSE ORDERED",I)) S:PSORXED("DOSE ORDERED",I)'=$P(^PSRX(PSORXED("IRXN"),6,I,0),"^",2) PSOSIGFL=1
    41         .I $G(PSORXED("DURATION",I))]"" D
    42         ..S DURATION=$S($E($P(^PSRX(PSORXED("IRXN"),6,I,0),"^",5),1)'?.N:$E($P(^PSRX(PSORXED("IRXN"),6,I,0),"^",5),2,99)_$E($P(^PSRX(PSORXED("IRXN"),6,I,0),"^",5),1),1:$P(^PSRX(PSORXED("IRXN"),6,I,0),"^",5))
    43         ..I +DURATION'=+$G(PSORXED("DURATION",I)) S PSOSIGFL=1
    44         .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^",6)'=$G(PSORXED("CONJUNCTION",I)) S PSOSIGFL=1
    45         .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^",7)'=$G(PSORXED("ROUTE",I)) S PSOSIGFL=1
    46         .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^",8)'=PSORXED("SCHEDULE",I) S PSOSIGFL=1
    47         .I $G(^PSRX(PSORXED("IRXN"),6,I,1))'=$G(PSORXED("ODOSE",I)) S PSOSIGFL=1
    48         K DURATION
    49         Q
    50         ;
    51 RESUB   ; Resubmits 3rd party claim in case of an edit (Original)
    52         N CHANGED S CHANGED=$$CHANGED(PSORXED("IRXN"),.FLDS)
    53         I CHANGED D
    54         . N RX S RX=PSORXED("IRXN") Q:'RX
    55         . I $P(CHANGED,"^",2),'$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,0)) D  Q
    56         . . D REVERSE^PSOBPSU1(RX,0,"DC",99,"RX DIVISION CHANGED",1)
    57         . I $$SUBMIT^PSOBPSUT(RX,0,1,1) D
    58         . . I '$P(CHANGED,"^",2),$$STATUS^PSOBPSUT(RX,0)="" Q
    59         . . D ECMESND^PSOBPSU1(RX,0,,"ED",$$GETNDC^PSONDCUT(RX,0),,$S($P(CHANGED,"^",2):"RX DIVISION CHANGED",1:"RX EDITED"),,+$G(CHGNDC))
    60         . . ;- Checking/Handling DUR/79 Rejects
    61         . . I $$FIND^PSOREJUT(RX,0) S X=$$HDLG^PSOREJU1(RX,0,"79,88","ED","IOQ","Q")
    62         Q
    63         ;
    64 CHANGED(RX,PRIOR)       ; - Check if fields have changed and should for 3rd Party Claim resubmission
    65         ;Input:  (r) RX    - Rx IEN
    66         ;        (r) PRIOR - Array with fields
    67         ;Output:  CHANGED  - 0 - Not changed / 1 - Original Rx field changed ^ Rx Division changed (1 - YES)
    68         N CHANGED,SAVED
    69         S CHANGED=0 D GETS^DIQ(52,RX_",","4;7;8;20;22;27;81","I","SAVED")
    70         F I=4,7,8,22,27,81 D  I CHANGED Q
    71         . I $G(PRIOR(52,RX_",",I,"I"))'=$G(SAVED(52,RX_",",I,"I")) S CHANGED=1 Q
    72         I $$DIVNCPDP^BPSBUTL(+$G(PRIOR(52,RX_",",20,"I")))'=$$DIVNCPDP^BPSBUTL(+$G(SAVED(52,RX_",",20,"I"))) S CHANGED="1^1"
    73         Q CHANGED
    74         ;;
    75 NDCDAWDE(ST,FLN,RXN)    ; allow edit of NDC & DAW for DC'd/expired ECME RXs
    76         ;;  input: (r) ST  - the Rx status code
    77         ;;         (r) FLN - field number selected for editing
    78         ;;         (r) RXN - prescription #
    79         ;; output: VALMSG for inappropriate field selection or use
    80         ;;         PSODRUG & RSORXED arrays updated if edited
    81         Q:$G(ST)=""!($G(FLN)="")!($G(RXN)="")
    82         I '((ST=11)!(ST=12)) S VALMSG=("Invalid selection!") Q
    83         I '((FLN=2)!(FLN=20)!(FLN=21)) S VALMSG=("Invalid selection!") Q
    84         I $$STATUS^PSOBPSUT(RXN,$$LSTRFL^PSOBPSU1(RXN))="" S VALMSG=("Invalid selection!") Q
    85         ;
    86         ; edit NDCs
    87         I FLN=2 D  Q
    88         .N NDC
    89         .S NDC=$$GETNDC^PSONDCUT(RXN,0)
    90         .D NDCEDT^PSONDCUT(RXN,"",$G(DRG),$G(PSOSITE),.NDC)
    91         .I $G(NDC)="^" Q
    92         .S (PSODRUG("NDC"),PSORXED("FLD",27))=NDC
    93         ;;
    94         ; edit refill NDCs/DAWs
    95         I FLN=20 D  Q
    96         .I $$LSTRFL^PSOBPSU1(RXN)=0 S VALMSG="Invalid selection!" Q
    97         .D REF^PSOORED2
    98         ;;
    99         ; edit DAW
    100         I FLN=21 D  Q
    101         .N DAW
    102         .D EDTDAW^PSODAWUT(RXN,0,.DAW)
    103         .I $G(DAW)="^" Q
    104         .S (PSODRUG("DAW"),PSORXED("FLD",81))=DAW
    105         Q
    106         ;;
     1PSOORED7 ;ISC-BHAM/MFR-edit orders from backdoor con't ;03/06/95 10:24
     2 ;;7.0;OUTPATIENT PHARMACY;**148,247**;DEC 1997;Build 18
     3 ;called from psooredt. cmop edit checks.
     4 ;Reference to file #50 supported by IA 221
     5 ;Reference to $$ECMEON^BPSUTIL supported by IA 4410
     6 ;Reference to $$DIVNCPDP^BPSBUTL supported by IA 4719
     7 ;
     8NOCHG S CMRL=1 D CHK1^PSOORED2 I '$G(CMRL) W !,"No editing allowed of "_$S(FLN=9:"Day Supply",FLN=10:"Quantity",1:"# of Refills")_" (CMOP)." D PAUSE^VALM1 K CMRL Q
     9 K CMRL,DIC,DIQ
     10 S DIC=52,DA=PSORXED("IRXN"),DIQ="PSORXED" D EN^DIQ1 K DIC,DIQ
     11 S PSORXED($S(FLN=9:"DAYS SUPPLY",FLN=10:"QTY",1:"# OF REFILLS"))=PSORXED(52,DA,DR)
     12 D:'$O(PSORXED("DOSE",0)) DOLST^PSOORED3
     13 I FLN=9 D  Q
     14 .D DAYS^PSODIR1(.PSORXED) I $G(PSORXED("DFLG")) K PSORXED("FLD",8) Q
     15 .S PSORXED("FLD",8)=PSORXED("DAYS SUPPLY")
     16 I FLN=10 D  Q
     17 .D QTY^PSODIR1(.PSORXED) I $G(PSORXED("DFLG")) K PSORXED("FLD",7) Q
     18 .S:$G(PSORXED("QTY")) PSORXED("FLD",7)=PSORXED("QTY")
     19 I FLN=11 D  Q
     20 .S X=$G(PSORXED("PATIENT STATUS")) S:'X X=$P(RX0,"^",3)
     21 .S DIC=53,DIC(0)="QXZ" D ^DIC K DIC
     22 .S:+Y PSORXED("PTST NODE")=Y(0)
     23 .S:'$G(PSORXED("PATIENT STATUS")) PSORXED("PATIENT STATUS")=+Y
     24 .K X,Y
     25 .I $G(PSODRUG("IEN"))=$P(RX0,"^",6) K PSODRUG S X="`"_$P(RX0,"^",6),DIC=50,DIC(0)="QXZ" D ^DIC K PSOY S PSOY=Y,PSOY(0)=Y(0) D SET^PSODRG
     26 .S:'$G(PSORXED("DAYS SUPPLY")) PSORXED("DAYS SUPPLY")=$P(RX0,"^",8)
     27 .F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'I  S RFTT=$G(RFTT)+1
     28 .D REFILL^PSODIR1(.PSORXED) K RFTT
     29 .I $G(PSORXED("DFLG")) K PSORXED("FLD",9) Q
     30 .I PSORXED("# OF REFILLS")=$P(RX0,"^",9) Q
     31 .S PSORXED("FLD",9)=PSORXED("# OF REFILLS")
     32 Q
     33VER ;checks for changes to dosing instructions
     34 S ENTS=0
     35 F I=0:0 S I=$O(PSORXED("DOSE",I)) Q:'I  S ENTS=$G(ENTS)+1
     36 I ENTS<OLENT!(ENTS>OLENT) S PSOSIGFL=1 Q
     37 F I=1:1:OLENT D:$D(^PSRX(PSORXED("IRXN"),6,I,0))
     38 .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^")'=PSORXED("DOSE",I) S PSOSIGFL=1
     39 .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^")=PSORXED("DOSE",I) D
     40 ..I $G(PSORXED("DOSE ORDERED",I)) S:PSORXED("DOSE ORDERED",I)'=$P(^PSRX(PSORXED("IRXN"),6,I,0),"^",2) PSOSIGFL=1
     41 .I $G(PSORXED("DURATION",I))]"" D
     42 ..S DURATION=$S($E($P(^PSRX(PSORXED("IRXN"),6,I,0),"^",5),1)'?.N:$E($P(^PSRX(PSORXED("IRXN"),6,I,0),"^",5),2,99)_$E($P(^PSRX(PSORXED("IRXN"),6,I,0),"^",5),1),1:$P(^PSRX(PSORXED("IRXN"),6,I,0),"^",5))
     43 ..I +DURATION'=+$G(PSORXED("DURATION",I)) S PSOSIGFL=1
     44 .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^",6)'=$G(PSORXED("CONJUNCTION",I)) S PSOSIGFL=1
     45 .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^",7)'=$G(PSORXED("ROUTE",I)) S PSOSIGFL=1
     46 .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^",8)'=PSORXED("SCHEDULE",I) S PSOSIGFL=1
     47 .I $G(^PSRX(PSORXED("IRXN"),6,I,1))'=$G(PSORXED("ODOSE",I)) S PSOSIGFL=1
     48 K DURATION
     49 Q
     50 ;
     51RESUB ; Resubmits 3rd party claim in case of an edit (Original)
     52 N CHANGED S CHANGED=$$CHANGED(PSORXED("IRXN"),.FLDS)
     53 I CHANGED D
     54 . N RX S RX=PSORXED("IRXN") Q:'RX
     55 . I $P(CHANGED,"^",2),'$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,0)) D  Q
     56 . . D REVERSE^PSOBPSU1(RX,0,"DC",99,"RX DIVISION CHANGED",1)
     57 . I $$SUBMIT^PSOBPSUT(RX,0,1,1) D
     58 . . I '$P(CHANGED,"^",2),$$STATUS^PSOBPSUT(RX,0)="" Q
     59 . . D ECMESND^PSOBPSU1(RX,0,,"ED",$$GETNDC^PSONDCUT(RX,0),,$S($P(CHANGED,"^",2):"RX DIVISION CHANGED",1:"RX EDITED"),,+$G(CHGNDC))
     60 . . ;- Checking/Handling DUR/79 Rejects
     61 . . I $$FIND^PSOREJUT(RX,0) S X=$$HDLG^PSOREJU1(RX,0,"79,88","ED","IOQ","I")
     62 Q
     63 ;
     64CHANGED(RX,PRIOR) ; - Check if fields have changed and should for 3rd Party Claim resubmission
     65 ;Input:  (r) RX    - Rx IEN
     66 ;        (r) PRIOR - Array with fields
     67 ;Output:  CHANGED  - 0 - Not changed / 1 - Original Rx field changed ^ Rx Division changed (1 - YES)
     68 N CHANGED,SAVED
     69 S CHANGED=0 D GETS^DIQ(52,RX_",","4;7;8;20;22;27;81","I","SAVED")
     70 F I=4,7,8,22,27,81 D  I CHANGED Q
     71 . I $G(PRIOR(52,RX_",",I,"I"))'=$G(SAVED(52,RX_",",I,"I")) S CHANGED=1 Q
     72 I $$DIVNCPDP^BPSBUTL(+$G(PRIOR(52,RX_",",20,"I")))'=$$DIVNCPDP^BPSBUTL(+$G(SAVED(52,RX_",",20,"I"))) S CHANGED="1^1"
     73 Q CHANGED

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOOREDT.m

    r613 r623  
    1 PSOOREDT        ;BIR/SAB - edit orders from backdoor ;11:19 AM  1 Jan 2009
    2         ;;7.0;OUTPATIENT PHARMACY;**4,20,27,37,57,46,78,102,104,119,143,148,260,281,208**;DEC 1997;Build 41;WorldVistA 30-Jan-08
    3         ;
    4         ;Modified from FOIA VISTA,
    5         ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    6         ;General Public License See attached copy of the License.
    7         ;
    8         ;This program is free software; you can redistribute it and/or modify
    9         ;it under the terms of the GNU General Public License as published by
    10         ;the Free Software Foundation; either version 2 of the License, or
    11         ;(at your option) any later version.
    12         ;
    13         ;This program is distributed in the hope that it will be useful,
    14         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    15         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    16         ;GNU General Public License for more details.
    17         ;
    18         ;You should have received a copy of the GNU General Public License along
    19         ;with this program; if not, write to the Free Software Foundation, Inc.,
    20         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    21         ;
    22         ;External reference to ^PSDRUG supported by DBIA 221
    23         ;External reference to PSSLOCK supported by DBIA 2789
    24         ;External reference to ^VA(200 supported by DBIA 10060
    25 SEL     K PSOISLKD,PSOLOKED S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY D SVAL K PSOPLCK S VALMBCK="" Q
    26         K PSOPLCK D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) D UL^PSSLOCK(+$G(PSODFN)) D SVALO K PSOMSG S VALMBCK="" Q
    27         K PSOMSG S PSOLOKED=1
    28         K PSORX("DFLG"),DIR,DUOUT,DIRUT S DIR("A")="Select fields by number"
    29         S DIR(0)="LO^1:"_$S($$STATUS^PSOBPSUT($P(PSOLST(ORN),"^",2))'="":21,$G(REF):20,1:19)
    30         D ^DIR I $D(DIRUT) K DIR,DIRUT,DTOUT S VALMBCK="" D UL K PSOLOKED Q
    31 EDTSEL  N VALMCNT K PSOISLKD,PSORX("DFLG"),PSOOIFLG,PSOMRFLG,DIR,DIRUT,DTOUT,DTOUT,ZONE S (PSOEDIT,PSORXED)=1 I +Y S FST=Y D HLDHDR^PSOLMUTL D  G EX ;PSO LM SELECT MENU protocol
    32         .I '$G(PSOLOKED) S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY D SVAL K PSOPLCK S VALMBCK="",(PSOISLKD,PSODE)=1 Q
    33         .I '$G(PSOLOKED) K PSOPLCK D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) D UL^PSSLOCK(+$G(PSODFN)) D SVALO K PSOMSG S VALMBCK="",(PSOISLKD,PSODE)=1 Q
    34         .K PSOMSG,PSOPLCK S (NEWEDT,PSOLOKED)=1 D EDT
    35         E  S VALMBCK="",PSODE=1
    36 EX      I $G(PSOISLKD) D UL K PSOISLKD G EX2
    37         I '$G(PSOSIGFL),'$G(PSORXED("DFLG")) D UPDATE^PSOORED6 D LOG^PSORXED,POST^PSORXED G EX1
    38         I $G(PSOSIGFL)=1 D  Q:$G(PSORX("FN"))
    39         .N PSOTMP
    40         .S PSOTMP=$G(PSOFROM),PSOFROM="NEW"
    41         .S VALMSG="This change will create a new prescription!",NCPDPFLG=1
    42         .D EN^PSOORED1(.PSORXED)
    43         .I $G(PSORX("FN")) D  Q
    44         ..D ^PSOBUILD
    45         ..K QUIT,PSORX("DFLG"),FST,FLD,IEN,FLN,INCOM,PSOI,PSODRUG,PSOEDIT
    46         ..K PSORENW,PSOSIGFL,PSOOIFLG,PSOMRFLG,PSODIR,CHK,PSORX("SIG"),PSODE
    47         ..K PSOTRN,PSORX("EDIT"),PSORXED("FLD"),NEWEDT
    48         ..D EOJ^PSONEW
    49         ..D UL K PSOLOKED S VALMBCK="Q"
    50         .S PSOFROM=PSOTMP I PSOFROM="" K PSOFROM
    51         ;
    52 EX1     I '$G(PSODE)!('$G(ZONE)) I $G(PSORENW("OIRXN")) D EN^PSOHLSN1(PSORENW("OIRXN"),"XX","","Order edited")
    53 QUIT    D UL K PSOLOKED D ^PSOBUILD,ACT^PSOORNE2 D:+^PSRX($P(PSOLST(ORN),"^",2),"STA")=5 EN^PSOCMOPC($P(PSOLST(ORN),"^",2))
    54         K:'$O(^PSRX($P(PSOLST(ORN),"^",2),1,0)) REF
    55 EX2     S VALMBCK=$S($G(PSORX("FN")):"Q",$G(ZONE):"Q",1:"R") K PSORXED,FST,FLD,IEN,FLN,INCOM,PSOI,PSODRUG,PSOEDIT,PSORENW,PSOSIGFL,PSODIR,CHK,PSORX("SIG"),PSODE,PSOTRN,PSORX("DFLG"),RFED,ZONE,PSORX("EDIT"),PSOOIFLG,PSOMRFLG,SIG,QUIT
    56         K NEWEDT I $G(VALMBCK)="R" W ! D CLEAN^PSOVER1 H 2
    57         Q
    58         ;
    59 EDT     ; Rx Edit (Backdoor)
    60         K NCPDPFLG
    61         S I=0 F  S I=$O(^PSRX($P(PSOLST(ORN),"^",2),1,I)) Q:'I  S PSORXED("RX1")=^PSRX($P(PSOLST(ORN),"^",2),1,I,0)
    62         S (RX0,PSORXED("RX0"))=^PSRX($P(PSOLST(ORN),"^",2),0),PSORXED("RX2")=$G(^(2)),PSORXED("RX3")=$G(^(3)),PSOSIG=$P(^("SIG"),"^")
    63         F FLD=1:1:$L(FST,",") Q:$P(FST,",",FLD)']""!($G(PSORXED("DFLG")))!($G(PSORX("DFLG")))  S FLN=+$P(FST,",",FLD) D
    64         .S PSORXED("DFLG")=0,(DA,PSORXED("IRXN"),PSORENW("OIRXN"))=$P(PSOLST(ORN),"^",2),RX0=^PSRX(PSORXED("IRXN"),0) S:$G(PSOSIG)="" PSOSIG=$P(^("SIG"),"^")
    65         .I '$G(PSOSIGFL) D
    66         ..S PSOI=+^PSRX(DA,"OR1"),PSODAYS=$P(RX0,"^",8),PSORXST=+$P($G(^PS(53,$P(RX0,"^",3),0)),"^",7)
    67         ..I 'PSOI S PSOI=+^PSDRUG($P(RX0,"^",6),2),$P(^PSRX(DA,"OR1"),"^")=PSOI
    68         ..S:'$G(PSODRUG("IEN")) PSODRUG("IEN")=$P(RX0,"^",6),PSODRUG("NAME")=$P(^PSDRUG($P(RX0,"^",6),0),"^")
    69         ..S PSODRUG("OI")=PSOI
    70         .S PSORX("PROVIDER")=$P(RX0,"^",4),PSORX("PROVIDER NAME")=$P(^VA(200,$P(RX0,"^",4),0),"^"),PSOTRN=$G(^PSRX(DA,"TN"))
    71         .D:'$G(CHK) POP^PSOSIGNO(DA),CHK Q:$G(PSORXED("DFLG"))
    72         .S FDR="39.2^"_$S($P(PSOPAR,"^",3):"6",1:"")_";6.5^113^114^3^1^22R^24^8^7^9^4^11;"_$S($P(RX0,"^",11)="W"&($P(PSOPAR,"^",12)):"35;",1:"")_"^10.6^5^20^23^12^PSOCOU^RF^81"
    73         .I $G(ST)=11!($G(ST)=12) D NDCDAWDE^PSOORED7(ST,FLN,$G(RXN)) Q
    74         .I FLN=20,'$G(REF) S VALMSG="There is no Refill Data to be edited." Q
    75         .S DR=$P(FDR,"^",FLN) I DR="RF" D REF^PSOORED2 Q
    76         .I DR="PSOCOU" D PSOCOU^PSOORED6 Q
    77         .I FLN=2,'$P(PSOPAR,"^",3),$$RXRLDT^PSOBPSUT(RXN,0),$$STATUS^PSOBPSUT(RXN,0)'="" D  Q
    78         ..N NDC D NDC^PSODRG(RXN,0,,.NDC) I $G(NDC)="^"!($G(NDC)="") Q
    79         ..S (PSODRUG("NDC"),PSORXED("FLD",27))=NDC
    80         .I FLN'>2,'$P(PSOPAR,"^",3) S VALMSG="Check site parameters, Drug data is not editable." Q
    81         .I FLN=3 D EDTDOSE^PSOORED2 Q
    82         .I FLN=4 D INS^PSOORED1 Q
    83         .I FLN=1 D PSOI^PSOORED6 N PSOX S PSORXED=1,PSOX("IRXN")=$S($D(DA):DA,$D(PSORXED("IRXN")):PSORXED("IRXN"),$D(PSORENW("OIRXN")):PSORENW("OIRXN")) D:'$G(PSORXED("DFLG")) EN^PSODIAG Q
    84         .I FLN=2 D DRG^PSOORED6 N PSOX S PSORXED=1,PSOX("IRXN")=PSORXED("IRXN") D:'$G(PSORXED("DFLG")) EN^PSODIAG S:$O(^PSRX(PSORXED("IRXN"),1,0)) REF=1 Q
    85         .I FLN=12 D PROV Q
    86         .I FLN=6 D ISDT^PSOORED2 Q
    87         .I FLN=7 D FLDT^PSOORED2 Q
    88         .I FLN=21,$$STATUS^PSOBPSUT(RXN,0)="" S VALMSG="Invalid selection!" Q
    89         .I FLN=21 D  Q
    90         ..N DAW D EDTDAW^PSODAWUT(RXN,0,.DAW) I $G(DAW)="^" Q
    91         ..S (PSODRUG("DAW"),PSORXED("FLD",81))=DAW
    92         .I FLN=9!(FLN=10)!(FLN=11) D NOCHG^PSOORED7 Q
    93         .S DR=+DR
    94         .K DIR,DIRUT,DIROUT ;S DIE=52 D ^DIE I $D(Y) S PSORXED("DFLG")=1
    95         .K DIC,DIQ S DIC=52,DA=PSORXED("IRXN"),DIQ="PSORXED" D EN^DIQ1 K DIC,DIQ
    96         .S DIR("B")=$S($G(PSORXED("FLD",DR))]"":PSORXED("FLD",DR),1:PSORXED(52,DA,DR)),DIR(0)="52,"_DR D ^DIR
    97         .I DR=24!(DR=12) S PSORXED("FLD",DR)=X
    98         .I $D(DIRUT) K DIR,DIRUT,DUOUT,DTOUT,PSORXED(52,DA,DR),PSORXED("FLD",DR) Q
    99         .I DR'=5,X="@" W !,"Data Required!",! K DIC,DIQ,DR,DA,DIR,DIRUT,PSORXED(52,DA,DR),X,Y Q
    100         .I DR=5,X'="@" S Y=+Y
    101         .I DR=3!(DR=20)!(DR=23) S Y=+Y
    102         .S PSORXED("FLD",DR)=$S(X="@":X,1:Y) K DIR,DIRUT,DIROUT,X,Y,PSORXED(52,DA,DR)
    103         .I DR=11,PSORXED("FLD",DR)="W",$P(PSOPAR,"^",12) D
    104         ..D FIELD^DID(52,DR,"","LABEL","ZZ") S PSORXED(ZZ("LABEL"))=PSORXED("FLD",DR) K ZZ
    105         ..S DR=35,DIQ="PSORXED" D EN^DIQ1 K DIC,DIQ,DIRUT,DUOUT,DTOUT
    106         ..S:$G(PSORXED(52,DA,DR))]"" DIR("B")=PSORXED(52,DA,DR)
    107         ..S DIR(0)="52,"_(DR) D ^DIR I $D(DIRUT),X'="@" K DIR,DIRUT Q
    108         ..S PSORXED("FLD",DR)=X K DIR,DIRUT,DIROUT,X,Y,PSORXED(52,DA,DR)
    109         .I $G(PSORXED("FLD",DR))]"" D FIELD^DID(52,DR,"","LABEL","ZZ") S PSORXED(ZZ("LABEL"))=PSORXED("FLD",DR) K ZZ
    110         Q:$G(PSOSIGFL)
    111         S (RX1,I,RFD,RFDT)=0 F  S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'I  S RFD=I,RFDT=$P(^PSRX(PSORXED("IRXN"),1,I,0),"^"),RX1(I)=$G(RX1(I))+1
    112         Q
    113 CHK     S CHK=1 I $G(^PSDRUG($P(PSORXED("RX0"),"^",6),"I"))]"",^("I")<DT S VALMSG="This drug has been inactivated. ",PSORXED("DFLG")=1 Q
    114         K PSPOP I $G(PSODIV),$P(PSORXED("RX2"),"^",9)'=PSOSITE S PSPRXN=PSORXED("IRXN") D  Q:PSORXED("DFLG")
    115         .I '$P(PSOSYS,"^",2) S VALMSG="RX# "_$P(^PSRX(PSPRXN,0),"^")_" is not a valid choice. (Different Division)" S PSORXED("DFLG")=1 Q
    116         .I $P(PSOSYS,"^",3) K DIR,DUOUT,DTOUT D  K DIR,DUOUT,DTOUT Q
    117         ..W $C(7) S DIR("A",1)="",DIR("A",2)="RX# "_$P(^PSRX(PSPRXN,0),"^")_" is from another division.",DIR("A")="Continue: (Y/N)",DIR(0)="Y",DIR("?",1)="'Y' FOR YES",DIR("?")="'N' FOR NO"
    118         ..S DIR("B")="N" D ^DIR I 'Y!($D(DIRUT)) S PSORXED("DFLG")=1 W !
    119         ;
    120         I $P(^PSRX(PSORXED("IRXN"),"STA"),"^")=14!($P(^("STA"),"^")=15) S PSORXED("DFLG")=1 S VALMSG="Discontinued prescriptions cannot be edited." Q
    121         ;WVEHR ;begin p208
    122         S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
    123         D ^DIC K DIC ;vfah
    124         S PSOZAF=+Y ;vfah
    125         I $P($G(^PSRX(PSORXED("IRXN"),"OR1")),"^",5)=$G(PSOZAF) S PSORXED("DFLG")=1 S VALMSG="EDIT option is not available for Autofinshed Rxs" K PSOZAF Q  ;vfah
    126         ;WVEHR ;end p208
    127         I $P(^PSRX(PSORXED("IRXN"),"STA"),"^")=16 S PSORXED("DFLG")=1 S VALMSG="Prescriptions on Provider Hold cannot be edited." Q
    128 CHKX    K PSPOP,DIR,DTOUT,DUOUT,Y,X Q
    129         Q
    130 PROV    ;select provider
    131         S PSORXED("PROVIDER")=$P(RX0,"^",4),PSORXED("PROVIDER NAME")=$P(^VA(200,$P(RX0,"^",4),0),"^")
    132         D PROV^PSODIR(.PSORXED) I PSORXED("PROVIDER")'=$P(RX0,"^",4) D
    133         .K DIR,DIRUT W ! S DIR(0)="Y",DIR("A",1)="You have changed the name of the provider entered for this Rx."
    134         .S DIR("A",2)="This edit will cause the provider's name to be update for all fills.",DIR("A")="Do you want to continue" D ^DIR
    135         .I 'Y!$D(DIRUT) K PSORX("PROVIDER"),PSORX("PROVIDER NAME"),PSORX("COSIGNING PROVIDER") Q
    136         .S PSORXED("FLD",4)=PSORXED("PROVIDER") K DIR,DIRUT,DUOUT
    137         .S PSORXED("FLD",109)=$G(PSORXED("COSIGNING PROVIDER"))
    138         Q
    139 UDPROV  ;update provider
    140         S $P(^PSRX(PSORXED("IRXN"),0),"^",4)=PSORXED("PROVIDER"),$P(^(3),"^",3)=$G(PSORX("COSIGNING PROVIDER"))
    141         F XTY="1","P" F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),XTY,I)) Q:'I  S $P(^PSRX(PSORXED("IRXN"),XTY,I,0),"^",17)=PSORXED("PROVIDER") S:XTY RFED=I
    142         K XTY,I
    143         Q
    144 SIG     ;edit medication instructions (SIG)
    145         S PSOFDR=+$P(^PSRX(PSORXED("IRXN"),"SIG"),"^",2) I PSOFDR D
    146         .F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"SIG1",I)) Q:'I  S SIG(I)=^PSRX(PSORXED("IRXN"),"SIG1",I,0)
    147         E  S PSORX("SIG")=$P(^PSRX(PSORXED("IRXN"),"SIG"),"^")
    148         D SIG^PSODIR1(.PSORX) D:$G(PSORX("SIG"))]"" EN1^PSOSIGNO(PSORXED("IRXN"),PSORX("SIG"))
    149         I '$G(PSOSIGFL),$G(PSORX("SIG"))]"" S ^PSRX(PSORXED("IRXN"),"SIG")=PSORX("SIG") K ^PSRX(PSORXED("IRXN"),"SIG1") Q
    150         S PSOMRFLG=1
    151         Q
    152 UL      ;
    153         I '$G(PSOLOKED) Q
    154         D UL^PSSLOCK(PSODFN)
    155         D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
    156         Q
    157 SVAL    ;Set message for patient lock
    158         S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.")
    159         Q
    160 SVALO   ;Set message for order lock
    161         S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order.")
    162         Q
    163         ;
     1PSOOREDT ;BIR/SAB - edit orders from backdoor ;1/27/07  13:22
     2 ;;7.0;OUTPATIENT PHARMACY;**4,20,27,37,57,46,78,102,104,119,143,148,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ;External reference to ^PSDRUG supported by DBIA 221
     12 ;External reference to PSSLOCK supported by DBIA 2789
     13 ;External reference to ^VA(200 supported by DBIA 10060
     14SEL K PSOISLKD,PSOLOKED S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY D SVAL K PSOPLCK S VALMBCK="" Q
     15 K PSOPLCK D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) D UL^PSSLOCK(+$G(PSODFN)) D SVALO K PSOMSG S VALMBCK="" Q
     16 K PSOMSG S PSOLOKED=1
     17 K PSORX("DFLG"),DIR,DUOUT,DIRUT S DIR("A")="Select fields by number"
     18 S DIR(0)="LO^1:"_$S($$STATUS^PSOBPSUT($P(PSOLST(ORN),"^",2))'="":21,$G(REF):20,1:19)
     19 D ^DIR I $D(DIRUT) K DIR,DIRUT,DTOUT S VALMBCK="" D UL K PSOLOKED Q
     20EDTSEL N VALMCNT K PSOISLKD,PSORX("DFLG"),PSOOIFLG,PSOMRFLG,DIR,DIRUT,DTOUT,DTOUT,ZONE S (PSOEDIT,PSORXED)=1 I +Y S FST=Y D HLDHDR^PSOLMUTL D  G EX ;PSO LM SELECT MENU protocol
     21 .I '$G(PSOLOKED) S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY D SVAL K PSOPLCK S VALMBCK="",(PSOISLKD,PSODE)=1 Q
     22 .I '$G(PSOLOKED) K PSOPLCK D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) D UL^PSSLOCK(+$G(PSODFN)) D SVALO K PSOMSG S VALMBCK="",(PSOISLKD,PSODE)=1 Q
     23 .K PSOMSG,PSOPLCK S (NEWEDT,PSOLOKED)=1 D EDT
     24 E  S VALMBCK="",PSODE=1
     25EX I $G(PSOISLKD) D UL K PSOISLKD G EX2
     26 I '$G(PSOSIGFL),'$G(PSORXED("DFLG")) D UPDATE^PSOORED6 D LOG^PSORXED,POST^PSORXED G EX1
     27 I $G(PSOSIGFL)=1 D  Q:$G(PSORX("FN"))
     28 .N PSOTMP
     29 .S PSOTMP=$G(PSOFROM),PSOFROM="NEW"
     30 .S VALMSG="This change will create a new prescription!",NCPDPFLG=1
     31 .D EN^PSOORED1(.PSORXED)
     32 .I $G(PSORX("FN")) D  Q
     33 ..D ^PSOBUILD
     34 ..K QUIT,PSORX("DFLG"),FST,FLD,IEN,FLN,INCOM,PSOI,PSODRUG,PSOEDIT
     35 ..K PSORENW,PSOSIGFL,PSOOIFLG,PSOMRFLG,PSODIR,CHK,PSORX("SIG"),PSODE
     36 ..K PSOTRN,PSORX("EDIT"),PSORXED("FLD"),NEWEDT
     37 ..D EOJ^PSONEW
     38 ..D UL K PSOLOKED S VALMBCK="Q"
     39 .S PSOFROM=PSOTMP I PSOFROM="" K PSOFROM
     40 ;
     41EX1 I '$G(PSODE)!('$G(ZONE)) I $G(PSORENW("OIRXN")) D EN^PSOHLSN1(PSORENW("OIRXN"),"XX","","Order edited")
     42QUIT D UL K PSOLOKED D ^PSOBUILD,ACT^PSOORNE2 D:+^PSRX($P(PSOLST(ORN),"^",2),"STA")=5 EN^PSOCMOPC($P(PSOLST(ORN),"^",2))
     43 K:'$O(^PSRX($P(PSOLST(ORN),"^",2),1,0)) REF
     44EX2 S VALMBCK=$S($G(PSORX("FN")):"Q",$G(ZONE):"Q",1:"R") K PSORXED,FST,FLD,IEN,FLN,INCOM,PSOI,PSODRUG,PSOEDIT,PSORENW,PSOSIGFL,PSODIR,CHK,PSORX("SIG"),PSODE,PSOTRN,PSORX("DFLG"),RFED,ZONE,PSORX("EDIT"),PSOOIFLG,PSOMRFLG,SIG,QUIT
     45 K NEWEDT I $G(VALMBCK)="R" W ! D CLEAN^PSOVER1 H 2
     46 Q
     47 ;
     48EDT S NCPDPFLG=0
     49 S I=0 F  S I=$O(^PSRX($P(PSOLST(ORN),"^",2),1,I)) Q:'I  S PSORXED("RX1")=^PSRX($P(PSOLST(ORN),"^",2),1,I,0)
     50 S (RX0,PSORXED("RX0"))=^PSRX($P(PSOLST(ORN),"^",2),0),PSORXED("RX2")=$G(^(2)),PSORXED("RX3")=$G(^(3)),PSOSIG=$P(^("SIG"),"^")
     51 F FLD=1:1:$L(FST,",") Q:$P(FST,",",FLD)']""!($G(PSORXED("DFLG")))!($G(PSORX("DFLG")))  S FLN=+$P(FST,",",FLD) D
     52 .S PSORXED("DFLG")=0,(DA,PSORXED("IRXN"),PSORENW("OIRXN"))=$P(PSOLST(ORN),"^",2),RX0=^PSRX(PSORXED("IRXN"),0) S:$G(PSOSIG)="" PSOSIG=$P(^("SIG"),"^")
     53 .I '$G(PSOSIGFL) D
     54 ..S PSOI=+^PSRX(DA,"OR1"),PSODAYS=$P(RX0,"^",8),PSORXST=+$P($G(^PS(53,$P(RX0,"^",3),0)),"^",7)
     55 ..I 'PSOI S PSOI=+^PSDRUG($P(RX0,"^",6),2),$P(^PSRX(DA,"OR1"),"^")=PSOI
     56 ..S:'$G(PSODRUG("IEN")) PSODRUG("IEN")=$P(RX0,"^",6),PSODRUG("NAME")=$P(^PSDRUG($P(RX0,"^",6),0),"^")
     57 ..S PSODRUG("OI")=PSOI
     58 .S PSORX("PROVIDER")=$P(RX0,"^",4),PSORX("PROVIDER NAME")=$P(^VA(200,$P(RX0,"^",4),0),"^"),PSOTRN=$G(^PSRX(DA,"TN"))
     59 .D:'$G(CHK) POP^PSOSIGNO(DA),CHK Q:$G(PSORXED("DFLG"))
     60 .S FDR="39.2^"_$S($P(PSOPAR,"^",3):"6",1:"")_";6.5^113^114^3^1^22R^24^8^7^9^4^11;"_$S($P(RX0,"^",11)="W"&($P(PSOPAR,"^",12)):"35;",1:"")_"^10.6^5^20^23^12^PSOCOU^RF^81"
     61 .I FLN=20,'$G(REF) S VALMSG="There is no Refill Data to be edited." Q
     62 .S DR=$P(FDR,"^",FLN) I DR="RF" D REF^PSOORED2 Q
     63 .I DR="PSOCOU" D PSOCOU^PSOORED6 Q
     64 .I FLN=2,'$P(PSOPAR,"^",3) D  Q
     65 ..N NDC D NDC^PSODRG(RXN,0,,.NDC) I $G(NDC)="^"!($G(NDC)="") Q
     66 ..S (PSODRUG("NDC"),PSORXED("FLD",27))=NDC
     67 .I FLN'>2,'$P(PSOPAR,"^",3) S VALMSG="Check site parameters, Drug data is not editable." Q
     68 .I FLN=3 D EDTDOSE^PSOORED2 Q
     69 .I FLN=4 D INS^PSOORED1 Q
     70 .I FLN=1 D PSOI^PSOORED6 N PSOX S PSORXED=1,PSOX("IRXN")=$S($D(DA):DA,$D(PSORXED("IRXN")):PSORXED("IRXN"),$D(PSORENW("OIRXN")):PSORENW("OIRXN")) D:'$G(PSORXED("DFLG")) EN^PSODIAG Q
     71 .I FLN=2 D DRG^PSOORED6 N PSOX S PSORXED=1,PSOX("IRXN")=PSORXED("IRXN") D:'$G(PSORXED("DFLG")) EN^PSODIAG S:$O(^PSRX(PSORXED("IRXN"),1,0)) REF=1 Q
     72 .I FLN=12 D PROV Q
     73 .I FLN=6 D ISDT^PSOORED2 Q
     74 .I FLN=7 D FLDT^PSOORED2 Q
     75 .I FLN=21,$$STATUS^PSOBPSUT(RXN,0)="" S VALMSG="Invalid selection!" Q
     76 .I FLN=21 D  Q
     77 ..N DAW D EDTDAW^PSODAWUT(RXN,0,.DAW) I $G(DAW)="^" Q
     78 ..S (PSODRUG("DAW"),PSORXED("FLD",81))=DAW
     79 .I FLN=9!(FLN=10)!(FLN=11) D NOCHG^PSOORED7 Q
     80 .S DR=+DR
     81 .K DIR,DIRUT,DIROUT ;S DIE=52 D ^DIE I $D(Y) S PSORXED("DFLG")=1
     82 .K DIC,DIQ S DIC=52,DA=PSORXED("IRXN"),DIQ="PSORXED" D EN^DIQ1 K DIC,DIQ
     83 .S DIR("B")=$S($G(PSORXED("FLD",DR))]"":PSORXED("FLD",DR),1:PSORXED(52,DA,DR)),DIR(0)="52,"_DR D ^DIR
     84 .I DR=24!(DR=12) S PSORXED("FLD",DR)=X
     85 .I $D(DIRUT) K DIR,DIRUT,DUOUT,DTOUT,PSORXED(52,DA,DR),PSORXED("FLD",DR) Q
     86 .I DR'=5,X="@" W !,"Data Required!",! K DIC,DIQ,DR,DA,DIR,DIRUT,PSORXED(52,DA,DR),X,Y Q
     87 .I DR=5,X'="@" S Y=+Y
     88 .I DR=3!(DR=20)!(DR=23) S Y=+Y
     89 .S PSORXED("FLD",DR)=$S(X="@":X,1:Y) K DIR,DIRUT,DIROUT,X,Y,PSORXED(52,DA,DR)
     90 .I DR=11,PSORXED("FLD",DR)="W",$P(PSOPAR,"^",12) D
     91 ..D FIELD^DID(52,DR,"","LABEL","ZZ") S PSORXED(ZZ("LABEL"))=PSORXED("FLD",DR) K ZZ
     92 ..S DR=35,DIQ="PSORXED" D EN^DIQ1 K DIC,DIQ,DIRUT,DUOUT,DTOUT
     93 ..S:$G(PSORXED(52,DA,DR))]"" DIR("B")=PSORXED(52,DA,DR)
     94 ..S DIR(0)="52,"_(DR) D ^DIR I $D(DIRUT),X'="@" K DIR,DIRUT Q
     95 ..S PSORXED("FLD",DR)=X K DIR,DIRUT,DIROUT,X,Y,PSORXED(52,DA,DR)
     96 .I $G(PSORXED("FLD",DR))]"" D FIELD^DID(52,DR,"","LABEL","ZZ") S PSORXED(ZZ("LABEL"))=PSORXED("FLD",DR) K ZZ
     97 Q:$G(PSOSIGFL)
     98 S (RX1,I,RFD,RFDT)=0 F  S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'I  S RFD=I,RFDT=$P(^PSRX(PSORXED("IRXN"),1,I,0),"^"),RX1(I)=$G(RX1(I))+1
     99 Q
     100CHK S CHK=1 I $G(^PSDRUG($P(PSORXED("RX0"),"^",6),"I"))]"",^("I")<DT S VALMSG="This drug has been inactivated. ",PSORXED("DFLG")=1 Q
     101 K PSPOP I $G(PSODIV),$P(PSORXED("RX2"),"^",9)'=PSOSITE S PSPRXN=PSORXED("IRXN") D  Q:PSORXED("DFLG")
     102 .I '$P(PSOSYS,"^",2) S VALMSG="RX# "_$P(^PSRX(PSPRXN,0),"^")_" is not a valid choice. (Different Division)" S PSORXED("DFLG")=1 Q
     103 .I $P(PSOSYS,"^",3) K DIR,DUOUT,DTOUT D  K DIR,DUOUT,DTOUT Q
     104 ..W $C(7) S DIR("A",1)="",DIR("A",2)="RX# "_$P(^PSRX(PSPRXN,0),"^")_" is from another division.",DIR("A")="Continue: (Y/N)",DIR(0)="Y",DIR("?",1)="'Y' FOR YES",DIR("?")="'N' FOR NO"
     105 ..S DIR("B")="N" D ^DIR I 'Y!($D(DIRUT)) S PSORXED("DFLG")=1 W !
     106 ;
     107 I $P(^PSRX(PSORXED("IRXN"),"STA"),"^")=14!($P(^("STA"),"^")=15) S PSORXED("DFLG")=1 S VALMSG="Discontinued prescriptions cannot be edited." Q
     108 ;
     109 S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
     110 D ^DIC K DIC ;vfah
     111 S PSOZAF=+Y ;vfah
     112 I $P($G(^PSRX(PSORXED("IRXN"),"OR1")),"^",5)=$G(PSOZAF) S PSORXED("DFLG")=1 S VALMSG="EDIT option is not available for Autofinshed Rxs" K PSOZAF Q  ;vfah
     113 ;
     114 I $P(^PSRX(PSORXED("IRXN"),"STA"),"^")=16 S PSORXED("DFLG")=1 S VALMSG="Prescriptions on Provider Hold cannot be edited." Q
     115CHKX K PSPOP,DIR,DTOUT,DUOUT,Y,X Q
     116 Q
     117PROV ;select provider
     118 S PSORXED("PROVIDER")=$P(RX0,"^",4),PSORXED("PROVIDER NAME")=$P(^VA(200,$P(RX0,"^",4),0),"^")
     119 D PROV^PSODIR(.PSORXED) I PSORXED("PROVIDER")'=$P(RX0,"^",4) D
     120 .K DIR,DIRUT W ! S DIR(0)="Y",DIR("A",1)="You have changed the name of the provider entered for this Rx."
     121 .S DIR("A",2)="This edit will cause the provider's name to be update for all fills.",DIR("A")="Do you want to continue" D ^DIR
     122 .I 'Y!$D(DIRUT) K PSORX("PROVIDER"),PSORX("PROVIDER NAME"),PSORX("COSIGNING PROVIDER") Q
     123 .S PSORXED("FLD",4)=PSORXED("PROVIDER") K DIR,DIRUT,DUOUT
     124 .S PSORXED("FLD",109)=$G(PSORXED("COSIGNING PROVIDER"))
     125 Q
     126UDPROV ;update provider
     127 S $P(^PSRX(PSORXED("IRXN"),0),"^",4)=PSORXED("PROVIDER"),$P(^(3),"^",3)=$G(PSORX("COSIGNING PROVIDER"))
     128 F XTY="1","P" F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),XTY,I)) Q:'I  S $P(^PSRX(PSORXED("IRXN"),XTY,I,0),"^",17)=PSORXED("PROVIDER") S:XTY RFED=I
     129 K XTY,I
     130 Q
     131SIG ;edit medication instructions (SIG)
     132 S PSOFDR=+$P(^PSRX(PSORXED("IRXN"),"SIG"),"^",2) I PSOFDR D
     133 .F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"SIG1",I)) Q:'I  S SIG(I)=^PSRX(PSORXED("IRXN"),"SIG1",I,0)
     134 E  S PSORX("SIG")=$P(^PSRX(PSORXED("IRXN"),"SIG"),"^")
     135 D SIG^PSODIR1(.PSORX) D:$G(PSORX("SIG"))]"" EN1^PSOSIGNO(PSORXED("IRXN"),PSORX("SIG"))
     136 I '$G(PSOSIGFL),$G(PSORX("SIG"))]"" S ^PSRX(PSORXED("IRXN"),"SIG")=PSORX("SIG") K ^PSRX(PSORXED("IRXN"),"SIG1") Q
     137 S PSOMRFLG=1
     138 Q
     139UL ;
     140 I '$G(PSOLOKED) Q
     141 D UL^PSSLOCK(PSODFN)
     142 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
     143 Q
     144SVAL ;Set message for patient lock
     145 S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.")
     146 Q
     147SVALO ;Set message for order lock
     148 S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order.")
     149 Q
     150 ;

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI1.m

    r613 r623  
    1 PSOORFI1        ;BIR/SAB - finish OP orders from OE/RR continued ;5/23/05 2:11pm
    2         ;;7.0;OUTPATIENT PHARMACY;**7,15,23,27,32,44,51,46,71,90,108,131,152,186,210,222,258,260,225**;DEC 1997;Build 29
    3         ;Ref. ^PS(50.7 supp. DBIA 2223
    4         ;Ref. ^PSDRUG( supp. DBIA 221
    5         ;Ref. L^PSSLOCK supp. DBIA 2789
    6         ;Ref. ^PS(50.606 supp. DBIA 2174
    7         ;Ref. ^PS(55 supp. DBIA 2228
    8         ;Ref. ULK^ORX2 supp. DBIA 867
    9         ;
    10         ;PSO*186 add call to function $$DEACHK
    11         ;PSO*210 add call to WORDWRAP api
    12         ;
    13         S SIGOK=1
    14 DSPL    K ^TMP("PSOPO",$J),CLOZPAT,PSOPRC,PSODSPL
    15         S (OI,PSODRUG("OI"))=$P(OR0,"^",8),PSODRUG("OIN")=$P(^PS(50.7,$P(OR0,"^",8),0),"^"),OID=$P(OR0,"^",9)
    16         I $P($G(OR0),"^",9) S POERR=1,DREN=$P(OR0,"^",9) D DRG^PSOORDRG K POERR G DRG
    17         I '$P(OR0,"^",9) D DREN^PSOORNW2
    18 DRG     I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),"CLOZ1")),"^")="PSOCLO1" D CLOZ^PSOORFI2
    19         ;PSO*186 modify If/Else below to use DEACHK
    20         I $G(PSODRUG("DEA"))]"" D
    21         .S PSOCS=0 K DIR,DIC,PSOX
    22         .N PSDEA,PSDAYS S PSDEA=PSODRUG("DEA"),PSDAYS=+$P(OR0,"^",22)
    23         .I $$DEACHK^PSOUTLA1("*",PSDEA,PSDAYS,$G(CLOZPAT),.PSOCS,.PSOMAX)
    24         E  D
    25         .S PSOMAX=$S($G(CLOZPAT)=2:3,$G(CLOZPAT)=1:1,1:$P(OR0,"^",11))
    26 ISSDT   S (PSOID,Y,PSONEW("ISSUE DATE"))=$S($G(PSONEW("ISSUE DATE")):PSONEW("ISSUE DATE"),$P($G(OR0),"^",6):$E($P(OR0,"^",6),1,7),1:DT)
    27         X ^DD("DD") S PSONEW("ISSUE DATE")=Y
    28         D USER^PSOORFI2($P(OR0,"^",4)) S PSONEW("CLERK CODE")=$P(OR0,"^",4),PSORX("CLERK CODE")=USER1
    29         S (PSONEW("DFLG"),PSONEW("QFLG"))=0,PSODFN=$P(OR0,"^",2),PSONEW("QTY")=$P(OR0,"^",10),PSONEW("MAIL/WINDOW")=$S($P(OR0,"^",17)="M":"M",1:"W")
    30         S:$G(PSONEW("CLINIC"))']"" PSONEW("CLINIC")=+$P(OR0,"^",13),PSORX("CLINIC")=$S($D(^SC(PSONEW("CLINIC"),0)):$P(^SC(PSONEW("CLINIC"),0),"^"),1:"")
    31         S:$G(PSORX("CLINIC"))']"" PSORX("CLINIC")=$S($D(^SC(+$P(OR0,"^",13),0)):$P(^SC($P(OR0,"^",13),0),"^"),1:"")
    32         D USER^PSOORFI2($P(OR0,"^",5))
    33         S PSONEW("CLERK CODE")=$P(OR0,"^",4),PSONEW("PROVIDER")=$P(OR0,"^",5),PSONEW("PROVIDER NAME")=USER1
    34         S PSONEW("PATIENT STATUS")=$S(+$G(^PS(55,PSODFN,"PS")):+$G(^PS(55,PSODFN,"PS")),1:"")
    35         S PSONEW("CHCS NUMBER")=$S($P($G(^PS(52.41,+$G(ORD),"EXT")),"^")'="":$P($G(^("EXT")),"^"),1:"")
    36         S PSONEW("EXTERNAL SYSTEM")=$S($P($G(^PS(52.41,+$G(ORD),"EXT")),"^",3)'="":$P($G(^("EXT")),"^",3),1:"")
    37         I $P(OR0,"^",22)>0 S PSONEW("DAYS SUPPLY")=$P(OR0,"^",22) G DS
    38         S PSONEW("DAYS SUPPLY")=$S(+$G(^PS(55,PSODFN,"PS"))&($P($G(^PS(53,+$G(^PS(55,PSODFN,"PS")),0)),"^",3)):$P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3),1:30)
    39 DS      S:$D(CLOZPAT) PSONEW("DAYS SUPPLY")=$S(CLOZPAT=2&(PSONEW("DAYS SUPPLY")>28):28,CLOZPAT=1&(PSONEW("DAYS SUPPLY")>14):14,'CLOZPAT&(PSONEW("DAYS SUPPLY")>7):7,1:PSONEW("DAYS SUPPLY"))
    40         S IEN=0 D OBX                ; Display Order Checks Information
    41         D LMDISP^PSOORFI5(+$G(ORD))  ; Display Flag/Unflag Information
    42         D DIN^PSONFI(PSODRUG("OI"),$S($D(PSODRUG("IEN")):PSODRUG("IEN"),1:"")) ;Setup for N/F & DIN indicator
    43         I $G(PKI1)!($G(PKI)=1) D L1^PSOPKIV1 K:$G(PKI)=1 PKI
    44         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="*(1) Orderable Item: "_$P(^PS(50.7,PSODRUG("OI"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_NFIO
    45         S:NFIO["<DIN>" NFIO=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
    46         D FULL^VALM1 K LST I $G(PSODRUG("NAME"))]"" D  G PST
    47         .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2)"_$S($D(^PSDRUG("AQ",PSODRUG("IEN"))):"      CMOP ",1:"           ")_"Drug: "_PSODRUG("NAME")_NFID
    48         .S:NFID["<DIN>" NFID=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
    49         .I $P(^PSDRUG(PSODRUG("IEN"),0),"^",10)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       Drug Message:" D DRGMSG^PSOORNEW
    50         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2)           Drug: No Dispense Drug Selected"
    51 PST     D DOSE^PSOORFI4 K PSOINSFL
    52         S PSOINSFL=$P($G(^PS(52.41,ORD,"INS")),"^",2)
    53         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (4)   Pat Instruct:" D INST^PSOORFI4
    54         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  Provider Comments:" S TY=3 D INST
    55         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       Instructions:" S TY=2 D INST
    56         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                SIG:" D SIG
    57         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (5) Patient Status: "_$P($G(^PS(53,+PSONEW("PATIENT STATUS"),0)),"^")
    58         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (6)     Issue Date: "_PSONEW("ISSUE DATE")
    59         S (Y,PSONEW("FILL DATE"))=$S($E($P(OR0,"^",6),1,7)<DT:DT,1:$E($P(OR0,"^",6),1,7)) X ^DD("DD") S PSORX("FILL DATE")=Y,^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"        (7) Fill Date: "_Y
    60         I $P(OR0,"^",18) D
    61         .S IEN=IEN+1,Y=$P(OR0,"^",18) X ^DD("DD") S $P(^TMP("PSOPO",$J,IEN,0)," ",39)="Effective Date: "_Y
    62         D:$D(CLOZPAT) ELIG^PSOORFI2,CLQTY^PSOORFI4
    63         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (8)    Days Supply: "_$S($G(PSONEW("DAYS SUPPLY")):PSONEW("DAYS SUPPLY"),+$G(^PS(55,PSODFN,"PS"))&($P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3)):$P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3),1:"")
    64         I +$G(^PS(55,PSODFN,"PS")) S RXPT=+^("PS") I $G(^PS(53,RXPT,0))]"" D
    65         .S PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:+$P(OR0,"^",11)),PSOX=+$P(^PS(53,RXPT,0),"^",4)
    66         .S PSONEW("# OF REFILLS")=$S(PSONEW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSONEW("# OF REFILLS"))
    67         .S PSOMAX=$S(PSOMAX>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:PSOMAX) K RXPT
    68         .S MPSDY=PSONEW("DAYS SUPPLY")
    69         .;I PSOMAX=5 S MAXRF=$S(MPSDY<60:5,MPSDY'<60&(MPSDY'>89):2,1:1) I PSONEW("# OF REFILLS")>MAXRF S PSONEW("# OF REFILLS")=MAXRF K MAXRF,MPSDY Q
    70         .S MAXRF=$S(MPSDY<60:11,MPSDY'<60&(MPSDY'>89):5,MPSDY=90:3,1:0)
    71         .I PSONEW("# OF REFILLS")>MAXRF S PSONEW("# OF REFILLS")=MAXRF K MAXRF,MPSDY
    72         E  D
    73         . I $G(PSOMAX) S PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11)) Q
    74         .S PSONEW("# OF REFILLS")=+$P(OR0,"^",11)
    75         S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"                (9)   QTY"_$S($P($G(^PSDRUG(+$G(PSODRUG("IEN")),660)),"^",8)]"":" ("_$P($G(^PSDRUG(+$G(PSODRUG("IEN")),660)),"^",8)_")",1:" (  )")_": "
    76         S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_$S($D(CLOZPAT):+$G(PSONEW("QTY")),1:$P(OR0,"^",10))
    77         I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),5)),"^")]"" D
    78         .S $P(RN," ",79)=" ",IEN=IEN+1
    79         .S ^TMP("PSOPO",$J,IEN,0)=$E(RN,$L("QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^"))+1,79)_"QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^") K RN
    80         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       Provider ordered "_+$P(OR0,"^",11)_" refills"
    81         D:$D(CLOZPAT) PQTY^PSOORFI4
    82         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(10)   # of Refills: "_PSONEW("# OF REFILLS")_$E("  ",$L(PSONEW("# OF REFILLS"))+1,2)_"               (11)   Routing: "_$S($G(PSONEW("MAIL/WINDOW"))="M":"MAIL",1:"WINDOW")
    83         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(12)         Clinic: "_PSORX("CLINIC")
    84         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(13)       Provider: "_PSONEW("PROVIDER NAME")
    85         I $P($G(^VA(200,$S($G(PSONEW("PROVIDER")):PSONEW("PROVIDER"),1:$P(OR0,"^",5)),"PS")),"^",7)&($P($G(^("PS")),"^",8)) S PSONEW("COSIGNING PROVIDER")=$P(^("PS"),"^",8) D
    86         .D USER^PSOORFI2(PSONEW("COSIGNING PROVIDER"))
    87         .S IEN=IEN+1 S ^TMP("PSOPO",$J,IEN,0)="        Cos-Provider: "_USER1
    88         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(14)         Copies: 1"
    89         S PSONEW("REMARKS")=$S($P(OR0,"^",17)="C":"Administered in Clinic.",1:"")
    90         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(15)        Remarks: "_$S($G(PSONEW("REMARKS"))]"":PSONEW("REMARKS"),1:"")
    91         D USER^PSOORFI2($P(OR0,"^",4))
    92         S $P(RN," ",35)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="   Entry By: "_USER1_$E(RN,$L(USER1)+1,35)
    93         S Y=$P(OR0,"^",12) X ^DD("DD") S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"Entry Date: "_$E($P(OR0,"^",12),4,5)_"/"_$E($P(OR0,"^",12),6,7)_"/"_$E($P(OR0,"^",12),2,3)_" "_$P(Y,"@",2) K RN
    94         S PSOACT=$S($D(^XUSEC("PSORPH",DUZ)):"DEFX",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"")
    95         ; - PSOACTOV is used to force the Pending Order to be Read-Only (no updates) even if invoked by a Pharmacist
    96         I $G(PSOACTOV) S PSOACT=""
    97         D:'$G(ACP) EN^PSOLMPO S:$G(ACP) VALMBCK="Q" D:$G(PKI1)=2 DCP^PSOPKIV1
    98         Q
    99 POST    ;post patient selection
    100         D POST^PSOORFI2 Q
    101 SIG     ;displays possible sig
    102         D SIG^PSOORFI2 Q
    103 INST    ;displays provider comments and pharmacy instructions
    104         S INST=0 F  S INST=$O(^PS(52.41,ORD,TY,INST)) Q:'INST  D     ;PSO*210
    105         . S (MIG,INST(INST))=^PS(52.41,ORD,TY,INST,0)
    106         . D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOPO",$J)),20)
    107         K INST,TY,MIG,SG
    108         Q
    109 OBX     ;formats obx section
    110         D OBX^PSOORFI4
    111         Q
    112 ST      ;sort by route or patient
    113         W !!,"Enter 'PA' to process orders by patients",!,"      'RT' to process orders by route (mail/window)",!,"      'PR' to process orders by priority",!,"      'CL' to process orders by clinic"
    114         W !,"      'FL' to process flagged orders",!,"   or 'E' or '^' to exit" W ! Q
    115 RT      ;which route to sort by
    116         W !!,"Enter 'W' to process window orders first",!,"      'M' to process mail orders first",!,"      'C' to process orders administered in clinic first",!,"   or 'E' or '^' to exit" Q
    117 PT      ;process for all or one patient
    118         W !!,"Enter 'A' to process all patient orders",!,"      'S' to process orders for a patient",!,"      or 'E' or '^' to exit" Q
    119 EP      ;continue processing or not
    120         W !,"If you want to continue processing orders Press RETURN or enter '^' to exit" Q
    121 LOCK    S PSOPLCK=$$L^PSSLOCK(PAT,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S POERR("QFLG")=1
    122         K PSOPLCK
    123         Q
    124 ULK     S X=PAT_";DPT(" D ULK^ORX2 S:$G(PSOQUIT) POERR("QFLG")=1 ; not called anymore
    125         Q
    126 LOCK1   S PSOACT=$S($D(^XUSEC("PSORPH",DUZ)):"DEFX",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"")
    127         Q
    128 EX      K DRET,SIG,PSODRUG,PRC,PHI
    129         K DIR,DIRUT,DUOUT,DIRUT,X,Y,DIC,POERR,PSONEW,PSOSD,MAIL,CLI,WIN,OR0,OR1,OR2,ORD,SRT,PSRT,PSODFN,PSOFROM,T,OR3,PAT,%,%T,%Y,DI,DQ,DR,DRG,STA,I,T1,PSOSORT
    130         K TO,TC,TZ,PSOCPAY,PSOBILL,PSOIBQS,GROUPCNT,AGROUP,AGROUP1,OBX,%,%I,%H,D0,DFN,PSORX,PSOPTPST,PSOQFLG,PT,RTN,TM,TM1,DIPGM,PSOID,PSOCNT,PSOLK,PSZFIN,PSZFZZ D KVA^VADPT
    131         K PSOFDR,PSOQUIT,PSOFIN,^TMP("PSOAO",$J),^TMP("PSODA",$J),^TMP("PSOPO",$J),^TMP("PSOPF",$J),^TMP("PSOPI",$J),^TMP("PSOHDR",$J),MEDA,MEDP
    132         K C,CC,CNT,CRIT,D,DGI,DGS,DREN,IT,JJ,LG,MM,NIEN,PSOD,PATA,PSDAYS,PSOACT,PSOBM,PSOCOU,PSOCOUU,PSOFLAG,PSON,PSONOOR,PSOOPT,PSOPF,PSOPI,PSRF,RXFL,SDA,SEG1,SER,SERS,SLPPL,STAT,Z,Z4,ZDA
    133         D FULL^VALM1
    134         Q
     1PSOORFI1 ;BIR/SAB - finish OP orders from OE/RR continued ;1/27/07  13:24
     2 ;;7.0;OUTPATIENT PHARMACY;**7,15,23,27,32,44,51,46,71,90,108,131,152,186,210,222,258,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; GPL Copyright (C) 2007 WorldVistA
     5 ;Ref. ^PS(50.7 supp. DBIA 2223
     6 ;Ref. ^PSDRUG( supp. DBIA 221
     7 ;Ref. L^PSSLOCK supp. DBIA 2789
     8 ;Ref. ^PS(50.606 supp. DBIA 2174
     9 ;Ref. ^PS(55 supp. DBIA 2228
     10 ;Ref. ULK^ORX2 supp. DBIA 867
     11 ;
     12 ;PSO*186 add call to function $$DEACHK
     13 ;PSO*210 add call to WORDWRAP api
     14 ;
     15 S SIGOK=1
     16DSPL K ^TMP("PSOPO",$J),CLOZPAT,PSOPRC,PSODSPL
     17 S (OI,PSODRUG("OI"))=$P(OR0,"^",8),PSODRUG("OIN")=$P(^PS(50.7,$P(OR0,"^",8),0),"^"),OID=$P(OR0,"^",9)
     18 I $P($G(OR0),"^",9) S POERR=1,DREN=$P(OR0,"^",9) D DRG^PSOORDRG K POERR G DRG
     19 I '$P(OR0,"^",9)&($G(PSOAFYN)="Y") D DISPD^PSOAFIN G DSPL ;vfah 060924
     20 I '$P(OR0,"^",9) D DREN^PSOORNW2
     21DRG I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),"CLOZ1")),"^")="PSOCLO1" D CLOZ^PSOORFI2
     22 ;PSO*186 modify If/Else below to use DEACHK
     23 I $G(PSODRUG("DEA"))]"" D
     24 .S PSOCS=0 K DIR,DIC,PSOX
     25 .N PSDEA,PSDAYS S PSDEA=PSODRUG("DEA"),PSDAYS=+$P(OR0,"^",22)
     26 .I $$DEACHK^PSOUTLA1("*",PSDEA,PSDAYS,$G(CLOZPAT),.PSOCS,.PSOMAX)
     27 E  D
     28 .S PSOMAX=$S($G(CLOZPAT)=2:3,$G(CLOZPAT)=1:1,1:$P(OR0,"^",11))
     29ISSDT S (PSOID,Y,PSONEW("ISSUE DATE"))=$S($G(PSONEW("ISSUE DATE")):PSONEW("ISSUE DATE"),$P($G(OR0),"^",6):$E($P(OR0,"^",6),1,7),1:DT)
     30 X ^DD("DD") S PSONEW("ISSUE DATE")=Y
     31 D USER^PSOORFI2($P(OR0,"^",4)) S PSONEW("CLERK CODE")=$P(OR0,"^",4),PSORX("CLERK CODE")=USER1
     32 S (PSONEW("DFLG"),PSONEW("QFLG"))=0,PSODFN=$P(OR0,"^",2),PSONEW("QTY")=$P(OR0,"^",10),PSONEW("MAIL/WINDOW")=$S($P(OR0,"^",17)="M":"M",1:"W")
     33 S:$G(PSONEW("CLINIC"))']"" PSONEW("CLINIC")=+$P(OR0,"^",13),PSORX("CLINIC")=$S($D(^SC(PSONEW("CLINIC"),0)):$P(^SC(PSONEW("CLINIC"),0),"^"),1:"")
     34 S:$G(PSORX("CLINIC"))']"" PSORX("CLINIC")=$S($D(^SC(+$P(OR0,"^",13),0)):$P(^SC($P(OR0,"^",13),0),"^"),1:"")
     35 D USER^PSOORFI2($P(OR0,"^",5))
     36 S PSONEW("CLERK CODE")=$P(OR0,"^",4),PSONEW("PROVIDER")=$P(OR0,"^",5),PSONEW("PROVIDER NAME")=USER1
     37 S PSONEW("PATIENT STATUS")=$S(+$G(^PS(55,PSODFN,"PS")):+$G(^PS(55,PSODFN,"PS")),1:"")
     38 S PSONEW("CHCS NUMBER")=$S($P($G(^PS(52.41,+$G(ORD),"EXT")),"^")'="":$P($G(^("EXT")),"^"),1:"")
     39 S PSONEW("EXTERNAL SYSTEM")=$S($P($G(^PS(52.41,+$G(ORD),"EXT")),"^",3)'="":$P($G(^("EXT")),"^",3),1:"")
     40 I $P(OR0,"^",22)>0 S PSONEW("DAYS SUPPLY")=$P(OR0,"^",22) G DS
     41 S PSONEW("DAYS SUPPLY")=$S(+$G(^PS(55,PSODFN,"PS"))&($P($G(^PS(53,+$G(^PS(55,PSODFN,"PS")),0)),"^",3)):$P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3),1:30)
     42DS S:$D(CLOZPAT) PSONEW("DAYS SUPPLY")=$S(CLOZPAT=2&(PSONEW("DAYS SUPPLY")>28):28,CLOZPAT=1&(PSONEW("DAYS SUPPLY")>14):14,'CLOZPAT&(PSONEW("DAYS SUPPLY")>7):7,1:PSONEW("DAYS SUPPLY"))
     43 S IEN=0 D OBX
     44 D DIN^PSONFI(PSODRUG("OI"),$S($D(PSODRUG("IEN")):PSODRUG("IEN"),1:"")) ;Setup for N/F & DIN indicator
     45 I $G(PKI1)!($G(PKI)=1) D L1^PSOPKIV1 K:$G(PKI)=1 PKI
     46 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="*(1) Orderable Item: "_$P(^PS(50.7,PSODRUG("OI"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_NFIO
     47 S:NFIO["<DIN>" NFIO=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
     48 D FULL^VALM1 K LST I $G(PSODRUG("NAME"))]"" D  G PST
     49 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2)"_$S($D(^PSDRUG("AQ",PSODRUG("IEN"))):"      CMOP ",1:"           ")_"Drug: "_PSODRUG("NAME")_NFID
     50 .S:NFID["<DIN>" NFID=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
     51 .I $P(^PSDRUG(PSODRUG("IEN"),0),"^",10)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       Drug Message:" D DRGMSG^PSOORNEW
     52 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2)           Drug: No Dispense Drug Selected"
     53PST D DOSE^PSOORFI4 K PSOINSFL
     54 S PSOINSFL=$P($G(^PS(52.41,ORD,"INS")),"^",2)
     55 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (4)   Pat Instruct:" D INST^PSOORFI4
     56 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  Provider Comments:" S TY=3 D INST
     57 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       Instructions:" S TY=2 D INST
     58 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                SIG:" D SIG
     59 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (5) Patient Status: "_$P($G(^PS(53,+PSONEW("PATIENT STATUS"),0)),"^")
     60 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (6)     Issue Date: "_PSONEW("ISSUE DATE")
     61 S (Y,PSONEW("FILL DATE"))=$S($E($P(OR0,"^",6),1,7)<DT:DT,1:$E($P(OR0,"^",6),1,7)) X ^DD("DD") S PSORX("FILL DATE")=Y,^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"        (7) Fill Date: "_Y
     62 I $P(OR0,"^",18) D
     63 .S IEN=IEN+1,Y=$P(OR0,"^",18) X ^DD("DD") S $P(^TMP("PSOPO",$J,IEN,0)," ",39)="Effective Date: "_Y
     64 D:$D(CLOZPAT) ELIG^PSOORFI2,CLQTY^PSOORFI4
     65 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (8)    Days Supply: "_$S($G(PSONEW("DAYS SUPPLY")):PSONEW("DAYS SUPPLY"),+$G(^PS(55,PSODFN,"PS"))&($P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3)):$P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3),1:"")
     66 I +$G(^PS(55,PSODFN,"PS")) S RXPT=+^("PS") I $G(^PS(53,RXPT,0))]"" D
     67 .S PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:+$P(OR0,"^",11)),PSOX=+$P(^PS(53,RXPT,0),"^",4)
     68 .S PSONEW("# OF REFILLS")=$S(PSONEW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSONEW("# OF REFILLS"))
     69 .S PSOMAX=$S(PSOMAX>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:PSOMAX) K RXPT
     70 .S MPSDY=PSONEW("DAYS SUPPLY")
     71 .;I PSOMAX=5 S MAXRF=$S(MPSDY<60:5,MPSDY'<60&(MPSDY'>89):2,1:1) I PSONEW("# OF REFILLS")>MAXRF S PSONEW("# OF REFILLS")=MAXRF K MAXRF,MPSDY Q
     72 .S MAXRF=$S(MPSDY<60:11,MPSDY'<60&(MPSDY'>89):5,MPSDY=90:3,1:0)
     73 .I PSONEW("# OF REFILLS")>MAXRF S PSONEW("# OF REFILLS")=MAXRF K MAXRF,MPSDY
     74 E  D
     75 . I $G(PSOMAX) S PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11)) Q
     76 .S PSONEW("# OF REFILLS")=+$P(OR0,"^",11)
     77 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"                (9)   QTY"_$S($P($G(^PSDRUG(+$G(PSODRUG("IEN")),660)),"^",8)]"":" ("_$P($G(^PSDRUG(+$G(PSODRUG("IEN")),660)),"^",8)_")",1:" (  )")_": "_$P(OR0,"^",10)
     78 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_$S($D(CLOZPAT):+$G(PSONEW("QTY")),1:$P(OR0,"^",10))
     79 I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),5)),"^")]"" D
     80 .S $P(RN," ",79)=" ",IEN=IEN+1
     81 .S ^TMP("PSOPO",$J,IEN,0)=$E(RN,$L("QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^"))+1,79)_"QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^") K RN
     82 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       Provider ordered "_+$P(OR0,"^",11)_" refills"
     83 D:$D(CLOZPAT) PQTY^PSOORFI4
     84 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(10)   # of Refills: "_PSONEW("# OF REFILLS")_$E("  ",$L(PSONEW("# OF REFILLS"))+1,2)_"               (11)   Routing: "_$S($G(PSONEW("MAIL/WINDOW"))="M":"MAIL",1:"WINDOW")
     85 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(12)         Clinic: "_PSORX("CLINIC")
     86 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(13)       Provider: "_PSONEW("PROVIDER NAME")
     87 I $P($G(^VA(200,$S($G(PSONEW("PROVIDER")):PSONEW("PROVIDER"),1:$P(OR0,"^",5)),"PS")),"^",7)&($P($G(^("PS")),"^",8)) S PSONEW("COSIGNING PROVIDER")=$P(^("PS"),"^",8) D
     88 .D USER^PSOORFI2(PSONEW("COSIGNING PROVIDER"))
     89 .S IEN=IEN+1 S ^TMP("PSOPO",$J,IEN,0)="        Cos-Provider: "_USER1
     90 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(14)         Copies: 1"
     91 S PSONEW("REMARKS")=$S($P(OR0,"^",17)="C":"Administered in Clinic.",1:"")
     92 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(15)        Remarks: "_$S($G(PSONEW("REMARKS"))]"":PSONEW("REMARKS"),1:"")
     93 D USER^PSOORFI2($P(OR0,"^",4))
     94 S $P(RN," ",35)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="   Entry By: "_USER1_$E(RN,$L(USER1)+1,35)
     95 S Y=$P(OR0,"^",12) X ^DD("DD") S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"Entry Date: "_$E($P(OR0,"^",12),4,5)_"/"_$E($P(OR0,"^",12),6,7)_"/"_$E($P(OR0,"^",12),2,3)_" "_$P(Y,"@",2) K RN
     96 S PSOACT=$S($D(^XUSEC("PSORPH",DUZ)):"DEF",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"")
     97 D:'$G(ACP) EN^PSOLMPO S:$G(ACP) VALMBCK="Q" D:$G(PKI1)=2 DCP^PSOPKIV1
     98 Q
     99POST ;post patient selection
     100 I $G(PSOAFYN)'="Y" D POST^PSOORFI2 Q  ;vfah
     101 I $G(PSOAFYN)="Y" Q  ;vfah
     102SIG ;displays possible sig
     103 D SIG^PSOORFI2 Q
     104INST ;displays provider comments and pharmacy instructions
     105 S INST=0 F  S INST=$O(^PS(52.41,ORD,TY,INST)) Q:'INST  D     ;PSO*210
     106 . S (MIG,INST(INST))=^PS(52.41,ORD,TY,INST,0)
     107 . D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOPO",$J)),20)
     108 K INST,TY,MIG,SG
     109 Q
     110OBX ;formats obx section
     111 D OBX^PSOORFI4
     112 Q
     113ST ;sort by route or patient
     114 W !!,"Enter 'PA' to process orders by patients",!,"      'RT' to process orders by route (mail/window)",!,"      'PR' to process orders by priority",!,"      'CL' to process orders by clinic",!,"   or 'E' or '^' to exit" W ! Q
     115RT ;which route to sort by
     116 W !!,"Enter 'W' to process window orders first",!,"      'M' to process mail orders first",!,"      'C' to process orders administered in clinic first",!,"   or 'E' or '^' to exit" Q
     117PT ;process for all or one patient
     118 W !!,"Enter 'A' to process all patient orders",!,"      'S' to process orders for a patient",!,"      or 'E' or '^' to exit" Q
     119EP ;continue processing or not
     120 W !,"If you want to continue processing orders Press RETURN or enter '^' to exit" Q
     121LOCK S PSOPLCK=$$L^PSSLOCK(PAT,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S POERR("QFLG")=1
     122 K PSOPLCK
     123 Q
     124ULK S X=PAT_";DPT(" D ULK^ORX2 S:$G(PSOQUIT) POERR("QFLG")=1 ; not called anymore
     125 Q
     126LOCK1 S PSOACT=$S($D(^XUSEC("PSORPH",DUZ)):"DEF",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"")
     127 Q
     128EX K DRET,SIG,PSODRUG,PRC,PHI
     129 K DIR,DIRUT,DUOUT,DIRUT,X,Y,DIC,POERR,PSONEW,PSOSD,MAIL,CLI,WIN,OR0,OR1,OR2,ORD,SRT,PSRT,PSODFN,PSOFROM,T,OR3,PAT,%,%T,%Y,DI,DQ,DR,DRG,STA,I,T1,PSOSORT
     130 K TO,TC,TZ,PSOCPAY,PSOBILL,PSOIBQS,GROUPCNT,AGROUP,AGROUP1,OBX,%,%I,%H,D0,DFN,PSORX,PSOPTPST,PSOQFLG,PT,RTN,TM,TM1,DIPGM,PSOID,PSOCNT,PSOLK,PSZFIN,PSZFZZ D KVA^VADPT
     131 K PSOFDR,PSOQUIT,PSOFIN,^TMP("PSOAO",$J),^TMP("PSODA",$J),^TMP("PSOPO",$J),^TMP("PSOPF",$J),^TMP("PSOPI",$J),^TMP("PSOHDR",$J),MEDA,MEDP
     132 K C,CC,CNT,CRIT,D,DGI,DGS,DREN,IT,JJ,LG,MM,NIEN,PSOD,PATA,PSDAYS,PSOACT,PSOBM,PSOCOU,PSOCOUU,PSOFLAG,PSON,PSONOOR,PSOOPT,PSOPF,PSOPI,PSRF,RXFL,SDA,SEG1,SER,SERS,SLPPL,STAT,Z,Z4,ZDA
     133 D FULL^VALM1
     134 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI2.m

    r613 r623  
    1 PSOORFI2        ;BIR/BHW-finish cprs orders cont. ;07/29/96
    2         ;;7.0;OUTPATIENT PHARMACY;**7,15,23,27,46,130,146,177,222,225**;DEC 1997;Build 29
    3         ;External reference ^YSCL(603.01 supported by DBIA 2697
    4         ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
    5 HLP     W !,"Enter 'S' to process orders with a priority of STAT",!,"      'E' to process orders with an Emergency priority,",!,"      'R' to process Routine orders.",! Q
    6 HELP    ;
    7         W !,"Please enter a minimum of two (2) characters.",!,"Enter Patient's name whose med orders are to be completed.",!
    8         S (PATN,DPT)=0 F  S DPT=$O(^PS(52.41,"AOR",DPT)) Q:'DPT  I $D(^PS(52.41,"AOR",DPT,PSOPINST)) W !,$P(^DPT(DPT,0),"^") S PATN=PATN+1 I PATN=20 D  I $D(DUOUT)!($D(DTOUT)) G HELPX
    9         .K DIR,DUOUT,DTOUT,DIRUT S DIR(0)="E" D ^DIR S PATN=0 K DIR
    10 HELPX   K DTOUT,DUOUT,DIRUT,PAINST S DIR(0)="FO^2:30",DIR("A")="Select Patient",DIR("?")="^D HELP^PSOORFIN"
    11         K PATN,DPT Q
    12 RTE     ;
    13         S PSZFIN=1
    14         F PSZFZZ=0:0 S PSZFZZ=$O(^PS(52.41,"AC",PAT,$E(PSRT),PSZFZZ)) Q:'PSZFZZ!('PSZFIN)  D
    15         .I $P($G(^PS(52.41,PSZFZZ,0)),"^",3)="NW"!($P($G(^(0)),"^",3)="RNW")!($P($G(^(0)),"^",3)="RF") I $P($G(^PS(52.41,PSZFZZ,"INI")),"^")=$G(PSOPINST) S PSZFIN=0
    16         Q
    17 PRI     ;
    18         S PSZFIN=1
    19         F PSZFZZ=0:0 S PSZFZZ=$O(^PS(52.41,"AP",PAT,$E(PSRT),PSZFZZ)) Q:'PSZFZZ!('PSZFIN)  D
    20         .I $P($G(^PS(52.41,PSZFZZ,0)),"^",3)="NW"!($P($G(^(0)),"^",3)="RNW")!($P($G(^(0)),"^",3)="RF") I $P($G(^PS(52.41,PSZFZZ,"INI")),"^")=$G(PSOPINST) S PSZFIN=0
    21         Q
    22 PROFILE ;display med profile
    23         S MEDA=3 ;3=question asked already
    24         W !!! K MEDP,DIR,DUOUT,DIRUT,DTOUT S DIR(0)="Y",DIR("B")="Yes",DIR("A")="Do you want to see Medication Profile" D ^DIR K DIR Q:$D(DIRUT)!('Y)
    25         I Y S MEDP=1
    26         K DIR,DUOUT,DIRUT,DTOUT
    27         Q
    28 DC      I '$G(PSOORRNW),$G(PSOOPT)=3 S PSORENW("DFLG")=1 S:'$D(PSOBBC1("FROM")) VALMBCK="Q",VALMSG="Renew Rx Request Canceled.",Y=-1 Q
    29         G DC^PSOORFI6
    30         Q
    31 DE      Q:'$D(^PS(52.41,ORD,0))
    32         K ^PS(52.41,"AOR",$P(^PS(52.41,ORD,0),"^",2),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD),^PS(52.41,"AD",$P(^PS(52.41,ORD,0),"^",12),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD)
    33         S $P(^PS(52.41,ORD,0),"^",3)="DC",POERR("PLACER")=$P(^(0),"^"),POERR("STAT")="OC"
    34         S POERR("COMM")=$S($G(POERR("DEAD")):"Patient died on "_$G(PSOPTPST(2,PSODFN,.351))_".",1:ACOM),$P(^PS(52.41,ORD,4),"^")=POERR("COMM")
    35         D EN^PSOHLSN(POERR("PLACER"),POERR("STAT"),POERR("COMM"),PSONOOR)
    36         I '$G(POERR("DEAD")) S DIR("A")="Press Return to Continue" D PAUSE^VALM1
    37         K PSONOOR,PDORUG,ACOM,CMOP,DEA,DEF,DREN,FDR,HDR,PHI,PRC,SIGOK,DIR,DTOUT,DUOUT,DIRUT
    38         S Y=-1 Q
    39         ;
    40 RF      ;process refill request from CPRS
    41         S PSOREF("IRXN")=$P(OR0,"^",19) D PSOL^PSSLOCK($P(OR0,"^",19)) I '$G(PSOMSG) D  D PAUSE^VALM1 K PSOREF,PSOMSG Q
    42         .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P(PSOMSG,"^",2),! Q
    43         .W $C(7),!!,"Another person is editing Rx "_$P(^PSRX($P(OR0,"^",19),0),"^"),!
    44         ;
    45         D FULL^VALM1
    46         I '$P($G(^PS(52.41,ORD,0)),"^",23),+$G(^PS(52.41,ORD,"FLG")) D  I $D(DIRUT)!'Y S VALMBCK="B" Q
    47         . K DIRUT,DUOUT,DTOUT,DIR
    48         . S DIR("A",1)="Flagged by "_$$GET1^DIQ(52.41,ORD,34)_" on "_$$GET1^DIQ(52.41,ORD,33)_": "_$$GET1^DIQ(52.41,ORD,35)
    49         . S DIR("A",2)=""
    50         . S DIR("A",3)="Unflagged by "_$$GET1^DIQ(52.41,ORD,37)_" on "_$$GET1^DIQ(52.41,ORD,36)_": "_$$GET1^DIQ(52.41,ORD,38)
    51         . S DIR("A",4)=""
    52         . S DIR(0)="Y",DIR("B")="YES",DIR("A")="Continue"
    53         . W ! D ^DIR
    54         ;
    55         I $G(ORD),+$P($G(^PS(52.41,+ORD,0)),"^",23)=1 D  Q:$D(DIRUT)!'Y  D EN1^ORCFLAG(+$P($G(^PS(52.41,ORD,0)),"^")) H 1
    56         . K DIRUT,DUOUT,DTOUT,DIR
    57         . S DIR("A",1)="This Refill Request is flagged. In order to process it"
    58         . S DIR("A",2)="you must unflag it first."
    59         . S DIR("A",3)=""
    60         . S DIR(0)="Y",DIR("A")="Unflag Refill Request",DIR("B")="NO"
    61         . W ! D ^DIR I $D(DIRUT)!'Y S VALMBCK="B"
    62         I $G(ORD),+$P($G(^PS(52.41,+ORD,0)),"^",23)=1 Q
    63         ;
    64         K PSOMSG S (PSOREF("DFLG"),PSOREF("FIELD"),PSOREF1)=0,X="T-6M",%DT="X" D ^%DT
    65         S (PSOID,PSOREF("ISSUE DATE"))=$S($P(^PSRX(PSOREF("IRXN"),0),"^",13)<Y:Y,1:$P(^PSRX(PSOREF("IRXN"),0),"^",13))
    66         S:$G(PSORX("BAR CODE"))&($G(PSOBBC1("FROM"))="NEW") PSOREF("ISSUE DATE")=DT K X,X1,X2
    67         ;
    68         S PSONEW("DAYS SUPPLY")=$P(^PSRX(PSOREF("IRXN"),0),"^",8),PSONEW("# OF REFILLS")=$P(^(0),"^",9)
    69         W !!,"Processing Refill Request for Rx "_$P(^PSRX(PSOREF("IRXN"),0),"^")
    70         ;S:$G(PSOREQFD)]"" PSORX("FILL DATE")=PSOREQFD
    71         D FILLDT^PSODIR2(.PSOREF) I PSOREF("DFLG") S VALMBCK="R" G END
    72         ;S:$G(PSORX("FILL DATE"))]"" PSOREQFD=PSORX("FILL DATE")
    73         ;
    74         ;S:$G(PSOREQMP)]"" PSORX(" METHOD OF PICK-UP")=PSOREQMP
    75         S PSORX("MAIL/WINDOW")=$S($P(OR0,"^",17)="M":"MAIL",1:"WINDOW") D MW^PSODIR2(.PSOREF) I PSOREF("DFLG") S VALMBCK="R" G END
    76         ;S:$G(PSORX("METHOD OF PICK-UP"))]"" PSOREQMP=PSORX("METHOD OF PICK-UP")
    77         S:'$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0
    78         D ^PSOREF0
    79 END     D PSOUL^PSSLOCK(PSOREF("IRXN")) K PSOREF,NODE,PSOREF1,PSL,PSOERR,PSORX("QFLG")
    80         Q
    81 S       D KPRI,KPRIZ F  S ORD=$O(^PS(52.41,"AP",PAT,"S",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN S PSOSTATZ=1
    82         D:$G(POERR("QFLG")) KPRI Q:$G(POERR("QFLG"))  I $G(PSOSTATZ) S ORD=0 D
    83         .D KPRIZ F  S ORD=$O(^PS(52.41,"AP",PAT,"E",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN
    84         .Q:$G(POERR("QFLG"))
    85         .D KPRIZ S ORD=0 F  S ORD=$O(^PS(52.41,"AP",PAT,"R",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN
    86         D KPRI
    87         Q
    88 E       D KPRI,KPRIZ F  S ORD=$O(^PS(52.41,"AP",PAT,"E",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN S PSOEMERZ=1
    89         D:$G(POERR("QFLG")) KPRI Q:$G(POERR("QFLG"))  I $G(PSOEMERZ) S ORD=0 D
    90         .D KPRIZ F  S ORD=$O(^PS(52.41,"AP",PAT,"S",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN
    91         .Q:$G(POERR("QFLG"))
    92         .D KPRIZ S ORD=0 F  S ORD=$O(^PS(52.41,"AP",PAT,"R",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN
    93         D KPRI
    94         Q
    95 R       D KPRI,KPRIZ F  S ORD=$O(^PS(52.41,"AP",PAT,"R",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN S PSOROUTZ=1
    96         D:$G(POERR("QFLG")) KPRI Q:$G(POERR("QFLG"))  I $G(PSOROUTZ) S ORD=0 D
    97         .D KPRIZ F  S ORD=$O(^PS(52.41,"AP",PAT,"E",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN
    98         .Q:$G(POERR("QFLG"))
    99         .D KPRIZ S ORD=0 F  S ORD=$O(^PS(52.41,"AP",PAT,"S",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN
    100         D KPRI
    101         Q
    102 KPRI    K PSOSTATZ,PSOROUTZ,PSOEMERZ
    103         Q
    104 KPRIZ   K PSOQUIT,POERR("QFLG")
    105         Q
    106 INST    ;Select Institution
    107         N PSOCNT
    108         I '$G(PSOSITE) D ^PSOLSET I '$G(PSOSITE) S PSOIQUIT=1 Q
    109         N PSIR,PSCT,PSINST K PSOPINST
    110         S PSCT=0 F PSIR=0:0 S PSIR=$O(^PS(59,PSOSITE,"INI1",PSIR)) Q:'PSIR  I $P($G(^PS(59,PSOSITE,"INI1",PSIR,0)),"^") S PSCT=PSCT+1 I PSCT=1 S PSOPINST=$P($G(^(0)),"^")
    111         I PSCT=0 W !!,"There are no CPRS Ordering Institutions associated with this Outpatient site!",!,"Use the Site Parameter enter/edit option to enter CPRS Ordering Institutions!",! S PSOIQUIT=1 Q
    112         I PSCT=1 Q
    113         W !!!,"There are multiple Institutions associated with this Outpatient Site for",!,"finishing orders entered through CPRS. Select the Institution for which to",!,"finish orders from.  Enter '?' to see all choices.",!
    114         K PSOPNAME D:$G(PSOPINST)  K DIC S DIC(0)="AEQMZ",DIC="^PS(59,"_PSOSITE_",""INI1""," S:$G(PSOPNAME)'="" DIC("B")=$G(PSOPNAME) D ^DIC K DIC,PSOPNAME I Y<1 W !!,"No Institution selected",! S PSOIQUIT=1 Q
    115         .K ^UTILITY("DIQ1",$J),DIQ S DA=$G(PSOPINST),DIC=4,DIQ(0)="E",DR=".01" D EN^DIQ1 S PSOPNAME=$G(^UTILITY("DIQ1",$J,4,DA,.01,"E")) K ^UTILITY("DIQ1",$J),DA,DR,DIC,DIQ
    116         W ! S PSOPINST=$P(Y,"^",2) K Y
    117         D INSTNM W !,"You have selected "_$G(PSODINST)_"."
    118         W !,"After completing these orders, you may re-enter this option and select again.",!
    119         S PSOCNT=$$CNT(PSOPINST)
    120         W !,"      <There ",$S(PSOCNT=1:"is ",1:"are "),$S(PSOCNT>0:PSOCNT,1:"no")," flagged order",$S(PSOCNT=1:"",1:"s")," for ",PSODINST,">",!
    121         K PSODINST
    122         Q
    123         ;
    124 CNT(SITE)        ; - Counter for flagged pending orders by Site
    125         N CNT,ORD
    126         S (CNT,LOGIN,ORD)=0
    127         F  S LOGIN=$O(^PS(52.41,"AD",LOGIN)) Q:'LOGIN  D
    128         . F  S ORD=$O(^PS(52.41,"AD",LOGIN,SITE,ORD)) Q:'ORD  D
    129         . . I $P(^PS(52.41,ORD,0),"^",3)="DC"!($P(^PS(52.41,ORD,0),"^",3)="DE") Q
    130         . . I $P($G(^PS(52.41,ORD,0)),"^",23) S CNT=CNT+1
    131         Q CNT
    132         ;
    133 INST1   ;
    134         K PSOPINST N PSIR
    135         F PSIR=0:0 S PSIR=$O(^PS(59,PSOSITE,"INI1",PSIR)) Q:'PSIR!($G(PSOPINST))  I $P($G(^PS(59,PSOSITE,"INI1",PSIR,0)),"^") S PSOPINST=$P($G(^(0)),"^")
    136         Q
    137 CLOZ    ;checks clozapine status of patient
    138         S CLOZPAT=$O(^YSCL(603.01,"C",PSODFN,0))
    139         S CLOZPAT=$P($G(^YSCL(603.01,+CLOZPAT,0)),"^",3)
    140         S CLOZPAT=$S(CLOZPAT="M":2,CLOZPAT="B":1,1:0)
    141         S:'$D(PSONEW("# OF REFILLS")) (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0
    142         Q
    143 ELIG    I $G(CLOZPAT)=1 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="   Patient Eligible for 14 Day Supply or 7 Day Supply with 1 refill"
    144         I $G(CLOZPAT)=2 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="   Patient Eligible for 28 Day Supply or 14 Day Supply with 1 refill or 7 Day Supply with 3 refill"
    145         Q
    146 USER(USER)      ;returns .01 of 200
    147         K DIC,X,Y S DIC="^VA(200,",DIC(0)="M",X="`"_USER D ^DIC S USER1=$S(+Y:$P(Y,"^",2),1:"Unknown") K DIC,X,Y
    148         Q
    149 INSTNM  ;
    150         K PSOFINDA,PSODINST I $G(DA) S PSOFINDA=$G(DA)
    151         K PSODNM S DA=$G(PSOPINST) I DA S DIC=4,DIQ(0)="E",DR=".01",DIQ="PSODNM" D EN^DIQ1 S PSODINST=$G(PSODNM(4,DA,.01,"E")) K PSODNM,DIC,DR,DA
    152         I $G(PSOFINDA) S DA=$G(PSOFINDA) K PSOFINDA
    153         Q
    154 POST    S PSOFINY=$G(Y) D ^PSOBUILD S Y=$G(PSOFINY) K PSOFINY D OERR^PSORX1 I $G(PSOQUIT) Q
    155         K PSOQFLG F PT="GET","DEAD","INP","CNH","TPB","ADDRESS","COPAY" S RTN=PT_"^PSOPTPST" D @RTN K PSOXFLG Q:$G(POERR("DEAD"))!($G(PSOQFLG))
    156         I $G(POERR("DEAD")) S POERR("QFLG")=1 Q
    157         K PSOERR("DEAD") I $G(PSOQFLG) Q
    158         D ^PSOORUT2,BLD^PSOORUT1,EN^PSOLMUTL
    159         Q
    160 SIG     ;
    161         S SIG=0,PSOFINFL=1 F  S SIG=$O(^PS(52.41,ORD,"SIG",SIG)) Q:'SIG  D
    162         .S (MIG,SIG(SIG))=^PS(52.41,ORD,"SIG",SIG,0)
    163         .F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG) D
    164         ..I $E(^TMP("PSOPO",$J,IEN,0),$L(^TMP("PSOPO",$J,IEN,0)))=" " S ^TMP("PSOPO",$J,IEN,0)=$E(^TMP("PSOPO",$J,IEN,0),1,($L(^TMP("PSOPO",$J,IEN,0))-1))
    165         S:$O(SIG(0)) SIGOK=1 K MIG
    166         F D=0:0 S D=$O(^PS(52.41,ORD,"INS1",D)) Q:'D  S PSONEW("INS",D)=^PS(52.41,ORD,"INS1",D,0)
    167         ;I PSONEW("INS")]"" S X=PSONEW("INS") D SIG^PSOHELP I $G(INS1)]"" S PSONEW("SIG")=$E(INS1,2,9999999)
    168         Q
     1PSOORFI2 ;BIR/BHW-finish cprs orders cont. ;1/27/07  13:25
     2 ;;7.0;OUTPATIENT PHARMACY;**7,15,23,27,46,130,146,177,222,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; GPL Copyright (C) 2007 WorldVistA
     5 ;Ext ref ^YSCL(603.01 supported by DBIA 2697
     6 ;Ext refs PSOL and PSOUL^PSSLOCK supported by DBIA 2789
     7HLP W !,"Enter 'S' to process orders with a priority of STAT",!,"      'E' to process orders with an Emergency priority,",!,"      'R' to process Routine orders.",! Q
     8HELP ;
     9 W !,"Please enter a minimum of two (2) characters.",!,"Enter Patient's name whose med orders are to be completed.",!
     10 S (PATN,DPT)=0 F  S DPT=$O(^PS(52.41,"AOR",DPT)) Q:'DPT  I $D(^PS(52.41,"AOR",DPT,PSOPINST)) W !,$P(^DPT(DPT,0),"^") S PATN=PATN+1 I PATN=20 D  I $D(DUOUT)!($D(DTOUT)) G HELPX
     11 .K DIR,DUOUT,DTOUT,DIRUT S DIR(0)="E" D ^DIR S PATN=0 K DIR
     12HELPX K DTOUT,DUOUT,DIRUT,PAINST S DIR(0)="FO^2:30",DIR("A")="Select Patient",DIR("?")="^D HELP^PSOORFIN"
     13 K PATN,DPT Q
     14RTE ;
     15 S PSZFIN=1
     16 F PSZFZZ=0:0 S PSZFZZ=$O(^PS(52.41,"AC",PAT,$E(PSRT),PSZFZZ)) Q:'PSZFZZ!('PSZFIN)  D
     17 .I $P($G(^PS(52.41,PSZFZZ,0)),"^",3)="NW"!($P($G(^(0)),"^",3)="RNW")!($P($G(^(0)),"^",3)="RF") I $P($G(^PS(52.41,PSZFZZ,"INI")),"^")=$G(PSOPINST) S PSZFIN=0
     18 Q
     19PRI ;
     20 S PSZFIN=1
     21 F PSZFZZ=0:0 S PSZFZZ=$O(^PS(52.41,"AP",PAT,$E(PSRT),PSZFZZ)) Q:'PSZFZZ!('PSZFIN)  D
     22 .I $P($G(^PS(52.41,PSZFZZ,0)),"^",3)="NW"!($P($G(^(0)),"^",3)="RNW")!($P($G(^(0)),"^",3)="RF") I $P($G(^PS(52.41,PSZFZZ,"INI")),"^")=$G(PSOPINST) S PSZFIN=0
     23 Q
     24PROFILE ;
     25 S MEDA=3
     26 I $G(PSOAFYN)'="Y" W !!! K MEDP,DIR,DUOUT,DIRUT,DTOUT S DIR(0)="Y",DIR("B")="Yes",DIR("A")="Do you want to see Medication Profile" D ^DIR K DIR Q:$D(DIRUT)!('Y)
     27 I $G(PSOAFYN)'="Y" I Y S MEDP=1
     28 I $G(PSOAFYN)="Y" K MEDP
     29 K DIR,DUOUT,DIRUT,DTOUT
     30 Q
     31DC I '$G(PSOORRNW),$G(PSOOPT)=3 S PSORENW("DFLG")=1 S:'$D(PSOBBC1("FROM")) VALMBCK="Q",VALMSG="Renew Rx Request Canceled.",Y=-1 Q
     32 I $G(PSOAFYN)'="Y" N VALMCNT W ! K DIR,DUOUT,DIROUT,DTOUT,PSOELSE I '$G(PSOERR("DEAD")) S PSOELSE=1 D  Q:$D(DIRUT)
     33 .D NOOR^PSOCAN4 Q:$D(DIRUT)
     34 .S DIR("A")="Comments",DIR(0)="F^10:75",DIR("B")="Per Pharmacy Request" D ^DIR K DIR
     35 I $G(PSOAFYN)="Y" N VALMCNT K DIR,DUOUT,DIROUT,DTOUT,PSOELSE I '$G(PSOERR("DEAD")) S PSOELSE=1 D  Q:$D(DIRUT)  ;vfah
     36 .D NOOR^PSOCAN4 Q:$D(DIRUT)  ;vfah
     37 .S Y="Rx AutoFinish" ;vfah
     38 I $G(PSOAFYN)'="Y" S PSOELSE="1"
     39 I '$G(PSOELSE) K PSOELSE S PSONOOR="A" G DE
     40 K PSOELSE I $D(DIRUT) K DIRUT,DUOUT,DTOUT,Y Q
     41 S ACOM=Y
     42DE I $G(PSOAFYN)="Y" Q
     43 I $G(PSOAFYN)'="Y" Q:'$D(^PS(52.41,ORD,0))
     44 K ^PS(52.41,"AOR",$P(^PS(52.41,ORD,0),"^",2),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD),^PS(52.41,"AD",$P(^PS(52.41,ORD,0),"^",12),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD)
     45 S $P(^PS(52.41,ORD,0),"^",3)="DC",POERR("PLACER")=$P(^(0),"^"),POERR("STAT")="OC"
     46 S POERR("COMM")=$S($G(POERR("DEAD")):"Patient died on "_$G(PSOPTPST(2,PSODFN,.351))_".",1:ACOM),$P(^PS(52.41,ORD,4),"^")=POERR("COMM")
     47 D EN^PSOHLSN(POERR("PLACER"),POERR("STAT"),POERR("COMM"),PSONOOR)
     48 I '$G(POERR("DEAD")) S DIR("A")="Press Return to Continue" D PAUSE^VALM1
     49 K PSONOOR,PDORUG,ACOM,CMOP,DEA,DEF,DREN,FDR,HDR,PHI,PRC,SIGOK,DIR,DTOUT,DUOUT,DIRUT
     50 S Y=-1 Q
     51 ;
     52RF ;
     53 S PSOREF("IRXN")=$P(OR0,"^",19) D PSOL^PSSLOCK($P(OR0,"^",19)) I '$G(PSOMSG) D  D PAUSE^VALM1 K PSOREF,PSOMSG Q
     54 .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P(PSOMSG,"^",2),! Q
     55 .W $C(7),!!,"Another person is editing Rx "_$P(^PSRX($P(OR0,"^",19),0),"^"),!
     56 K PSOMSG S (PSOREF("DFLG"),PSOREF("FIELD"),PSOREF1)=0,X="T-6M",%DT="X" D ^%DT
     57 S (PSOID,PSOREF("ISSUE DATE"))=$S($P(^PSRX(PSOREF("IRXN"),0),"^",13)<Y:Y,1:$P(^PSRX(PSOREF("IRXN"),0),"^",13))
     58 S:$G(PSORX("BAR CODE"))&($G(PSOBBC1("FROM"))="NEW") PSOREF("ISSUE DATE")=DT K X,X1,X2
     59 ;
     60 S PSONEW("DAYS SUPPLY")=$P(^PSRX(PSOREF("IRXN"),0),"^",8),PSONEW("# OF REFILLS")=$P(^(0),"^",9) D FULL^VALM1
     61 W !!,"Processing Refill Request for Rx "_$P(^PSRX(PSOREF("IRXN"),0),"^")
     62 D FILLDT^PSODIR2(.PSOREF) I PSOREF("DFLG") S VALMBCK="R" G END
     63 ;
     64 S PSORX("MAIL/WINDOW")=$S($P(OR0,"^",17)="M":"MAIL",1:"WINDOW") D MW^PSODIR2(.PSOREF) I PSOREF("DFLG") S VALMBCK="R" G END
     65 S:'$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0
     66 D ^PSOREF0
     67END D PSOUL^PSSLOCK(PSOREF("IRXN")) K PSOREF,NODE,PSOREF1,PSL,PSOERR,PSORX("QFLG")
     68 Q
     69S D KPRI,KPRIZ F  S ORD=$O(^PS(52.41,"AP",PAT,"S",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN S PSOSTATZ=1
     70 D:$G(POERR("QFLG")) KPRI Q:$G(POERR("QFLG"))  I $G(PSOSTATZ) S ORD=0 D
     71 .D KPRIZ F  S ORD=$O(^PS(52.41,"AP",PAT,"E",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN
     72 .Q:$G(POERR("QFLG"))
     73 .D KPRIZ S ORD=0 F  S ORD=$O(^PS(52.41,"AP",PAT,"R",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN
     74 D KPRI
     75 Q
     76E D KPRI,KPRIZ F  S ORD=$O(^PS(52.41,"AP",PAT,"E",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN S PSOEMERZ=1
     77 D:$G(POERR("QFLG")) KPRI Q:$G(POERR("QFLG"))  I $G(PSOEMERZ) S ORD=0 D
     78 .D KPRIZ F  S ORD=$O(^PS(52.41,"AP",PAT,"S",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN
     79 .Q:$G(POERR("QFLG"))
     80 .D KPRIZ S ORD=0 F  S ORD=$O(^PS(52.41,"AP",PAT,"R",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN
     81 D KPRI
     82 Q
     83R D KPRI,KPRIZ F  S ORD=$O(^PS(52.41,"AP",PAT,"R",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN S PSOROUTZ=1
     84 D:$G(POERR("QFLG")) KPRI Q:$G(POERR("QFLG"))  I $G(PSOROUTZ) S ORD=0 D
     85 .D KPRIZ F  S ORD=$O(^PS(52.41,"AP",PAT,"E",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN
     86 .Q:$G(POERR("QFLG"))
     87 .D KPRIZ S ORD=0 F  S ORD=$O(^PS(52.41,"AP",PAT,"S",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN
     88 D KPRI
     89 Q
     90KPRI K PSOSTATZ,PSOROUTZ,PSOEMERZ
     91 Q
     92KPRIZ K PSOQUIT,POERR("QFLG")
     93 Q
     94INST ;
     95 I '$G(PSOSITE) D ^PSOLSET I '$G(PSOSITE) S PSOIQUIT=1 Q
     96 N PSIR,PSCT,PSINST K PSOPINST
     97 I $G(PSOAFYN)="Y" S PSCT=1,PSOPINST=+ORL ;vfah selects CPRS Ordering Institution if autofinishing and non-interactive
     98 I $G(PSOAFYN)'="Y" S PSCT=0 F PSIR=0:0 S PSIR=$O(^PS(59,PSOSITE,"INI1",PSIR)) Q:'PSIR  I $P($G(^PS(59,PSOSITE,"INI1",PSIR,0)),"^") S PSCT=PSCT+1 I PSCT=1 S PSOPINST=$P($G(^(0)),"^") ;vfah
     99 I PSCT=0 W !!,"There are no CPRS Ordering Institutions associated with this Outpatient site!",!,"Use the Site Parameter enter/edit option to enter CPRS Ordering Institutions!",! S PSOIQUIT=1 Q
     100 I PSCT=1 Q
     101 W !!!,"There are multiple Institutions associated with this Outpatient Site for",!,"finishing orders entered through CPRS. Select the Institution for which to",!,"finish orders from.  Enter '?' to see all choices.",!
     102 K PSOPNAME D:$G(PSOPINST)  K DIC S DIC(0)="AEQMZ",DIC="^PS(59,"_PSOSITE_",""INI1""," S:$G(PSOPNAME)'="" DIC("B")=$G(PSOPNAME) D ^DIC K DIC,PSOPNAME I Y<1 W !!,"No Institution selected",! S PSOIQUIT=1 Q
     103 .K ^UTILITY("DIQ1",$J),DIQ S DA=$G(PSOPINST),DIC=4,DIQ(0)="E",DR=".01" D EN^DIQ1 S PSOPNAME=$G(^UTILITY("DIQ1",$J,4,DA,.01,"E")) K ^UTILITY("DIQ1",$J),DA,DR,DIC,DIQ
     104 W ! S PSOPINST=$P(Y,"^",2) K Y
     105 D INSTNM W !,"You have selected "_$G(PSODINST)_".",!,"After completing these orders, you may re-enter this option and select again.",! K PSODINST
     106 Q
     107INST1 ;
     108 K PSOPINST N PSIR
     109 F PSIR=0:0 S PSIR=$O(^PS(59,PSOSITE,"INI1",PSIR)) Q:'PSIR!($G(PSOPINST))  I $P($G(^PS(59,PSOSITE,"INI1",PSIR,0)),"^") S PSOPINST=$P($G(^(0)),"^")
     110 Q
     111CLOZ ;
     112 S CLOZPAT=$O(^YSCL(603.01,"C",PSODFN,0))
     113 S CLOZPAT=$P($G(^YSCL(603.01,+CLOZPAT,0)),"^",3)
     114 S CLOZPAT=$S(CLOZPAT="M":2,CLOZPAT="B":1,1:0)
     115 S:'$D(PSONEW("# OF REFILLS")) (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0
     116 Q
     117ELIG I $G(CLOZPAT)=1 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="   Patient Eligible for 14 Day Supply or 7 Day Supply with 1 refill"
     118 I $G(CLOZPAT)=2 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="   Patient Eligible for 28 Day Supply or 14 Day Supply with 1 refill or 7 Day Supply with 3 refill"
     119 Q
     120USER(USER) ;
     121 K DIC,X,Y S DIC="^VA(200,",DIC(0)="M",X="`"_USER D ^DIC S USER1=$S(+Y:$P(Y,"^",2),1:"Unknown") K DIC,X,Y
     122 Q
     123INSTNM ;
     124 K PSOFINDA,PSODINST I $G(DA) S PSOFINDA=$G(DA)
     125 K PSODNM S DA=$G(PSOPINST) I DA S DIC=4,DIQ(0)="E",DR=".01",DIQ="PSODNM" D EN^DIQ1 S PSODINST=$G(PSODNM(4,DA,.01,"E")) K PSODNM,DIC,DR,DA
     126 I $G(PSOFINDA) S DA=$G(PSOFINDA) K PSOFINDA
     127 Q
     128POST S PSOFINY=$G(Y) D ^PSOBUILD S Y=$G(PSOFINY) K PSOFINY D OERR^PSORX1 I $G(PSOQUIT) Q
     129 K PSOQFLG F PT="GET","DEAD","INP","CNH","TPB","ADDRESS","COPAY" S RTN=PT_"^PSOPTPST" D @RTN K PSOXFLG Q:$G(POERR("DEAD"))!($G(PSOQFLG))
     130 I $G(POERR("DEAD")) S POERR("QFLG")=1 Q
     131 K PSOERR("DEAD") I $G(PSOQFLG) Q
     132 D ^PSOORUT2,BLD^PSOORUT1,EN^PSOLMUTL
     133 Q
     134SIG ;
     135 S SIG=0,PSOFINFL=1 F  S SIG=$O(^PS(52.41,ORD,"SIG",SIG)) Q:'SIG  D
     136 .S (MIG,SIG(SIG))=^PS(52.41,ORD,"SIG",SIG,0)
     137 .F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG) D
     138 ..I $E(^TMP("PSOPO",$J,IEN,0),$L(^TMP("PSOPO",$J,IEN,0)))=" " S ^TMP("PSOPO",$J,IEN,0)=$E(^TMP("PSOPO",$J,IEN,0),1,($L(^TMP("PSOPO",$J,IEN,0))-1))
     139 S:$O(SIG(0)) SIGOK=1 K MIG
     140 F D=0:0 S D=$O(^PS(52.41,ORD,"INS1",D)) Q:'D  S PSONEW("INS",D)=^PS(52.41,ORD,"INS1",D,0)
     141 ;I PSONEW("INS")]"" S X=PSONEW("INS") D SIG^PSOHELP I $G(INS1)]"" S PSONEW("SIG")=$E(INS1,2,9999999)
     142 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI3.m

    r613 r623  
    1 PSOORFI3        ;BIR/RTR-finish CPRS orders by Clinic ;11/09/98
    2         ;;7.0;OUTPATIENT PHARMACY;**15,27,32,46,84,99,130,117,139,172,225**;DEC 1997;Build 29
    3         ;PPPPDA1-1374,SC(-2675,40.8-728,51.2-2226,50.607-2221,55-2228,PSSLOCK-2789,DPT-10035,ORX2-867
    4         ;
    5         K ^TMP($J,"PSOCL"),^TMP($J,"PSOCLX"),PSOCLIN,PSOCLINF,PSOXINST
    6         N PSOCFLAG,PSONPTRX,PSOINPTR,PSCLP,PSOCLINS,PSOSTC,PSOLGD,PSODIEN,PSOCTMP
    7         K DIR S DIR(0)="SMB^C:CLINIC;S:SORT GROUP;E:EXIT",DIR("A")="Select By",DIR("B")="Clinic",DIR("?",1)="Enter 'C' to process orders for one individual Clinic,"
    8         S DIR("?",2)="      'S' to process orders for all Clinics associated with a Sort Group,",DIR("?",3)="      '^' or 'E' to exit" S DIR("?")=" "
    9         W ! D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!(Y="E") W ! G EXIT
    10         I Y="S" G SORT
    11 CLIN    W ! K DIC S DIC="^SC(",DIC(0)="QEAMZ",DIC("A")="Select CLINIC: " D ^DIC K DIC I Y<1!($D(DTOUT))!($D(DUOUT)) G EXIT
    12         S PSOCLIN=+Y,PSOCLINF=1 D CHECK I $G(PSOCFLAG) D INSTNM^PSOORFI2 W !!,"You are signed in under the "_$G(PSODINST)_" CPRS Ordering",!,"Institution, which does not match the Institution for this Clinic!",! K PSODINST G CLIN
    13         S ^TMP($J,"PSOCL",PSOCLIN)=PSOCLIN K PSOCLIN G START
    14 SORT    W ! K DIC S DIC="^PS(59.8,",DIC(0)="QEAMZ",DIC("A")="Select CLINIC SORT GROUP: " D ^DIC K DIC I Y<1!($D(DTOUT))!($D(DUOUT)) G EXIT
    15         S PSOCLINS=+Y
    16         K ^TMP($J,"PSOCL"),^TMP($J,"PSOCLX") F PSCLP=0:0 S PSCLP=$O(^PS(59.8,PSOCLINS,1,PSCLP)) Q:'PSCLP  S PSOSTC=+$P($G(^PS(59.8,PSOCLINS,1,PSCLP,0)),"^") S:$G(PSOSTC)&($D(^SC(PSOSTC,0))) ^TMP($J,"PSOCL",PSOSTC)=PSOSTC
    17         I '$O(^TMP($J,"PSOCL",0)) W !!,"There are no Clinics associated with this Sort Group!",! K ^TMP($J,"PSOCL") G SORT
    18         F PSCLP=0:0 S PSCLP=$O(^TMP($J,"PSOCL",PSCLP)) Q:'PSCLP  S PSOCLIN=PSCLP D CHECK I $G(PSOCFLAG) S ^TMP($J,"PSOCLX",PSCLP)=PSCLP K ^TMP($J,"PSOCL",PSCLP)
    19         I $O(^TMP($J,"PSOCLX",0)) H 1 W @IOF W !,"Orders for these Clinics in the Sort Group will not be displayed for Finishing",!,"because the CPRS Ordering Institution does not match the Institution that is",!,"associated with the Clinic:",! D
    20         .F PSCLP=0:0 S PSCLP=$O(^TMP($J,"PSOCLX",PSCLP)) Q:'PSCLP  D:($Y+4)>IOSL  W !,$P($G(^SC(PSCLP,0)),"^")
    21         ..W ! K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR W @IOF
    22         I $O(^TMP($J,"PSOCLX",0)) D EOP
    23         K ^TMP($J,"PSOCLX") I '$O(^TMP($J,"PSOCL",0)) W !!,"There are no Clinics that have a matching Institution!",! D EOP G SORT
    24         ;
    25         S PSOCLINF=2
    26 START   K MEDP,MEDA,PSOQUIT,POERR("QFLG"),POERR("DFLG"),DIR
    27         G:'$O(^TMP($J,"PSOCL",0)) EXIT
    28         S PATA=0 F PSOCLIN=0:0 S PSOCLIN=$O(^TMP($J,"PSOCL",PSOCLIN)) Q:'PSOCLIN!($G(POERR("QFLG")))  F PSOLGD=0:0 S PSOLGD=$O(^PS(52.41,"ACL",PSOCLIN,PSOLGD)) Q:'PSOLGD!($G(POERR("QFLG")))  D
    29         .F PSODIEN=0:0 S PSODIEN=$O(^PS(52.41,"ACL",PSOCLIN,PSOLGD,PSODIEN)) Q:'PSODIEN!($G(POERR("QFLG")))  D
    30         ..I $P($G(^PS(52.41,PSODIEN,0)),"^",3)'="NW",$P($G(^(0)),"^",3)'="RNW",$P($G(^(0)),"^",3)'="RF" Q
    31         ..I $G(PSOPINST)'=$P($G(^PS(52.41,PSODIEN,"INI")),"^") Q
    32         ..Q:$G(PAT($P(^PS(52.41,PSODIEN,0),"^",2)))=$P(^PS(52.41,PSODIEN,0),"^",2)  S PAT=$P(^PS(52.41,PSODIEN,0),"^",2)
    33         ..I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
    34         ..D LK^PSOORFIN I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
    35         ..I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP^PSOORFIN Q
    36         ..S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(+$G(PAT),0)),"^"),PATA=PAT
    37         ..D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) K PSOFIN S POERR("QFLG")=0 S PSONOLCK=1,PSOPTLOK=PAT D OERR^PSORX1 S PSOFIN=1 D QU^PSOORFIN S X=PSOPTLOK D KLLP^PSOORFIN,ULP^PSOORFIN,KLL^PSOORFIN Q
    38         ..D SDFN^PSOORFIN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP^PSOORFIN K PSOQFLG Q
    39         ..S PAT(PAT)=PAT
    40         ..F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG")))  I '$P($G(^PS(52.41,ORD,0)),"^",23) D
    41         ...S PSODFN=PAT D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2),X="PPPPDA1" X ^%ZOSF("TEST") S:$T X=$$PDA^PPPPDA1(PSODFN)
    42         ...D LK1^PSOORFIN,ORD^PSOORFIN S X=PAT D ULP^PSOORFIN
    43         I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
    44         ;
    45 EXIT    K ^TMP($J,"PSOCL"),^TMP($J,"PSOCLX"),PSOCLIN,PSOCLINF,PSOXINST G EX^PSOORFIN
    46         Q
    47 CHECK   ; check Institution
    48         K PSOXINST,PSOCFLAG
    49         I $P($G(^SC(PSOCLIN,0)),"^",4),$P($G(^(0)),"^",4)'=$G(PSOPINST) S PSOCFLAG=1 Q
    50         I $P($G(^SC(PSOCLIN,0)),"^",4) Q
    51         S PSONPTRX=$P($G(^SC(PSOCLIN,0)),"^",15)
    52         I '$G(PSONPTRX) S PSONPTRX=$O(^DG(40.8,0))
    53         I '$G(DT) S DT=$$DT^XLFDT
    54         S PSOINPTR=+$$SITE^VASITE(DT,PSONPTRX) I PSOINPTR'=$G(PSOPINST) S PSOCFLAG=1
    55         Q
    56 EOP     W ! K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR
    57         Q
    58 L1      ;Lock single order
    59         I '$G(ORD) Q
    60         K PSOMSG D PSOL^PSSLOCK(+ORD_"S") I '$G(PSOMSG) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"This Order is being edited by another person."),! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
    61         Q
    62 UL1     ;Unlock single order
    63         I '$G(ORD) Q
    64         I '$D(^PS(52.41,ORD,0)) D  Q
    65         . D UNLK1^ORX2(+$G(OR0))
    66         . Q
    67         D PSOUL^PSSLOCK(+ORD_"S")
    68         Q
    69 DOSE    ;pending orders
    70         K DOENT S DS=1
    71         F I=0:0 S I=$O(^PS(52.41,ORD,1,I)) Q:'I  S DOSE=$G(^PS(52.41,ORD,1,I,1)),DOSE1=$G(^(2)) D  D DOSE1
    72         .S PSONEW("DOSE",I)=$P(DOSE1,"^"),PSONEW("DOSE ORDERED",I)=$P(DOSE1,"^",2),PSONEW("UNITS",I)=$P(DOSE,"^",9),PSONEW("NOUN",I)=$P(DOSE,"^",5)
    73         .S:$P(DOSE,"^",9) UNITS=$P(^PS(50.607,$P(DOSE,"^",9),0),"^")
    74         .S PSONEW("VERB",I)=$P(DOSE,"^",10),PSONEW("ROUTE",I)=$P(DOSE,"^",8)
    75         .S:$P(DOSE,"^",8) ROUTE=$P(^PS(51.2,$P(DOSE,"^",8),0),"^")
    76         .S PSONEW("SCHEDULE",I)=$P(DOSE,"^"),PSONEW("DURATION",I)=$P(DOSE,"^",2)
    77         .S DOENT=$G(DOENT)+1 S PSONEW("CONJUNCTION",I)=$S($P(DOSE,"^",6)="A":"AND",$P(DOSE,"^",6)="S":"THEN",$P(DOSE,"^",6)="X":"EXCEPT",1:"")
    78         .I 'PSONEW("DOSE ORDERED",I),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Verb: "_$G(PSONEW("VERB",I))
    79         .S:$G(DS) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)"
    80         S PSONEW("ENT")=DOENT K DOSE,DOSE1,I,UNITS,ROUTE,DOENT
    81         Q
    82 DOSE1   I $G(DS)=1 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"        *Dosage:" D FMD G DU
    83         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="            *Dosage:" D FMD
    84 DU      I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I))
    85         I PSONEW("DOSE ORDERED",I),$G(PSONEW("VERB",I))]"" D
    86         .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Verb: "_$G(PSONEW("VERB",I))
    87         .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     Dispense Units: "_$S($E(PSONEW("DOSE ORDERED",I),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",I)
    88         I PSONEW("NOUN",I) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Noun: "_PSONEW("NOUN",I)
    89         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="             *Route: "_$G(ROUTE)
    90         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          *Schedule: "_PSONEW("SCHEDULE",I)
    91         I $P(DOSE,"^",2)]"" D
    92         .S DUR=$S($E($P(DOSE,"^",2),1)'?.N:$E($P(DOSE,"^",2),2,99)_$E($P(DOSE,"^",2),1),1:$P(DOSE,"^",2))
    93         .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          *Duration: "_DUR_" ("_$S($P(DOSE,"^",2)["M":"MINUTES",$P(DOSE,"^",2)["H":"HOURS",$P(DOSE,"^",2)["L":"MONTHS",$P(DOSE,"^",2)["W":"WEEKS",1:"DAYS")_")"
    94         I $P(DOSE,"^",6)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       *Conjunction: "_$S($P(DOSE,"^",6)="A":"AND",$P(DOSE,"^",6)="S":"THEN",$P(DOSE,"^",6)="X":"EXCEPT",1:"")
    95         Q
    96 DOSE2   ;displays pending order after edits
    97         S DS=1
    98         F I=1:1:PSONEW("ENT") Q:'I  D  D DOSE3 K COJ
    99         .S:$G(PSONEW("UNITS",I))]"" UNITS=$P(^PS(50.607,PSONEW("UNITS",I),0),"^") S:$G(PSONEW("ROUTE",I))]"" ROUTE=$P(^PS(51.2,PSONEW("ROUTE",I),0),"^")
    100         .S DUR=$G(PSONEW("DURATION",I)) S:$G(PSONEW("CONJUNCTION",I))]"" COJ=PSONEW("CONJUNCTION",I)
    101         .S NOUN=PSONEW("NOUN",I),VERB=$G(PSONEW("VERB",I))
    102         .I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I))
    103         .I '$G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Verb: "_$G(PSONEW("VERB",I))
    104         .S:$G(DS) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)"
    105         K I,UNITS,ROUTE,DUR,COJ,VERB,NOUN
    106         Q
    107 DOSE3   I $G(DS)=1 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"        *Dosage:" D FMD G DO
    108         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="            *Dosage:" D FMD
    109 DO      I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I))
    110         I $G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Verb: "_$G(PSONEW("VERB",I))
    111         I $G(PSONEW("DOSE ORDERED",I)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     Dispense Units: "_$S($E(PSONEW("DOSE ORDERED",I),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",I)
    112         I $G(PSONEW("DOSE ORDERED",I)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               NOUN: "_PSONEW("NOUN",I)
    113         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="             *Route: "_$G(ROUTE)
    114         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          *Schedule: "_PSONEW("SCHEDULE",I)
    115         I $G(DUR)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          *Duration: "_DUR_" ("_$S(DUR["M":"MINUTES",DUR["H":"HOURS",DUR["L":"MONTHS",DUR["W":"WEEKS",1:"DAYS")_")"
    116         I $G(COJ)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       *Conjunction: "_$S(COJ="A":"AND",COJ="T":"THEN",COJ="X":"EXCEPT",1:"")
    117         Q
    118 FMD     Q:$G(PSONEW("DOSE",II))']""  S MIG=PSONEW("DOSE",II)
    119         I $E(MIG,1)=".",$G(PSONEW("DOSE ORDERED",II)) S MIG="0"_MIG
    120         F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG)
    121         I $G(UNITS)]"" S:$L(^TMP("PSOPO",$J,IEN,0)_" ("_UNITS_")")>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" ("_UNITS_")"
    122         K DS,MIG,SG
    123         I '$G(PSONEW("DOSE ORDERED",II)),$P($G(^PS(55,PSODFN,"LAN")),"^") D LAN^PSOORED5
    124         Q
    125 SQR     ;
    126         D SQR^PSOORFIN
    127         Q
    128 SQN     ;
    129         K MAXRF,PSOSIG,MPSDY,PSOMAX,STA,PSORX0,ORCHK,ORDRG
    130         I $G(PSOQUIT) S PSOQQ=1 K PSOQUIT
    131         Q
     1PSOORFI3 ;BIR/RTR-finish CPRS orders by Clinic ;5/14/07  10:07
     2 ;;7.0;OUTPATIENT PHARMACY;**15,27,32,46,84,99,130,117,139,172,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; GPL Copyright (C) 2007 WorldVistA
     5 ;PPPPDA1-1374,SC(-2675,40.8-728,51.2-2226,50.607-2221,55-2228,PSSLOCK-2789,DPT-10035,ORX2-867
     6 ;
     7 K ^TMP($J,"PSOCL"),^TMP($J,"PSOCLX"),PSOCLIN,PSOCLINF,PSOXINST
     8 N PSOCFLAG,PSONPTRX,PSOINPTR,PSCLP,PSOCLINS,PSOSTC,PSOLGD,PSODIEN,PSOCTMP
     9 K DIR S DIR(0)="SMB^C:CLINIC;S:SORT GROUP;E:EXIT",DIR("A")="Select By",DIR("B")="Clinic",DIR("?",1)="Enter 'C' to process orders for one individual Clinic,"
     10 S DIR("?",2)="      'S' to process orders for all Clinics associated with a Sort Group,",DIR("?",3)="      '^' or 'E' to exit" S DIR("?")=" "
     11 W ! D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!(Y="E") W ! G EXIT
     12 I Y="S" G SORT
     13CLIN W ! K DIC S DIC="^SC(",DIC(0)="QEAMZ",DIC("A")="Select CLINIC: " D ^DIC K DIC I Y<1!($D(DTOUT))!($D(DUOUT)) G EXIT
     14 S PSOCLIN=+Y,PSOCLINF=1 D CHECK I $G(PSOCFLAG) D INSTNM^PSOORFI2 W !!,"You are signed in under the "_$G(PSODINST)_" CPRS Ordering",!,"Institution, which does not match the Institution for this Clinic!",! K PSODINST G CLIN
     15 S ^TMP($J,"PSOCL",PSOCLIN)=PSOCLIN K PSOCLIN G START
     16SORT W ! K DIC S DIC="^PS(59.8,",DIC(0)="QEAMZ",DIC("A")="Select CLINIC SORT GROUP: " D ^DIC K DIC I Y<1!($D(DTOUT))!($D(DUOUT)) G EXIT
     17 S PSOCLINS=+Y
     18 K ^TMP($J,"PSOCL"),^TMP($J,"PSOCLX") F PSCLP=0:0 S PSCLP=$O(^PS(59.8,PSOCLINS,1,PSCLP)) Q:'PSCLP  S PSOSTC=+$P($G(^PS(59.8,PSOCLINS,1,PSCLP,0)),"^") S:$G(PSOSTC)&($D(^SC(PSOSTC,0))) ^TMP($J,"PSOCL",PSOSTC)=PSOSTC
     19 I '$O(^TMP($J,"PSOCL",0)) W !!,"There are no Clinics associated with this Sort Group!",! K ^TMP($J,"PSOCL") G SORT
     20 F PSCLP=0:0 S PSCLP=$O(^TMP($J,"PSOCL",PSCLP)) Q:'PSCLP  S PSOCLIN=PSCLP D CHECK I $G(PSOCFLAG) S ^TMP($J,"PSOCLX",PSCLP)=PSCLP K ^TMP($J,"PSOCL",PSCLP)
     21 I $O(^TMP($J,"PSOCLX",0)) H 1 W @IOF W !,"Orders for these Clinics in the Sort Group will not be displayed for Finishing",!,"because the CPRS Ordering Institution does not match the Institution that is",!,"associated with the Clinic:",! D
     22 .F PSCLP=0:0 S PSCLP=$O(^TMP($J,"PSOCLX",PSCLP)) Q:'PSCLP  D:($Y+4)>IOSL  W !,$P($G(^SC(PSCLP,0)),"^")
     23 ..W ! K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR W @IOF
     24 I $O(^TMP($J,"PSOCLX",0)) D EOP
     25 K ^TMP($J,"PSOCLX") I '$O(^TMP($J,"PSOCL",0)) W !!,"There are no Clinics that have a matching Institution!",! D EOP G SORT
     26 ;
     27 S PSOCLINF=2
     28START K MEDP,MEDA,PSOQUIT,POERR("QFLG"),POERR("DFLG"),DIR
     29 G:'$O(^TMP($J,"PSOCL",0)) EXIT
     30 S PATA=0 F PSOCLIN=0:0 S PSOCLIN=$O(^TMP($J,"PSOCL",PSOCLIN)) Q:'PSOCLIN!($G(POERR("QFLG")))  F PSOLGD=0:0 S PSOLGD=$O(^PS(52.41,"ACL",PSOCLIN,PSOLGD)) Q:'PSOLGD!($G(POERR("QFLG")))  D
     31 .F PSODIEN=0:0 S PSODIEN=$O(^PS(52.41,"ACL",PSOCLIN,PSOLGD,PSODIEN)) Q:'PSODIEN!($G(POERR("QFLG")))  D
     32 ..I $P($G(^PS(52.41,PSODIEN,0)),"^",3)'="NW",$P($G(^(0)),"^",3)'="RNW",$P($G(^(0)),"^",3)'="RF" Q
     33 ..I $G(PSOPINST)'=$P($G(^PS(52.41,PSODIEN,"INI")),"^") Q
     34 ..Q:$G(PAT($P(^PS(52.41,PSODIEN,0),"^",2)))=$P(^PS(52.41,PSODIEN,0),"^",2)  S PAT=$P(^PS(52.41,PSODIEN,0),"^",2)
     35 ..I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
     36 ..D LK^PSOORFIN I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
     37 ..I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP^PSOORFIN Q
     38 ..S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(+$G(PAT),0)),"^"),PATA=PAT
     39 ..D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) K PSOFIN S POERR("QFLG")=0 S PSONOLCK=1,PSOPTLOK=PAT D OERR^PSORX1 S PSOFIN=1 D QU^PSOORFIN S X=PSOPTLOK D KLLP^PSOORFIN,ULP^PSOORFIN,KLL^PSOORFIN Q
     40 ..D SDFN^PSOORFIN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP^PSOORFIN K PSOQFLG Q
     41 ..S PAT(PAT)=PAT
     42 ..F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG")))  D
     43 ...S PSODFN=PAT D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2),X="PPPPDA1" X ^%ZOSF("TEST") S:$T X=$$PDA^PPPPDA1(PSODFN)
     44 ...D LK1^PSOORFIN,ORD^PSOORFIN S X=PAT D ULP^PSOORFIN
     45 I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
     46 ;
     47EXIT K ^TMP($J,"PSOCL"),^TMP($J,"PSOCLX"),PSOCLIN,PSOCLINF,PSOXINST G EX^PSOORFIN
     48 Q
     49CHECK ; check Institution
     50 K PSOXINST,PSOCFLAG
     51 I $P($G(^SC(PSOCLIN,0)),"^",4),$P($G(^(0)),"^",4)'=$G(PSOPINST) S PSOCFLAG=1 Q
     52 I $P($G(^SC(PSOCLIN,0)),"^",4) Q
     53 S PSONPTRX=$P($G(^SC(PSOCLIN,0)),"^",15)
     54 I '$G(PSONPTRX) S PSONPTRX=$O(^DG(40.8,0))
     55 I '$G(DT) S DT=$$DT^XLFDT
     56 S PSOINPTR=+$$SITE^VASITE(DT,PSONPTRX) I PSOINPTR'=$G(PSOPINST) S PSOCFLAG=1
     57 Q
     58EOP W ! K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR
     59 Q
     60L1 ;Lock single order
     61 I '$G(ORD) Q
     62 K PSOMSG D PSOL^PSSLOCK(+ORD_"S") I '$G(PSOMSG),'$D(ZTSK) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"This Order is being edited by another person."),! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
     63 Q
     64UL1 ;Unlock single order
     65 I '$G(ORD) Q
     66 I '$D(^PS(52.41,ORD,0)) D  Q
     67 . D UNLK1^ORX2(+$G(OR0))
     68 . Q
     69 D PSOUL^PSSLOCK(+ORD_"S")
     70 Q
     71DOSE ;pending orders
     72 K DOENT S DS=1
     73 F I=0:0 S I=$O(^PS(52.41,ORD,1,I)) Q:'I  S DOSE=$G(^PS(52.41,ORD,1,I,1)),DOSE1=$G(^(2)) D  D DOSE1
     74 .S PSONEW("DOSE",I)=$P(DOSE1,"^"),PSONEW("DOSE ORDERED",I)=$P(DOSE1,"^",2),PSONEW("UNITS",I)=$P(DOSE,"^",9),PSONEW("NOUN",I)=$P(DOSE,"^",5)
     75 .S:$P(DOSE,"^",9) UNITS=$P(^PS(50.607,$P(DOSE,"^",9),0),"^")
     76 .S PSONEW("VERB",I)=$P(DOSE,"^",10),PSONEW("ROUTE",I)=$P(DOSE,"^",8)
     77 .S:$P(DOSE,"^",8) ROUTE=$P(^PS(51.2,$P(DOSE,"^",8),0),"^")
     78 .S PSONEW("SCHEDULE",I)=$P(DOSE,"^"),PSONEW("DURATION",I)=$P(DOSE,"^",2)
     79 .S DOENT=$G(DOENT)+1 S PSONEW("CONJUNCTION",I)=$S($P(DOSE,"^",6)="A":"AND",$P(DOSE,"^",6)="S":"THEN",$P(DOSE,"^",6)="X":"EXCEPT",1:"")
     80 .I 'PSONEW("DOSE ORDERED",I),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Verb: "_$G(PSONEW("VERB",I))
     81 .S:$G(DS) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)"
     82 S PSONEW("ENT")=DOENT K DOSE,DOSE1,I,UNITS,ROUTE,DOENT
     83 Q
     84DOSE1 I $G(DS)=1 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"        *Dosage:" D FMD G DU
     85 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="            *Dosage:" D FMD
     86DU I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I))
     87 I PSONEW("DOSE ORDERED",I),$G(PSONEW("VERB",I))]"" D
     88 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Verb: "_$G(PSONEW("VERB",I))
     89 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     Dispense Units: "_$S($E(PSONEW("DOSE ORDERED",I),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",I)
     90 I PSONEW("NOUN",I) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Noun: "_PSONEW("NOUN",I)
     91 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="             *Route: "_$G(ROUTE)
     92 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          *Schedule: "_PSONEW("SCHEDULE",I)
     93 I $P(DOSE,"^",2)]"" D
     94 .S DUR=$S($E($P(DOSE,"^",2),1)'?.N:$E($P(DOSE,"^",2),2,99)_$E($P(DOSE,"^",2),1),1:$P(DOSE,"^",2))
     95 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          *Duration: "_DUR_" ("_$S($P(DOSE,"^",2)["M":"MINUTES",$P(DOSE,"^",2)["H":"HOURS",$P(DOSE,"^",2)["L":"MONTHS",$P(DOSE,"^",2)["W":"WEEKS",1:"DAYS")_")"
     96 I $P(DOSE,"^",6)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       *Conjunction: "_$S($P(DOSE,"^",6)="A":"AND",$P(DOSE,"^",6)="S":"THEN",$P(DOSE,"^",6)="X":"EXCEPT",1:"")
     97 Q
     98DOSE2 ;displays pending order after edits
     99 S DS=1
     100 F I=1:1:PSONEW("ENT") Q:'I  D  D DOSE3 K COJ
     101 .S:$G(PSONEW("UNITS",I))]"" UNITS=$P(^PS(50.607,PSONEW("UNITS",I),0),"^") S:$G(PSONEW("ROUTE",I))]"" ROUTE=$P(^PS(51.2,PSONEW("ROUTE",I),0),"^")
     102 .S DUR=$G(PSONEW("DURATION",I)) S:$G(PSONEW("CONJUNCTION",I))]"" COJ=PSONEW("CONJUNCTION",I)
     103 .S NOUN=PSONEW("NOUN",I),VERB=$G(PSONEW("VERB",I))
     104 .I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I))
     105 .I '$G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Verb: "_$G(PSONEW("VERB",I))
     106 .S:$G(DS) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)"
     107 K I,UNITS,ROUTE,DUR,COJ,VERB,NOUN
     108 Q
     109DOSE3 I $G(DS)=1 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"        *Dosage:" D FMD G DO
     110 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="            *Dosage:" D FMD
     111DO I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I))
     112 I $G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Verb: "_$G(PSONEW("VERB",I))
     113 I $G(PSONEW("DOSE ORDERED",I)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     Dispense Units: "_$S($E(PSONEW("DOSE ORDERED",I),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",I)
     114 I $G(PSONEW("DOSE ORDERED",I)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               NOUN: "_PSONEW("NOUN",I)
     115 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="             *Route: "_$G(ROUTE)
     116 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          *Schedule: "_PSONEW("SCHEDULE",I)
     117 I $G(DUR)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          *Duration: "_DUR_" ("_$S(DUR["M":"MINUTES",DUR["H":"HOURS",DUR["L":"MONTHS",DUR["W":"WEEKS",1:"DAYS")_")"
     118 I $G(COJ)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       *Conjunction: "_$S(COJ="A":"AND",COJ="T":"THEN",COJ="X":"EXCEPT",1:"")
     119 Q
     120FMD Q:$G(PSONEW("DOSE",II))']""  S MIG=PSONEW("DOSE",II)
     121 I $E(MIG,1)=".",$G(PSONEW("DOSE ORDERED",II)) S MIG="0"_MIG
     122 F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG)
     123 I $G(UNITS)]"" S:$L(^TMP("PSOPO",$J,IEN,0)_" ("_UNITS_")")>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" ("_UNITS_")"
     124 K DS,MIG,SG
     125 I '$G(PSONEW("DOSE ORDERED",II)),$P($G(^PS(55,PSODFN,"LAN")),"^") D LAN^PSOORED5
     126 Q
     127SQR ;
     128 K PSOORRNW,PSOOPT,PSOREEDT,PSOQUIT S POERR("DFLG")=0
     129 Q
     130SQN ;
     131 K MAXRF,PSOSIG,MPSDY,PSOMAX,STA,PSORX0,ORCHK,ORDRG
     132 I $G(PSOQUIT) S PSOQQ=1 K PSOQUIT
     133 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI4.m

    r613 r623  
    1 PSOORFI4        ;BIR/SAB-CPRS order checks and display con't ;9:30 AM  31 Dec 2008
    2         ;;7.0;OUTPATIENT PHARMACY;**46,74,78,99,117,131,207,258,274,208**;DEC 1997;Build 41;WorldVistA 30-Jan-08
    3         ;
    4         ;Modified from FOIA VISTA,
    5         ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    6         ;General Public License See attached copy of the License.
    7         ;
    8         ;This program is free software; you can redistribute it and/or modify
    9         ;it under the terms of the GNU General Public License as published by
    10         ;the Free Software Foundation; either version 2 of the License, or
    11         ;(at your option) any later version.
    12         ;
    13         ;This program is distributed in the hope that it will be useful,
    14         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    15         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    16         ;GNU General Public License for more details.
    17         ;
    18         ;You should have received a copy of the GNU General Public License along
    19         ;with this program; if not, write to the Free Software Foundation, Inc.,
    20         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    21         ;
    22         ;External reference to ^PS(51.2 supported by DBIA 2226
    23         ;External reference to ^PS(50.607 supported by DBIA 2221
    24         ;External reference ^PS(55 supported by DBIA 2228
    25         ;External reference to ^PS(50.7 is supported by DBIA 2223
    26         ;External reference to $$PDA^PPPPDA1 is supported by DBIA 1374
    27         ;
    28 ORCHK   D ORCHK^PSOORNE6
    29         Q
    30 INST    ;displays patient instructions
    31         I $O(PSONEW("SIG",0)) G INST1
    32         S INST=0 F  S INST=$O(^PS(52.41,ORD,"INS1",INST)) Q:'INST  S (MIG,PSONEW("SIG",INST))=^PS(52.41,ORD,"INS1",INST,0) D
    33         .F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG)
    34         I $P($G(^PS(55,PSODFN,"LAN")),"^"),$O(^PS(52.41,ORD,"INS1",0)) D
    35         .I $G(^PS(50.7,PSODRUG("OI"),"INS1"))]"" S (X,PSONEW("SINS"))=^PS(50.7,PSODRUG("OI"),"INS1") D SSIG^PSOHELP
    36         .I $G(SINS1)]"" S PSONEW("SINS")=$E(SINS1,2,250)
    37         .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Other Pat Instruct: "_$S($G(PSONEW("SINS"))]"":PSONEW("SINS"),1:"")
    38         K INST,TY,MIG,SG,SINS1
    39         Q
    40 INST1   ;
    41         S INS=0 F  S INS=$O(PSONEW("SIG",INS)) Q:'INS  S MIG=PSONEW("SIG",INS) D
    42         .F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG)
    43         K INST,TY,MIG,SG
    44         I $P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Other Pat Instruct: "_$S($G(PSONEW("SINS"))]"":PSONEW("SINS"),1:"")
    45         Q
    46 PROVCOM ;
    47         I $G(PKI1)=1,'$G(PSORX("VERIFY")) D REA^PSOPKIV1 Q:$G(PSORX("DFLG"))
    48         I $O(PRC(0)),'$G(PSOPRC) D  D KV^PSOVER1
    49         .D EN^DDIOL("Provider Comments: ","","!")
    50         .F I=0:0 S I=$O(PRC(I)) Q:'I  D EN^DDIOL(PRC(I),"","!")
    51         .;WVEHR ;begin p208
    52         .;D KV^PSOVER1 S DIR(0)="Y",DIR("A")="Copy Provider Comments into the Patient Instructions",DIR("B")="No"
    53         .;D ^DIR Q:'Y!($D(DIRUT))
    54         .I $G(PSOAFYN)="Y" D KV^PSOVER1 ;vfam
    55         .I $G(PSOAFYN)'="Y" D KV^PSOVER1 S DIR(0)="Y",DIR("A")="Copy Provider Comments into the Patient Instructions",DIR("B")="No"  ;vfam
    56         .I $G(PSOAFYN)'="Y" D ^DIR Q:'Y!($D(DIRUT))  ;vfam
    57         .I $G(PSOAFYN)="Y" Q  ;vfam Provider Comments NOT Copied Into Patient Instructions
    58         .;WVEHR ;end p208
    59         .S PSOPRC=1,NI=0 F I=0:0 S I=$O(PSONEW("SIG",I)) Q:'I  S NI=I
    60         .S NC=0 F I=0:0 S I=$O(PRC(I)) Q:'I  S NC=NC+1
    61         .I NI'>1,NC=1,($L($G(PSONEW("SIG",NI)))+$L(PRC(1)))'>250 D  Q
    62         ..S X=PRC(1) D SIGONE^PSOHELP
    63         ..S PSONEW("SIG",1)=$G(PSONEW("SIG",NI))_INS1 K INS1,X
    64         ..S:$E(PSONEW("SIG",1))=" " PSONEW("SIG",1)=$E(PSONEW("SIG",1),2,250) S PSONEW("INS")=PSONEW("SIG",1) D EN^PSOFSIG(.PSONEW,1) K NI,NC
    65         .F I=0:0 S I=$O(PRC(I)) Q:'I  S NI=NI+1,(PSONEW("INS",NI),X)=PRC(I) D SIGONE^PSOHELP S PSONEW("SIG",NI)=INS1 K INS1
    66         .I $E(PSONEW("SIG",1))=" " S PSONEW("SIG",1)=$E(PSONEW("SIG",1),2,250)
    67         .D EN^PSOFSIG(.PSONEW,1) K NI,NC,X
    68         Q
    69 DOSE    ;displays dosing info for pending orders.  called from psoorfi1
    70         K II,UNITS S DS=1
    71         I '$O(^PS(52.41,ORD,1,0)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)        *Dosage:" G DOSEX
    72         F I=0:0 S I=$O(^PS(52.41,ORD,1,I)) Q:'I  S DOSE=$G(^PS(52.41,ORD,1,I,1)),DOSE1=$G(^(2)) D  D DOSE1
    73         .S II=$G(II)+1 K PSONEW("UNITS",II)
    74         .S PSONEW("DOSE",II)=$P(DOSE1,"^"),PSONEW("DOSE ORDERED",II)=$P(DOSE1,"^",2),PSONEW("UNITS",II)=$P(DOSE,"^",9),PSONEW("NOUN",II)=$P(DOSE,"^",5)
    75         .S:$P(DOSE,"^",9) UNITS=$P(^PS(50.607,$P(DOSE,"^",9),0),"^")
    76         .S PSONEW("VERB",II)=$P(DOSE,"^",10),PSONEW("ROUTE",II)=$P(DOSE,"^",8)
    77         .S:$P(DOSE,"^",8) ROUTE=$P(^PS(51.2,$P(DOSE,"^",8),0),"^")
    78         .S PSONEW("SCHEDULE",II)=$P(DOSE,"^"),PSONEW("DURATION",II)=$P(DOSE,"^",2)
    79         .S DOENT=$G(DOENT)+1 I $P(DOSE,"^",6)]"" S PSONEW("CONJUNCTION",II)=$S($P(DOSE,"^",6)="S":"T",$P(DOSE,"^",6)="X":"X",1:"A")
    80         .I 'PSONEW("DOSE ORDERED",II),$G(PSONEW("VERB",II))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Verb: "_$G(PSONEW("VERB",II))
    81         .S:$G(DS) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)"
    82 DOSEX   S PSONEW("ENT")=+$G(II) K DOSE,DOSE1,II,I,UNITS,ROUTE,DG
    83         Q
    84 DOSE1   I $G(DS)=1 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"        *Dosage:" D FMD^PSOORFI3 G DU
    85         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="            *Dosage:" D FMD^PSOORFI3
    86 DU      I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I))
    87         I PSONEW("DOSE ORDERED",II),$G(PSONEW("VERB",II))]"" D
    88         .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Verb: "_$G(PSONEW("VERB",II))
    89         .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     Dispense Units: "_$S($E(PSONEW("DOSE ORDERED",II),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",II)
    90         I PSONEW("NOUN",II)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Noun: "_PSONEW("NOUN",II)
    91         I $G(ROUTE)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="             *Route: "_$G(ROUTE)
    92         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          *Schedule: "_PSONEW("SCHEDULE",II)
    93         I $G(PSONEW("DURATION",II))]"" D
    94         .S PSONEW("DURATION",II)=$S($E(PSONEW("DURATION",II),1)'?.N:$E(PSONEW("DURATION",II),2,99)_$E(PSONEW("DURATION",II),1),1:PSONEW("DURATION",II))
    95         .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          *Duration: "_PSONEW("DURATION",II)_" ("_$S(PSONEW("DURATION",II)["M":"MINUTES",PSONEW("DURATION",II)["H":"HOURS",PSONEW("DURATION",II)["L":"MONTHS",PSONEW("DURATION",II)["W":"WEEKS",1:"DAYS")_")"
    96         I $G(PSONEW("CONJUNCTION",II))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       *Conjunction: "_$S(PSONEW("CONJUNCTION",II)="T":"THEN",PSONEW("CONJUNCTION",II)="X":"EXCEPT",1:"AND")
    97         Q
    98 DOSE2   ;displays pending order after edits.  called from psoornew
    99         I '$O(PSONEW("DOSE",0))!($O(PSONEW("DOSE",0))="") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)        *Dosage:" Q
    100         S DS=1
    101         F I=1:1:PSONEW("ENT") Q:'I  D  D DOSE3 K COJ
    102         .S:$G(PSONEW("UNITS",I))]"" UNITS=$P(^PS(50.607,PSONEW("UNITS",I),0),"^")
    103         .I $G(PSONEW("ROUTE",I))]"",$G(^PS(51.2,PSONEW("ROUTE",I),0))]"" S ROUTE=$P(^PS(51.2,PSONEW("ROUTE",I),0),"^")
    104         .S DUR=$G(PSONEW("DURATION",I)) S:$G(PSONEW("CONJUNCTION",I))]"" COJ=PSONEW("CONJUNCTION",I)
    105         .S NOUN=$G(PSONEW("NOUN",I)),VERB=$G(PSONEW("VERB",I))
    106         .I '$G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Verb: "_$G(PSONEW("VERB",I))
    107         .S:$G(DS) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)"
    108         K I,UNITS,ROUTE,DUR,COJ,VERB,NOUN,DG
    109         Q
    110 DOSE3   I $G(DS)=1 S II=I,^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"        *Dosage:" D FMD^PSOORFI3 G DO
    111         S II=I,IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="            *Dosage:" D FMD^PSOORFI3
    112 DO      I '$G(PSONEW("DOSE ORDERED",I)),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I))
    113         I $G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Verb: "_$G(PSONEW("VERB",I))
    114         I $G(PSONEW("DOSE ORDERED",I)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     Dispense Units: "_$S($E(PSONEW("DOSE ORDERED",I),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",I)
    115         I $G(PSONEW("NOUN",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               NOUN: "_PSONEW("NOUN",I)
    116         I $G(ROUTE)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="             *Route: "_$G(ROUTE)
    117         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          *Schedule: "_PSONEW("SCHEDULE",I)
    118         I $G(PSONEW("DURATION",I))]"" D
    119         .S PSONEW("DURATION",I)=$S($E(PSONEW("DURATION",I),1)'?.N:$E(PSONEW("DURATION",I),2,99)_$E(PSONEW("DURATION",I),1),1:PSONEW("DURATION",I))
    120         .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          *Duration: "_PSONEW("DURATION",I)_" ("_$S(PSONEW("DURATION",I)["M":"MINUTES",PSONEW("DURATION",I)["H":"HOURS",PSONEW("DURATION",I)["L":"MONTHS",PSONEW("DURATION",I)["W":"WEEKS",1:"DAYS")_")"
    121         I $G(PSONEW("CONJUNCTION",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       *Conjunction: "_$S(PSONEW("CONJUNCTION",I)="T":"THEN",PSONEW("CONJUNCTION",I)="X":"EXCEPT",1:"AND")
    122         Q
    123 OBX     ;formats obx section
    124         N COM,II
    125         D:$G(PKI1) L1^PSOPKIV1
    126         I $O(^PS(52.41,ORD,"OBX",0)) S (T,IEN)=0,IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="Order Checks:" F  S T=$O(^PS(52.41,ORD,"OBX",T)) Q:'T  D  S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" "
    127         .S COM=$G(^PS(52.41,ORD,"OBX",T,0))
    128         .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     " F II=1:1:$L(COM," ") D
    129         ..I $L(^TMP("PSOPO",$J,IEN,0)_" "_$P(COM," ",II))>80 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     "
    130         ..S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_" "_$P(COM," ",II)
    131         .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     Overriding Provider: "_$G(^PS(52.41,ORD,"OBX",T,1))
    132         .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     Overriding Reason:"
    133         .F T1=0:0 S T1=$O(^PS(52.41,ORD,"OBX",T,2,T1)) Q:'T1  D
    134         ..S MIG=^PS(52.41,ORD,"OBX",T,2,T1,0)
    135         ..F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",23)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG)
    136         Q
    137 PP      S PSODFN=PAT D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2),X="PPPPDA1"
    138         X ^%ZOSF("TEST") S:$T X=$$PDA^PPPPDA1(PSODFN)
    139         Q
    140 SPL     K PSOFIN S POERR("QFLG")=0 S PSONOLCK=1,PSOPTLOK=PAT
    141         Q
    142 CLQTY   ;
    143         K PSONEW("QTY")
    144         D QTY^PSOSIG(.PSONEW)
    145         S:'$G(PSONEW("QTY")) PSONEW("QTY")=0
    146         Q
    147 PQTY    ;
    148         S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_", days supply of "_+$P(OR0,"^",22)_" and a qty of "_+$P(OR0,"^",10)
    149         Q
    150 REF     Q:$G(PSODRUG("DEA"))']""
    151         S CS=0 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S CS=1
    152         S PTRF=PSONEW("# OF REFILLS"),PSDAYS=PSONEW("DAYS SUPPLY")
    153         I CS D
    154         .S PSOX1=$S(PTRF>5:5,1:PTRF),PSOX=$S(PSOX1=5:5,1:PSOX1)
    155         .S PSOX=$S('PSOX:0,PSDAYS=90:1,1:PSOX),PSDY1=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0)
    156         E  D
    157         .S PSOX1=PTRF,PSOX=$S(PSOX1=11:11,1:PSOX1),PSOX=$S('PSOX:0,PSDAYS=90:3,1:PSOX)
    158         .S PSDY1=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0)
    159         S PSONEW("# OF REFILLS")=$S(PSONEW("# OF REFILLS")>PSDY1:PSDY1,1:PSONEW("# OF REFILLS"))
    160         Q
     1PSOORFI4 ;BIR/SAB-CPRS order checks and display con't ;1/27/07  13:26
     2 ;;7.0;OUTPATIENT PHARMACY;**46,74,78,99,117,131,207,258,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; GPL Copyright (C) 2007 WorldVistA
     5 ;External reference to ^PS(51.2 supported by DBIA 2226
     6 ;External reference to ^PS(50.607 supported by DBIA 2221
     7 ;External reference ^PS(55 supported by DBIA 2228
     8 ;External reference to ^PS(50.7 is supported by DBIA 2223
     9 ;External reference to $$PDA^PPPPDA1 is supported by DBIA 1374
     10 ;
     11ORCHK D ORCHK^PSOORNE6
     12 Q
     13INST ;displays patient instructions
     14 I $O(PSONEW("SIG",0)) G INST1
     15 S INST=0 F  S INST=$O(^PS(52.41,ORD,"INS1",INST)) Q:'INST  S (MIG,PSONEW("SIG",INST))=^PS(52.41,ORD,"INS1",INST,0) D
     16 .F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG)
     17 I $P($G(^PS(55,PSODFN,"LAN")),"^"),$O(^PS(52.41,ORD,"INS1",0)) D
     18 .I $G(^PS(50.7,PSODRUG("OI"),"INS1"))]"" S (X,PSONEW("SINS"))=^PS(50.7,PSODRUG("OI"),"INS1") D SSIG^PSOHELP
     19 .I $G(SINS1)]"" S PSONEW("SINS")=$E(SINS1,2,250)
     20 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Other Pat Instruct: "_$S($G(PSONEW("SINS"))]"":PSONEW("SINS"),1:"")
     21 K INST,TY,MIG,SG,SINS1
     22 Q
     23INST1 ;
     24 S INS=0 F  S INS=$O(PSONEW("SIG",INS)) Q:'INS  S MIG=PSONEW("SIG",INS) D
     25 .F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG)
     26 K INST,TY,MIG,SG
     27 I $P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Other Pat Instruct: "_$S($G(PSONEW("SINS"))]"":PSONEW("SINS"),1:"")
     28 Q
     29PROVCOM ;
     30 I $G(PKI1)=1,'$G(PSORX("VERIFY")) D REA^PSOPKIV1 Q:$G(PSORX("DFLG"))
     31 I $O(PRC(0)),'$G(PSOPRC) D  D KV^PSOVER1
     32 .D EN^DDIOL("Provider Comments: ","","!")
     33 .F I=0:0 S I=$O(PRC(I)) Q:'I  D EN^DDIOL(PRC(I),"","!")
     34 .I $G(PSOAFYN)="Y" D KV^PSOVER1 ;vfam
     35 .I $G(PSOAFYN)'="Y" D KV^PSOVER1 S DIR(0)="Y",DIR("A")="Copy Provider Comments into the Patient Instructions",DIR("B")="No"  ;vfam
     36 .I $G(PSOAFYN)'="Y" D ^DIR Q:'Y!($D(DIRUT))  ;vfam
     37 .I $G(PSOAFYN)="Y" Q  ;vfam Provider Comments NOT Copied Into Patient Instructions
     38 .S PSOPRC=1,NI=0 F I=0:0 S I=$O(PSONEW("SIG",I)) Q:'I  S NI=I
     39 .S NC=0 F I=0:0 S I=$O(PRC(I)) Q:'I  S NC=NC+1
     40 .I NI'>1,NC=1,($L($G(PSONEW("SIG",NI)))+$L(PRC(1)))'>250 D  Q
     41 ..S PSONEW("SIG",1)=$G(PSONEW("SIG",NI))_" "_PRC(1)
     42 ..S:$E(PSONEW("SIG",1))=" " PSONEW("SIG",1)=$E(PSONEW("SIG",1),2,250) S PSONEW("INS")=PSONEW("SIG",1) D EN^PSOFSIG(.PSONEW,1) K NI,NC
     43 .F I=0:0 S I=$O(PRC(I)) Q:'I  S NI=NI+1,(PSONEW("SIG",NI),PSONEW("INS",NI))=PRC(I)
     44 .I $E(PSONEW("SIG",1))=" " S PSONEW("SIG",1)=$E(PSONEW("SIG",1),2,250)
     45 .D EN^PSOFSIG(.PSONEW,1) K NI,NC
     46 Q
     47DOSE ;displays dosing info for pending orders.  called from psoorfi1
     48 K II,UNITS S DS=1
     49 I '$O(^PS(52.41,ORD,1,0)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)        *Dosage:" G DOSEX
     50 F I=0:0 S I=$O(^PS(52.41,ORD,1,I)) Q:'I  S DOSE=$G(^PS(52.41,ORD,1,I,1)),DOSE1=$G(^(2)) D  D DOSE1
     51 .S II=$G(II)+1 K PSONEW("UNITS",II)
     52 .S PSONEW("DOSE",II)=$P(DOSE1,"^"),PSONEW("DOSE ORDERED",II)=$P(DOSE1,"^",2),PSONEW("UNITS",II)=$P(DOSE,"^",9),PSONEW("NOUN",II)=$P(DOSE,"^",5)
     53 .S:$P(DOSE,"^",9) UNITS=$P(^PS(50.607,$P(DOSE,"^",9),0),"^")
     54 .S PSONEW("VERB",II)=$P(DOSE,"^",10),PSONEW("ROUTE",II)=$P(DOSE,"^",8)
     55 .S:$P(DOSE,"^",8) ROUTE=$P(^PS(51.2,$P(DOSE,"^",8),0),"^")
     56 .S PSONEW("SCHEDULE",II)=$P(DOSE,"^"),PSONEW("DURATION",II)=$P(DOSE,"^",2)
     57 .S DOENT=$G(DOENT)+1 I $P(DOSE,"^",6)]"" S PSONEW("CONJUNCTION",II)=$S($P(DOSE,"^",6)="S":"T",$P(DOSE,"^",6)="X":"X",1:"A")
     58 .I 'PSONEW("DOSE ORDERED",II),$G(PSONEW("VERB",II))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Verb: "_$G(PSONEW("VERB",II))
     59 .S:$G(DS) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)"
     60DOSEX S PSONEW("ENT")=+$G(II) K DOSE,DOSE1,II,I,UNITS,ROUTE,DG
     61 Q
     62DOSE1 I $G(DS)=1 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"        *Dosage:" D FMD^PSOORFI3 G DU
     63 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="            *Dosage:" D FMD^PSOORFI3
     64DU I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I))
     65 I PSONEW("DOSE ORDERED",II),$G(PSONEW("VERB",II))]"" D
     66 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Verb: "_$G(PSONEW("VERB",II))
     67 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     Dispense Units: "_$S($E(PSONEW("DOSE ORDERED",II),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",II)
     68 I PSONEW("NOUN",II)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Noun: "_PSONEW("NOUN",II)
     69 I $G(ROUTE)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="             *Route: "_$G(ROUTE)
     70 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          *Schedule: "_PSONEW("SCHEDULE",II)
     71 I $G(PSONEW("DURATION",II))]"" D
     72 .S PSONEW("DURATION",II)=$S($E(PSONEW("DURATION",II),1)'?.N:$E(PSONEW("DURATION",II),2,99)_$E(PSONEW("DURATION",II),1),1:PSONEW("DURATION",II))
     73 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          *Duration: "_PSONEW("DURATION",II)_" ("_$S(PSONEW("DURATION",II)["M":"MINUTES",PSONEW("DURATION",II)["H":"HOURS",PSONEW("DURATION",II)["L":"MONTHS",PSONEW("DURATION",II)["W":"WEEKS",1:"DAYS")_")"
     74 I $G(PSONEW("CONJUNCTION",II))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       *Conjunction: "_$S(PSONEW("CONJUNCTION",II)="T":"THEN",PSONEW("CONJUNCTION",II)="X":"EXCEPT",1:"AND")
     75 Q
     76DOSE2 ;displays pending order after edits.  called from psoornew
     77 I '$O(PSONEW("DOSE",0))!($O(PSONEW("DOSE",0))="") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)        *Dosage:" Q
     78 S DS=1
     79 F I=1:1:PSONEW("ENT") Q:'I  D  D DOSE3 K COJ
     80 .S:$G(PSONEW("UNITS",I))]"" UNITS=$P(^PS(50.607,PSONEW("UNITS",I),0),"^")
     81 .I $G(PSONEW("ROUTE",I))]"",$G(^PS(51.2,PSONEW("ROUTE",I),0))]"" S ROUTE=$P(^PS(51.2,PSONEW("ROUTE",I),0),"^")
     82 .S DUR=$G(PSONEW("DURATION",I)) S:$G(PSONEW("CONJUNCTION",I))]"" COJ=PSONEW("CONJUNCTION",I)
     83 .S NOUN=$G(PSONEW("NOUN",I)),VERB=$G(PSONEW("VERB",I))
     84 .I '$G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Verb: "_$G(PSONEW("VERB",I))
     85 .S:$G(DS) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)"
     86 K I,UNITS,ROUTE,DUR,COJ,VERB,NOUN,DG
     87 Q
     88DOSE3 I $G(DS)=1 S II=I,^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"        *Dosage:" D FMD^PSOORFI3 G DO
     89 S II=I,IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="            *Dosage:" D FMD^PSOORFI3
     90DO I '$G(PSONEW("DOSE ORDERED",I)),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I))
     91 I $G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Verb: "_$G(PSONEW("VERB",I))
     92 I $G(PSONEW("DOSE ORDERED",I)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     Dispense Units: "_$S($E(PSONEW("DOSE ORDERED",I),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",I)
     93 I $G(PSONEW("NOUN",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               NOUN: "_PSONEW("NOUN",I)
     94 I $G(ROUTE)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="             *Route: "_$G(ROUTE)
     95 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          *Schedule: "_PSONEW("SCHEDULE",I)
     96 I $G(PSONEW("DURATION",I))]"" D
     97 .S PSONEW("DURATION",I)=$S($E(PSONEW("DURATION",I),1)'?.N:$E(PSONEW("DURATION",I),2,99)_$E(PSONEW("DURATION",I),1),1:PSONEW("DURATION",I))
     98 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          *Duration: "_PSONEW("DURATION",I)_" ("_$S(PSONEW("DURATION",I)["M":"MINUTES",PSONEW("DURATION",I)["H":"HOURS",PSONEW("DURATION",I)["L":"MONTHS",PSONEW("DURATION",I)["W":"WEEKS",1:"DAYS")_")"
     99 I $G(PSONEW("CONJUNCTION",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       *Conjunction: "_$S(PSONEW("CONJUNCTION",I)="T":"THEN",PSONEW("CONJUNCTION",I)="X":"EXCEPT",1:"AND")
     100 Q
     101OBX ;formats obx section
     102 N COM,II
     103 D:$G(PKI1) L1^PSOPKIV1
     104 I $O(^PS(52.41,ORD,"OBX",0)) S (T,IEN)=0,IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="Order Checks:" F  S T=$O(^PS(52.41,ORD,"OBX",T)) Q:'T  D  S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" "
     105 .S COM=$G(^PS(52.41,ORD,"OBX",T,0))
     106 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     " F II=1:1:$L(COM," ") D
     107 ..I $L(^TMP("PSOPO",$J,IEN,0)_" "_$P(COM," ",II))>80 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     "
     108 ..S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_" "_$P(COM," ",II)
     109 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     Overriding Provider: "_$G(^PS(52.41,ORD,"OBX",T,1))
     110 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     Overriding Reason:"
     111 .F T1=0:0 S T1=$O(^PS(52.41,ORD,"OBX",T,2,T1)) Q:'T1  D
     112 ..S MIG=^PS(52.41,ORD,"OBX",T,2,T1,0)
     113 ..F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",23)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG)
     114 Q
     115PP S PSODFN=PAT D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2),X="PPPPDA1"
     116 X ^%ZOSF("TEST") S:$T X=$$PDA^PPPPDA1(PSODFN)
     117 Q
     118SPL K PSOFIN S POERR("QFLG")=0 S PSONOLCK=1,PSOPTLOK=PAT
     119 Q
     120CLQTY ;
     121 K PSONEW("QTY")
     122 D QTY^PSOSIG(.PSONEW)
     123 S:'$G(PSONEW("QTY")) PSONEW("QTY")=0
     124 Q
     125PQTY ;
     126 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_", days supply of "_+$P(OR0,"^",22)_" and a qty of "_+$P(OR0,"^",10)
     127 Q
     128REF Q:$G(PSODRUG("DEA"))']""
     129 S CS=0 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S CS=1
     130 S PTRF=PSONEW("# OF REFILLS"),PSDAYS=PSONEW("DAYS SUPPLY")
     131 I CS D
     132 .S PSOX1=$S(PTRF>5:5,1:PTRF),PSOX=$S(PSOX1=5:5,1:PSOX1)
     133 .S PSOX=$S('PSOX:0,PSDAYS=90:1,1:PSOX),PSDY1=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0)
     134 E  D
     135 .S PSOX1=PTRF,PSOX=$S(PSOX1=11:11,1:PSOX1),PSOX=$S('PSOX:0,PSDAYS=90:3,1:PSOX)
     136 .S PSDY1=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0)
     137 S PSONEW("# OF REFILLS")=$S(PSONEW("# OF REFILLS")>PSDY1:PSDY1,1:PSONEW("# OF REFILLS"))
     138 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI5.m

    r613 r623  
    1 PSOORFI5        ;BIR/SJA-finish cprs orders ;11/06/06 10:49am
    2         ;;7.0;OUTPATIENT PHARMACY;**225**;DEC 1997;Build 29
    3         ;External references UL^PSSLOCK supported by DBIA 2789
    4         ;External reference to ^DPT supported by DBIA 10035
    5         ;
    6 FLG     W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="FLAGGED^FLAGGED"
    7         S LG=0,PATA=0 F  S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG")))  F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG")))  D
    8         .Q:'$D(^PS(52.41,PSOD,0))!('$P($G(^PS(52.41,PSOD,0)),"^",23))
    9         .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2)  S PAT=$P(^PS(52.41,PSOD,0),"^",2)
    10         .I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
    11         .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
    12         .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG,PSOQQ Q
    13         .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
    14         .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
    15         .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
    16         .S PAT(PAT)=PAT
    17         .F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG")))!($G(PSOQQ))  D
    18         ..I $P($G(^PS(52.41,ORD,0)),"^",23) D PP,LK1,ORD^PSOORFIN
    19         .S X=PAT D ULP K PSOQQ
    20         I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
    21         I $G(PSOQUIT) K PSOQUIT D EX G ^PSOORFIN
    22         G EX
    23         ;
    24 PRI     ; Called from PSOORFIN due to it's routine size.
    25         K DIR S PSOSORT="PRIORITY"
    26         S DIR("A")="Select Priority",DIR(0)="SBM^S:STAT;E:EMERGENCY;R:ROUTINE",DIR("B")="ROUTINE"
    27         D ^DIR G:$D(DIRUT) EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y
    28         S LG=0,PATA=0 F  S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG")))  F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG")))  D
    29         .Q:$P($G(^PS(52.41,PSOD,0)),"^",23)
    30         .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2)  S PAT=$P(^PS(52.41,PSOD,0),"^",2)
    31         .I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
    32         .I '$O(^PS(52.41,"AP",PAT,PSRT,0)) S PSOLK=1,PAT(PAT)=PAT Q
    33         .D PRI^PSOORFI2 I $G(PSZFIN) S PSOLK=1,PAT(PAT)=PAT Q
    34         .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
    35         .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP Q
    36         .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
    37         .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
    38         .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
    39         .D PP S ORD=0 D @PSRT S PAT(PAT)=PAT
    40         .S X=PAT D ULP
    41         I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
    42         I $G(PSOQUIT) K PSOQUIT D EX G ^PSOORFIN
    43 EX      D EX^PSOORFI1
    44         Q
    45 LK      D LOCK^PSOORFI1
    46         Q
    47 LK1     D LOCK1^PSOORFI1 Q
    48 QU      I $G(PSOQUIT) S POERR("QFLG")=1 K PSOQUIT
    49         S:$G(PSOQFLG) PAT(PAT)=PAT
    50         Q
    51 ULP     K PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
    52         D CLEAN^PSOVER1
    53         I '$G(X) Q
    54         D UL^PSSLOCK(X) Q
    55 KLL     K PSOPTLOK
    56         Q
    57 KLLP    K PSONOLCK
    58         Q
    59 SPL     D SPL^PSOORFI4
    60         Q
    61 SDFN    S PSODFN=+$G(PSODFN)
    62         Q
    63 PP      D PP^PSOORFI4
    64         Q
    65 KQ      K PSOQUIT,POERR("QFLG")
    66         Q
    67         ;
    68 LMDISP(ORD)     ; Backdoor ListManager Display of Flag/Unflag Informaiton
    69         N FLAG
    70         K FLAGLINE S ORD=+$G(ORD) I 'ORD Q
    71         ;
    72         I '$G(^PS(52.41,ORD,"FLG")) Q
    73         ; S X=IORVON_"Flagged"_IORVOFF
    74         D GETS^DIQ(52.41,ORD,"33;34;35;36;37;38","IE","FLAG")
    75         S L1="Flagged by "_$E(FLAG(52.41,ORD_",",34,"E"),1,30)_" on "_$$FMTE^XLFDT(FLAG(52.41,ORD_",",33,"I"),2)_": "
    76         S LEN=80-$L(L1),L1=L1_$E(FLAG(52.41,ORD_",",35,"E"),1,LEN),L2=$E(FLAG(52.41,ORD_",",35,"E"),LEN+1,999)
    77         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L1,FLAGLINE(IEN)=7
    78         I L2'="" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L2
    79         I FLAG(52.41,ORD_",",36,"I")'="" D
    80         . S L1="Unflagged by "_$E(FLAG(52.41,ORD_",",37,"E"),1,30)_" on "_$$FMTE^XLFDT(FLAG(52.41,ORD_",",36,"I"),2)_": "
    81         . S LEN=80-$L(L1),L1=L1_$E(FLAG(52.41,ORD_",",38,"E"),1,LEN),L2=$E(FLAG(52.41,ORD_",",38,"E"),LEN+1,999)
    82         . S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L1,FLAGLINE(IEN)=9
    83         . I L2'="" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L2
    84         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" "
    85         Q
     1PSOORFI5 ;VOE/mpa -finish cprs orders ; 1/15/07 5:40pm
     2 ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 2006;Build 39
     3 ; Copyright (C) 2007 WorldVistA
     4 ;
     5 ; This program is free software; you can redistribute it and/or modify
     6 ; it under the terms of the GNU General Public License as published by
     7 ; the Free Software Foundation; either version 2 of the License, or
     8 ; (at your option) any later version.
     9 ;
     10 ; This program is distributed in the hope that it will be useful,
     11 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     12 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     13 ; GNU General Public License for more details.
     14 ;
     15 ; You should have received a copy of the GNU General Public License
     16 ; along with this program; if not, write to the Free Software
     17 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     18 ;'Modified' MAS Patient Look-up Check Cross-References June 1987
     19 ;Split from PSOORFIN
     20SUCC ;
     21 D UL1^PSOORFI3,FULL^VALM1
     22 D:$P($G(^PS(52.41,+$G(ORD),0)),"^",3)'="NW"&($P($G(^(0)),"^",3)'="RNW")&($P($G(^(0)),"^",3)'="HD")&($P($G(^(0)),"^",3)'="RF")
     23 .K PSOSD("PENDING",$S('$G(OID):$P(^PS(50.7,$P(OR0,"^",8),0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,$P(OR0,"^",8),0),"^",2),0),"^"),1:$P(^PSDRUG($P(OR0,"^",9),0),"^")))
     24 S:$G(POERR("DFLG")) POERR("QFLG")=1 K POERR("DFLG"),PSONEW,ACP,OR0,DRET,SIG,OID,OI,PSORX("SC"),PSORX("CLINIC"),PSODRUG
     25 Q
     26LBL ;Begin DAOU
     27 S PSOFROM="NEW" D ^PSORXL
     28 K PSORX("PSOL"),PPL,RXRS
     29 ;End  5/4/2005
     30 Q
     31CHK ;
     32 D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) W !,$C(7),"Outpatient Division MUST be selected!",! G EX^PSOORFIN
     33 D INST1^PSOORFI2
     34 S PSZCNT=0 F PSZZI=0:0 S PSZZI=$O(^PS(59,PSZZI)) Q:'PSZZI  S PSZCNT=PSZCNT+1
     35 S TC=0 F TO=0:0 S TO=$O(^PS(52.41,"AOR",TO)) Q:'TO  F TZ=0:0 S TZ=$O(^PS(52.41,"AOR",TO,TZ)) Q:'TZ  F PSTZ=0:0 S PSTZ=$O(^PS(52.41,"AOR",TO,TZ,PSTZ)) Q:'PSTZ  S TC=TC+1
     36 W !!?10,$C(7),"Orders to be completed"_$S(PSZCNT=1:": ",1:" for all divisions: ")_TC,! Q:'TC
     37 D SUMM^PSOORNE1 K PSZZI,PSZCNT,PSTZ
     38 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFIN.m

    r613 r623  
    1 PSOORFIN        ;BIR/SAB-finish cprs orders ;12/21/04 3:24pm
    2         ;;7.0;OUTPATIENT PHARMACY;**7,15,27,32,44,46,84,106,111,117,131,146,139,195,225**;DEC 1997;Build 29
    3         ;PSSLOCK-2789,PSDRUG-221,50.7-2223,55-2228,50.606-2174
    4         D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) D MSG^PSODPT G EX
    5         D INST^PSOORFI2 I $G(PSOIQUIT) K PSOIQUIT G EX
    6         I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1
    7         S (PSOFIN,POERR)=1
    8         K PSOBCK,MEDA,MEDP,SRT,DIR D KQ
    9         S DIR("?")="^D ST^PSOORFI1",DIR("A")="Select By",DIR("B")="PATIENT",DIR(0)="SMB^PA:PATIENT;RT:ROUTE;PR:PRIORITY;CL:CLINIC;FL:FLAG;E:EXIT"
    10         D ^DIR I $D(DIRUT)!(Y="E") G EX
    11         G:Y="PA" PAT G:Y="PR" PRI^PSOORFI5 G:Y="CL" ^PSOORFI3 G:Y="FL" FLG^PSOORFI5
    12         K DIR S PSOSORT="ROUTE"
    13         S DIR("?")="^D RT^PSOORFI1",DIR("A")="Route",DIR(0)="SBM^W:WINDOW;M:MAIL;C:CLINIC;E:EXIT",DIR("B")="WINDOW"
    14         D ^DIR G:$D(DIRUT)!(Y="E") EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y
    15         S LG=0,PATA=0 F  S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG")))  F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG")))  D
    16         .Q:$P($G(^PS(52.41,PSOD,0)),"^",23)
    17         .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2)  S PAT=$P(^PS(52.41,PSOD,0),"^",2)
    18         .I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL
    19         .I '$O(^PS(52.41,"AC",PAT,PSRT,0)) S PSOLK=1,PAT(PAT)=PAT Q
    20         .D RTE^PSOORFI2 I $G(PSZFIN) S PSOLK=1,PAT(PAT)=PAT Q
    21         .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
    22         .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP Q
    23         .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
    24         .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
    25         .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
    26         .D PP S ORD=0 D @PSRT S PAT(PAT)=PAT
    27         .S X=PAT D ULP
    28         K POERR("QFLG"),PSOQFLG,PSOPTPST,MAIL,WIN,CLI I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL
    29         I $G(PSOQUIT) K PSOQUIT D EX G PSOORFIN
    30 EX      D EX^PSOORFI1
    31         Q
    32 W       D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S MAIL=1
    33         Q:$G(POERR("QFLG"))  I $G(MAIL) S ORD=0 D
    34         .D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG")))  D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
    35         .Q:$G(POERR("QFLG"))
    36         .D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG")))  D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
    37         Q
    38 M       D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S WIN=1
    39         Q:$G(POERR("QFLG"))  I $G(WIN) S ORD=0 D
    40         .D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD
    41         .Q:$G(POERR("QFLG"))
    42         .D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG")))  D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
    43         Q
    44 C       D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S CLI=1
    45         Q:$G(POERR("QFLG"))  I $G(CLI) S ORD=0 D
    46         .D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD
    47         .Q:$G(POERR("QFLG"))
    48         .D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG")))  D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
    49         Q
    50 PAT     W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="PATIENT"
    51         S DIR("?")="^D PT^PSOORFI1",DIR("A")="All Patients or Single Patient",DIR(0)="SBM^A:ALL;S:SINGLE;E:EXIT",DIR("B")="SINGLE"
    52         D ^DIR K DIR G:$D(DIRUT)!(Y="E") EX I Y="S" S PSOSORT=PSOSORT_"^"_"SINGLE" G SPAT
    53         S PSOSORT=PSOSORT_"^ALL"
    54         S LG=0,PATA=0 F  S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG")))  F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG")))  D
    55         .Q:'$D(^PS(52.41,PSOD,0))!($P($G(^PS(52.41,PSOD,0)),"^",23))
    56         .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2)  S PAT=$P(^PS(52.41,PSOD,0),"^",2)
    57         .I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL
    58         .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
    59         .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG,PSOQQ Q
    60         .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
    61         .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
    62         .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
    63         .S PAT(PAT)=PAT
    64         .F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG")))!($G(PSOQQ))  D
    65         ..I '$P($G(^PS(52.41,ORD,0)),"^",23) D PP,LK1,ORD
    66         .S X=PAT D ULP K PSOQQ
    67         I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL
    68         I $G(PSOQUIT) K PSOQUIT D EX G PSOORFIN
    69         G EX
    70 SPAT    K MEDA,MEDP,PSOQFLG,PSORX("FN") D KQ,KV^PSOVER1
    71         S DIR(0)="FO^2:30",DIR("A")="Select Patient",DIR("?")="^D HELP^PSOORFI2" D ^DIR I $E(X)="?" G SPAT
    72         G:$D(DIRUT) EX D KV^PSOVER1
    73         S DIC(0)="EQM",DIC=2,DIC("S")="I $D(^PS(52.41,""AOR"",+Y,PSOPINST))"
    74         D ^DIC K DIC G:"^"[X EX G:Y=-1 SPAT S (PSODFN,PAT)=+Y,PSOFINY=Y
    75         D LK I $G(POERR("QFLG")) G SPAT
    76         N SNGLPAT S SNGLPAT=1
    77         D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSOFINY I $G(MEDP) D SPL D OERR^PSORX1 D:$O(PSORX("PSOL",0))!($D(RXRS)) LBL S PSOFIN=1,X=PSOPTLOK D KLLP,ULP,KLL G SPAT
    78         D PP,SDFN,POST^PSOORFI1 D:$G(PSOQFLG)  G:$G(PSOQFLG) EX I $G(PSOQUIT) S:$G(PSOQUIT) POERR("QFLG")=1 S X=PAT D ULP G SPAT
    79         .S X=PAT D ULP
    80         S ORD=0 F  S ORD=$O(^PS(52.41,"P",PAT,ORD)) Q:'ORD!($G(POERR("QFLG")))  D:'$P($G(^PS(52.41,ORD,0)),"^",23)
    81         .D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE")&($P(^(0),"^",3)'="HD") LK1,ORD
    82         I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL
    83         S PSOFIN=1,X=PAT D ULP G SPAT
    84 ORD     I $G(PSOBCK) N LST,ORN
    85         E  S PSOLOUD=1 D:$P($G(^PS(55,PAT,0)),"^",6)'=2 EN^PSOHLUP(PAT) K PSOLOUD
    86         K DRET,SIG,^TMP("PSORXDC",$J) Q:'$D(^PS(52.41,ORD,0))
    87         I $G(PSOFIN),$P($G(^PS(52.41,ORD,"INI")),"^")'=$G(PSOPINST) Q
    88         D L1^PSOORFI3 I '$G(PSOMSG) K PSOMSG Q
    89         I '$D(^PS(52.41,ORD,0)) K PSOMSG Q
    90         K DRET,SIG,PSOPRC,PHI,PRC,PSOSIGFL,OBX,PSOMSG S PSOFDR=1,OR0=^PS(52.41,ORD,0),OI=$P(OR0,"^",8),PSORX("SC")=$P(OR0,"^",16)
    91         I $O(^PS(52.41,ORD,2,0)) S PHI=^PS(52.41,ORD,2,0),T=0 F  S T=$O(^PS(52.41,ORD,2,T)) Q:'T  S PHI(T)=^PS(52.41,ORD,2,T,0)
    92         I $P($G(^PS(52.41,ORD,"EXT")),"^")'="" K PHI I $O(^PS(52.41,ORD,"SIG",0)) S PHI=$G(^PS(52.41,ORD,"SIG",0)),T=0 F  S T=$O(^PS(52.41,ORD,"SIG",T)) Q:'T  S PHI(T)=$G(^PS(52.41,ORD,"SIG",T,0))
    93         I $O(^PS(52.41,ORD,3,0)) S PRC=^PS(52.41,ORD,3,0),T=0 F  S T=$O(^PS(52.41,ORD,3,T)) Q:'T  S PRC(T)=^PS(52.41,ORD,3,T,0)
    94         I $P(OR0,"^",24),($P(OR0,"^",3)="RNW"!($P(OR0,"^",3)="NW")) N PKI,PKI1,PKIR,PKIE S PKI=0 D CER^PSOPKIV1 Q:PKI<1
    95         I $P(OR0,"^",3)="RNW",$D(^PSRX(+$P(OR0,"^",21),0)) D  G SUCC ;process renews
    96         .K PSOREEDT S (PSOORRNW,PSOFDR)=1,PSORENW("OIRXN")=$P(OR0,"^",21),PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"))=0 D ^PSOORRNW,SQR
    97         I $P(OR0,"^",3)="RF",$D(^PSRX(+$P(OR0,"^",19),0)) D RF^PSOORFI2 G SUCC
    98         N PSODRUG,PSONEW S PSOFROM="PENDING" D:'$G(PSOTPBFG) DSPL^PSOTPCAN(ORD) D DSPL^PSOORFI1,SQN^PSOORFI3
    99 SUCC    ;
    100         D UL1^PSOORFI3,FULL^VALM1
    101         D:$P($G(^PS(52.41,+$G(ORD),0)),"^",3)'="NW"&($P($G(^(0)),"^",3)'="RNW")&($P($G(^(0)),"^",3)'="HD")&($P($G(^(0)),"^",3)'="RF")
    102         .K PSOSD("PENDING",$S('$G(OID):$P(^PS(50.7,$P(OR0,"^",8),0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,$P(OR0,"^",8),0),"^",2),0),"^"),1:$P(^PSDRUG($P(OR0,"^",9),0),"^")))
    103         S:$G(POERR("DFLG")) POERR("QFLG")=1 K POERR("DFLG"),PSONEW,ACP,OR0,DRET,SIG,OID,OI,PSORX("SC"),PSORX("CLINIC"),PSODRUG
    104         Q
    105 LBL     S PSOFROM="NEW" D ^PSORXL K PSORX("PSOL"),PPL,RXRS
    106         D:$D(BINGCRT)&($D(BINGRTE)&($D(DISGROUP))) ^PSOBING1 K BINGCRT,BINGRTE,PSONEW,BBFLG,BBRX
    107         Q
    108 CHK     ;
    109         D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) W !,$C(7),"Outpatient Division MUST be selected!",! G EX
    110         D INST1^PSOORFI2
    111         S PSZCNT=0 F PSZZI=0:0 S PSZZI=$O(^PS(59,PSZZI)) Q:'PSZZI  S PSZCNT=PSZCNT+1
    112         S TC=0 F TO=0:0 S TO=$O(^PS(52.41,"AOR",TO)) Q:'TO  F TZ=0:0 S TZ=$O(^PS(52.41,"AOR",TO,TZ)) Q:'TZ  F PSTZ=0:0 S PSTZ=$O(^PS(52.41,"AOR",TO,TZ,PSTZ)) Q:'PSTZ  S TC=TC+1
    113         W !!?10,$C(7),"Orders to be completed"_$S(PSZCNT=1:": ",1:" for all divisions: ")_TC,! Q:'TC
    114         D SUMM^PSOORNE1 K PSZZI,PSZCNT,PSTZ
    115         Q
    116 S       D S^PSOORFI2 Q
    117         ;
    118 E       D E^PSOORFI2 Q
    119         ;
    120 R       D R^PSOORFI2 Q
    121         ;
    122 LK      D LOCK^PSOORFI1
    123         Q
    124 LK1     D LOCK1^PSOORFI1 Q
    125 QU      I $G(PSOQUIT) S POERR("QFLG")=1 K PSOQUIT
    126         S:$G(PSOQFLG) PAT(PAT)=PAT
    127         Q
    128 ULP     K PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
    129         D CLEAN^PSOVER1
    130         I '$G(X) Q
    131         D UL^PSSLOCK(X) Q
    132 KLL     K PSOPTLOK Q
    133 KLLP    K PSONOLCK Q
    134 SPL     D SPL^PSOORFI4 Q
    135 SDFN    S PSODFN=+$G(PSODFN) Q
    136 PP      D PP^PSOORFI4 Q
    137 KQ      K PSOQUIT,POERR("QFLG") Q
    138 SQR     ;
    139         K PSOORRNW,PSOOPT,PSOREEDT,PSOQUIT S POERR("DFLG")=0
    140         Q
     1PSOORFIN ;BIR/SAB-finish cprs orders ;5/14/07  09:47
     2 ;;7.0;OUTPATIENT PHARMACY;**7,15,27,32,44,46,84,106,111,117,131,146,139,195,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VistA
     4 ; Copyright (C) GNU GPL 2007 WorldVistA
     5 ;
     6 ;PSSLOCK-2789,PSDRUG-221,50.7-2223,55-2228,50.606-2174
     7 I $G(PSOAFYN)'="Y" D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) D MSG^PSODPT G EX ;vfah
     8 I $G(PSOAFYN)="Y" D:'$D(PSOPAR) ^PSOAFSET I '$D(PSOPAR) D MSG^PSODPT G EX  ;vfah
     9 D INST^PSOORFI2 I $G(PSOIQUIT) K PSOIQUIT G EX
     10 I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1
     11 I $G(PSOAFYN)'="Y" S (PSOFIN,POERR)=1 K PSOBCK,MEDA,MEDP,SRT,DIR D KQ S DIR("?")="^D ST^PSOORFI1",DIR("A")="Select By",DIR("B")="PATIENT",DIR(0)="SMB^PA:PATIENT;RT:ROUTE;PR:PRIORITY;CL:CLINIC;E:EXIT" D ^DIR I $D(DIRUT)!(Y="E") G EX ;vfah
     12 I $G(PSOAFYN)'="Y" S (PSOFIN,POERR)=1 K PSOBCK,MEDA,MEDP,SRT,DIR D KQ ;vfah
     13 I $G(PSOAFYN)="Y" S Y="PA" ;vfah
     14 G:Y="PA" PAT G:Y="PR" PRI G:Y="CL" ^PSOORFI3
     15 K DIR S PSOSORT="ROUTE"
     16 S DIR("?")="^D RT^PSOORFI1",DIR("A")="Route",DIR(0)="SBM^W:WINDOW;M:MAIL;C:CLINIC;E:EXIT",DIR("B")="WINDOW"
     17 D ^DIR G:$D(DIRUT)!(Y="E") EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y
     18 I $G(PSOAFYN)="Y" S PSOSORT="ROUTE^WINDOW",PSRT="WINDOW" ;vfah
     19 S LG=0,PATA=0 F  S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG")))  F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG")))  D
     20 .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2)  S PAT=$P(^PS(52.41,PSOD,0),"^",2)
     21 .I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL
     22 .I '$O(^PS(52.41,"AC",PAT,PSRT,0)) S PSOLK=1,PAT(PAT)=PAT Q
     23 .D RTE^PSOORFI2 I $G(PSZFIN) S PSOLK=1,PAT(PAT)=PAT Q
     24 .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
     25 .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP Q
     26 .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
     27 .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
     28 .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
     29 .D PP S ORD=0 D @PSRT S PAT(PAT)=PAT
     30 .S X=PAT D ULP
     31 K POERR("QFLG"),PSOQFLG,PSOPTPST,MAIL,WIN,CLI I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL
     32 I $G(PSOQUIT) K PSOQUIT D EX G PSOORFIN
     33EX D EX^PSOORFI1
     34 Q
     35W D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S MAIL=1
     36 Q:$G(POERR("QFLG"))  I $G(MAIL) S ORD=0 D
     37 .D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG")))  D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
     38 .Q:$G(POERR("QFLG"))
     39 .D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG")))  D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
     40 Q
     41M D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S WIN=1
     42 Q:$G(POERR("QFLG"))  I $G(WIN) S ORD=0 D
     43 .D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD
     44 .Q:$G(POERR("QFLG"))
     45 .D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG")))  D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
     46 Q
     47C D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S CLI=1
     48 Q:$G(POERR("QFLG"))  I $G(CLI) S ORD=0 D
     49 .D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG")))  I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD
     50 .Q:$G(POERR("QFLG"))
     51 .D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG")))  D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
     52 Q
     53PAT I $G(PSOAFYN)'="Y" W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="PATIENT" ;vfah
     54 I $G(PSOAFYN)="Y" K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="PATIENT" ;vfah
     55 I $G(PSOAFYN)'="Y" S DIR("?")="^D PT^PSOORFI1",DIR("A")="All Patients or Single Patient",DIR(0)="SBM^A:ALL;S:SINGLE;E:EXIT",DIR("B")="SINGLE" ;vfah
     56 I $G(PSOAFYN)'="Y" D ^DIR K DIR G:$D(DIRUT)!(Y="E") EX I Y="S" S PSOSORT=PSOSORT_"^"_"SINGLE" G SPAT ;vfah
     57 I $G(PSOAFYN)="Y" S PSOSORT=PSOSORT_"^"_"SINGLE" G SPAT ;vfah
     58 S PSOSORT=PSOSORT_"^ALL"
     59 S LG=0,PATA=0 F  S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG")))  F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG")))  D:$D(^PS(52.41,PSOD,0))
     60 .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2)  S PAT=$P(^PS(52.41,PSOD,0),"^",2)
     61 .I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL
     62 .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
     63 .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG,PSOQQ Q
     64 .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
     65 .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
     66 .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
     67 .S PAT(PAT)=PAT
     68 .F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG")))!($G(PSOQQ))  D
     69 ..D PP,LK1,ORD
     70 .S X=PAT D ULP K PSOQQ
     71 I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL
     72 I $G(PSOQUIT) K PSOQUIT D EX G PSOORFIN
     73 G EX
     74SPAT K MEDA,MEDP,PSOQFLG,PSORX("FN") D KQ,KV^PSOVER1
     75 ;PSOAFIN begin SPAT
     76 I $G(PSOAFDON)=1 G EX ;vfah
     77 I $G(PSOAFYN)'="Y" S DIR(0)="FO^2:30",DIR("A")="Select Patient",DIR("?")="^D HELP^PSOORFI2" D ^DIR I $E(X)="?" G SPAT ;vfah
     78 I $G(PSOAFYN)'="Y" G:$D(DIRUT) EX D KV^PSOVER1 ;vfah
     79 I $G(PSOAFYN)'="Y" S DIC(0)="EQM",DIC=2,DIC("S")="I $D(^PS(52.41,""AOR"",+Y,PSOPINST))" ;vfah
     80 I $G(PSOAFYN)'="Y" D ^DIC K DIC G:"^"[X EX G:Y=-1 SPAT S (PSODFN,PAT)=+Y,PSOFINY=Y ;vfah
     81 ;PSOAFIN end SPAT
     82 D LK I $G(POERR("QFLG")) G SPAT
     83 N SNGLPAT S SNGLPAT=1
     84 D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSOFINY I $G(MEDP) D SPL D OERR^PSORX1 D:$O(PSORX("PSOL",0))!($D(RXRS)) LBL S PSOFIN=1,X=PSOPTLOK D KLLP,ULP,KLL G SPAT
     85 D PP,SDFN,POST^PSOORFI1 D:$G(PSOQFLG)  G:$G(PSOQFLG) EX I $G(PSOQUIT) S:$G(PSOQUIT) POERR("QFLG")=1 S X=PAT D ULP G SPAT
     86 .S X=PAT D ULP
     87 I PSOAFYN'="Y" S ORD=0 F  S ORD=$O(^PS(52.41,"P",PAT,ORD)) Q:'ORD!($G(POERR("QFLG")))  D  ;vhah
     88 .D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE")&($P(^(0),"^",3)'="HD") LK1,ORD
     89 I PSOAFYN="Y" S ORD=0,ORD=$O(^PS(52.41,"B",+ORDERID,ORD)) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE")&($P(^(0),"^",3)'="HD") LK1,ORD ;vfah
     90 I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL
     91 I $G(PSOAFYN)="Y" S PSOAFDON=1 ;vfah
     92 S PSOFIN=1,X=PAT D ULP G SPAT
     93ORD I $G(PSOBCK) N LST,ORN
     94 E  S PSOLOUD=1 D:$P($G(^PS(55,PAT,0)),"^",6)'=2 EN^PSOHLUP(PAT) K PSOLOUD
     95 K DRET,SIG,^TMP("PSORXDC",$J) Q:'$D(^PS(52.41,ORD,0))
     96 I $G(PSOFIN),$P($G(^PS(52.41,ORD,"INI")),"^")'=$G(PSOPINST) Q
     97 D L1^PSOORFI3 I '$G(PSOMSG) K PSOMSG Q
     98 I '$D(^PS(52.41,ORD,0)) K PSOMSG Q
     99 K DRET,SIG,PSOPRC,PHI,PRC,PSOSIGFL,OBX,PSOMSG S PSOFDR=1,OR0=^PS(52.41,ORD,0),OI=$P(OR0,"^",8),PSORX("SC")=$P(OR0,"^",16)
     100 I $O(^PS(52.41,ORD,2,0)) S PHI=^PS(52.41,ORD,2,0),T=0 F  S T=$O(^PS(52.41,ORD,2,T)) Q:'T  S PHI(T)=^PS(52.41,ORD,2,T,0)
     101 I $P($G(^PS(52.41,ORD,"EXT")),"^")'="" K PHI I $O(^PS(52.41,ORD,"SIG",0)) S PHI=$G(^PS(52.41,ORD,"SIG",0)),T=0 F  S T=$O(^PS(52.41,ORD,"SIG",T)) Q:'T  S PHI(T)=$G(^PS(52.41,ORD,"SIG",T,0))
     102 I $O(^PS(52.41,ORD,3,0)) S PRC=^PS(52.41,ORD,3,0),T=0 F  S T=$O(^PS(52.41,ORD,3,T)) Q:'T  S PRC(T)=^PS(52.41,ORD,3,T,0)
     103 I $P(OR0,"^",24),($P(OR0,"^",3)="RNW"!($P(OR0,"^",3)="NW")) N PKI,PKI1,PKIR,PKIE S PKI=0 D CER^PSOPKIV1 Q:PKI<1
     104 I $P(OR0,"^",3)="RNW",$D(^PSRX(+$P(OR0,"^",21),0)) D  G SUCC ;process renews
     105 .K PSOREEDT S (PSOORRNW,PSOFDR)=1,PSORENW("OIRXN")=$P(OR0,"^",21),PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"))=0 D ^PSOORRNW,SQR^PSOORFI3
     106 I $P(OR0,"^",3)="RF",$D(^PSRX(+$P(OR0,"^",19),0)) D RF^PSOORFI2 G SUCC
     107 N PSODRUG,PSONEW S PSOFROM="PENDING" D:'$G(PSOTPBFG) DSPL^PSOTPCAN(ORD) D DSPL^PSOORFI1:'$D(ZTSK),SQN^PSOORFI3
     108SUCC ;
     109 D SUCC^PSOORFI5
     110 Q
     111 ;
     112LBL ;
     113 D LBL^PSOORFI5
     114 Q
     115 ;
     116CHK ;
     117 D CHK^PSOORFI5
     118 Q
     119 ;
     120PRI K DIR S PSOSORT="PRIORITY"
     121 S DIR("A")="Select Priority",DIR(0)="SBM^S:STAT;E:EMERGENCY;R:ROUTINE",DIR("B")="ROUTINE"
     122 D ^DIR G:$D(DIRUT) EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y
     123 S LG=0,PATA=0 F  S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG")))  F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG")))  D
     124 .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2)  S PAT=$P(^PS(52.41,PSOD,0),"^",2)
     125 .I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL
     126 .I '$O(^PS(52.41,"AP",PAT,PSRT,0)) S PSOLK=1,PAT(PAT)=PAT Q
     127 .D PRI^PSOORFI2 I $G(PSZFIN) S PSOLK=1,PAT(PAT)=PAT Q
     128 .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
     129 .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP Q
     130 .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
     131 .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
     132 .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
     133 .D PP S ORD=0 D @PSRT S PAT(PAT)=PAT
     134 .S X=PAT D ULP
     135 I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL
     136 I $G(PSOQUIT) K PSOQUIT D EX G PSOORFIN
     137 G EX
     138 Q
     139S D S^PSOORFI2 Q
     140 ;
     141E D E^PSOORFI2 Q
     142 ;
     143R D R^PSOORFI2 Q
     144 ;
     145LK D LOCK^PSOORFI1
     146 Q
     147LK1 D LOCK1^PSOORFI1 Q
     148QU I $G(PSOQUIT) S POERR("QFLG")=1 K PSOQUIT
     149 S:$G(PSOQFLG) PAT(PAT)=PAT
     150 Q
     151ULP K PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
     152 D CLEAN^PSOVER1
     153 I '$G(X) Q
     154 D UL^PSSLOCK(X) Q
     155KLL K PSOPTLOK Q
     156KLLP K PSONOLCK Q
     157SPL D SPL^PSOORFI4 Q
     158SDFN S PSODFN=+$G(PSODFN) Q
     159PP D PP^PSOORFI4 Q
     160KQ K PSOQUIT,POERR("QFLG") Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE1.m

    r613 r623  
    1 PSOORNE1        ;BIR/SAB - Display new orders from backdoor ; 2/14/08 10:30am
    2         ;;7.0;OUTPATIENT PHARMACY;**11,21,27,32,37,46,71,94,104,117,133,148,279**;DEC 1997;Build 9
    3         ;External reference to ^PS(55 is supported by DBIA 2228
    4 EN(PSONEW)      D DSPL^PSOORNE3,^PSOLMPO2
    5         Q
    6 EDT     N FLD,LST K DIR,DUOUT,DIRUT S DIR("A")="Select Field to Edit by number",DIR(0)="LO^1:14" D ^DIR I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DTOUT S VALMBCK="" Q
    7 EDTSEL  S:'$G(COPY) PSOEDIT=1 S (PSONEW("DFLG"),PSONEW("FIELD"),PSONEW3)=0
    8         I +Y S LST=Y D HLDHDR^PSOLMUTL D  Q:$G(PSORX("DFLG"))!($G(PSORX("QFLG")))  S VALMBCK="R" G DSPL^PSOORNE3
    9         .F FLD=1:1:$L(LST,",") Q:$P(LST,",",FLD)']""  D @(+$P(LST,",",FLD)) Q:$G(PSODIR("DFLG"))!($G(PSODIR("QFLG")))
    10         E  S VALMBCK="" D FULL^VALM1
    11         D RDSPL G DSPL^PSOORNE3
    12         Q
    13 ACP     K VALMSG,DIR,PSORX("DFLG") D VER I $G(PSONEW2("QFLG"))!($G(PSORX("DFLG"))) S VALMBCK="Q" K PSONEW2 Q
    14         N PSONOBCK S PSONOBCK=$S($G(PSOSIGFL):1,1:0)
    15         D NOOR^PSONEW I $D(DIRUT) S PSONEW("DFLG")=1 K DIR,X,Y,DIRUT,DUOUT,DTOUT Q
    16         D RXNCHK,RDSPL
    17         I $G(PSONEW("QFLG")) S PSONEW("DFLG")=1 K DIR,X,Y,DIRUT,DUOUT,DTOUT Q
    18         D DISPLAY^PSONEW2
    19         D ^PSONEWG I $G(PSOCPZ("DFLG")) S PSONEW("DFLG")=1 K PSOANSQ,DIR,X,Y,DIRUT,DUOUT,DTOUT,PSOCPZ("DFLG"),PSOANSQD Q
    20         K PSOCPZ("DFLG")
    21         K DIR,DIRUT,X,Y S DIR(0)="Y",DIR("B")="YES",DIR("A")="Is this correct" D ^DIR
    22         I $D(DIRUT) S PSONEW("DFLG")=1 K PSOANSQ,PSOANSQD,DIR,X,Y,DIRUT,DUOUT,DTOUT Q
    23         I 'Y S VALMBCK="R" K PSOANSQ,DIR,X,Y,DIRUT,DUOUT,DTOUT D DSPL^PSOORNE3 Q
    24         W "..." K PSOANSQD,DIR,X,Y,DIRUT,DUOUT,DTOUT D DCORD^PSONEW2
    25         I $G(NCPDPFLG) D NCPDP^PSOORED6
    26         K:$G(COPY)!($G(PSOSIGFL)) PRC,PHI
    27         S:'$G(PSOID) PSOID=DT S (PSORX("FN"),PSONEW("POE"))=1 D EN^PSON52(.PSONEW) ; Files entry in File 52
    28         I $G(PSOBEDT) D
    29         .I '$D(^TMP("PSOBEDT",$J,PSODFN,0)) S ^TMP("PSOBEDT",$J,PSODFN,0)=PSORXED("IRXN") S:$G(PSONEW("MAIL/WINDOW"))["W" ^TMP("PSOBEDT",$J,PSODFN,1)=1 Q
    30         .S ^TMP("PSOBEDT",$J,PSODFN,0)=^TMP("PSOBEDT",$J,PSODFN,0)_","_PSORXED("IRXN")
    31         .I $G(PSONEW("MAIL/WINDOW"))["W" S ^TMP("PSOBEDT",$J,PSODFN,1)=1
    32         D NPSOSD^PSOUTIL(.PSONEW) ; Adds newly added rx to PSOSD array
    33         D ^PSOBUILD S VALMBCK="Q"
    34         K PSONEW("# OF REFILLS"),PSONEW("DAYS SUPPLY"),SDA,SEG1,SSN1,STA,Z4,ZDA
    35         Q:$G(COPY)  S PSONEW("DFLG")=0
    36         Q
    37 VER     I $G(PSOAC),$G(PSODRUG("NAME"))']"" D FULL^VALM1,2^PSOORNW1
    38         I $G(PSODRUG("NAME"))']"" S VALMSG="A Dispense Drug Must be Chosen!" S PSONEW2("QFLG")=1 Q
    39         I '$G(PSONEW("ENT")) W !,"Dosing Instruction Missing!!",! D  I PSONEW("DFLG")=1 S PSONEW2("QFLG")=1 Q
    40         .S PSOORRNW=1
    41         .K VALMSG D FULL^VALM1 W !,"Drug: "_PSODRUG("NAME")
    42         .I $O(SIG(0)) F I=1:1 Q:$G(SIG(I))']""  W !,SIG(I)
    43         .E   I $G(^PSRX(PSONEW("OIRXN"),"SIG"))]"" S X=$P(^PSRX(PSONEW("OIRXN"),"SIG"),"^") D SIGONE^PSOHELP W !,$E($G(INS1),2,250)
    44         .W ! D 5 K PSOORRNW I PSONEW("DFLG")=1 D M3 Q
    45         .D 6 D:PSONEW("DFLG")=1 M3
    46         D:$G(COPY) PROV^PSOUTIL(.PSORENW) I PSONEW("DFLG")=1 S PSONEW2("QFLG")=1 Q
    47         D FULL^VALM1,POST^PSODRG:'$G(PSOSIGFL) K PSONOOR I $G(PSORX("DFLG")) S VALMBCK="Q" Q
    48         I +$G(PSEXDT) D
    49         .D FULL^VALM1 S:$G(PSONEW("MAIL/WINDOW"))["W" BINGCRT="Y",BINGRTE="W"
    50         .D:+$G(PSEXDT)
    51         ..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_"."
    52         .S PSONEW2("QFLG")=1,VALMBCK="R" D PAUSE^VALM1
    53         Q
    54 1       I $G(PSOSIGFL) S PSOAC=1 D 2^PSOORNW1 K PSOAC D RDSPL G DSPL^PSOORNE3 Q
    55         D 6^PSOBKDED D RDSPL G DSPL^PSOORNE3 Q
    56         ;
    57 2       D 3^PSOBKDED Q
    58         ;
    59 3       D 1^PSOBKDED Q
    60         ;
    61 4       D 2^PSOBKDED Q
    62         ;
    63 5       I '$G(PSODRUG("IEN")) W !,"DRUG NAME REQUIRED!" D 2^PSOORNW1 I '$G(PSODRUG("IEN")) S VALMSG="No Dispense Drug Selected" Q
    64         W !!,"Drug: "_PSODRUG("NAME") D 10^PSOBKDED Q
    65         ;
    66 6       D INS^PSOBKDED Q:$G(PSONEW("DFLG"))  I $P($G(^PS(55,PSODFN,"LAN")),"^") D SINS^PSODIR(.PSONEW)
    67         Q
    68         ;
    69 7       D 8^PSOBKDED Q
    70         ;
    71 8       D 7^PSOBKDED Q
    72         ;
    73 9       D 9^PSOBKDED Q
    74         ;
    75 10      D 12^PSOBKDED Q
    76         ;
    77 11      D 5^PSOBKDED Q
    78         ;
    79 12      D 4^PSOBKDED Q
    80         ;
    81 13      D 11^PSOBKDED Q
    82         ;
    83 14      D 13^PSOBKDED Q
    84         ;
    85 SUMM    ;print break down of orders to be finished
    86         K ^TMP($J,"PSOCZT"),^TMP($J,"PSODPAT"),PAT,RT,DIR,DUOUT,DIRUT,PSZLQUIT
    87         S DIR("A")="Do you want an Order Summary",DIR(0)="Y",DIR("B")="No"
    88         D ^DIR K DIR I 'Y!($D(DIRUT)) K Y,X,DIRUT Q
    89         K PSOINPRT,DIQ,^UTILITY("DIQ1",$J) I $G(PSOPINST) S DA=PSOPINST,DIC=4,DIQ(0)="E",DR=".01" D EN^DIQ1 S PSOINPRT=$G(^UTILITY("DIQ1",$J,4,DA,.01,"E")) K ^UTILITY("DIQ1",$J),DA,DR,DIC,DIQ
    90         I $D(^PS(52.41,"ACL")) N PSOCLSUM D SUMMCL I $G(PSOCLSUM) K PSOINPRT Q
    91         F PSI=0:0 S PSI=$O(^PS(52.41,"AOR",PSI)) Q:'PSI  F PSID=0:0 S PSID=$O(^PS(52.41,"AOR",PSI,PSID)) Q:'PSID  F PIN=0:0 S PIN=$O(^PS(52.41,"AOR",PSI,PSID,PIN)) Q:'PIN  D
    92         .I '$D(^TMP($J,"PSOCZT",PSID,"PAT")) F PZA="PAT","WIN","MAIL","CLIN" S ^TMP($J,"PSOCZT",PSID,PZA)=0
    93         .I '$D(^TMP($J,"PSODPAT",PSID,PSI)) S ^TMP($J,"PSODPAT",PSID,PSI)=1,^TMP($J,"PSOCZT",PSID,"PAT")=^TMP($J,"PSOCZT",PSID,"PAT")+1
    94         .S PZROUT=$P($G(^PS(52.41,PIN,0)),"^",17) I PZROUT'="" S ^TMP($J,"PSOCZT",PSID,$S(PZROUT="C":"CLIN",PZROUT="M":"MAIL",1:"WIN"))=^TMP($J,"PSOCZT",PSID,$S(PZROUT="C":"CLIN",PZROUT="M":"MAIL",1:"WIN"))+1
    95         W @IOF W !?20,"Pending Outpatient Medication Orders",! I $G(PSZCNT)>1 W ?20,"(signed in under "_$G(PSOINPRT)_")",!
    96         F PSOINL=0:0 S PSOINL=$O(^TMP($J,"PSOCZT",PSOINL)) Q:'PSOINL!($G(PSZLQUIT))  D
    97         .I ($Y+6)>IOSL K DIR S DIR(0)="E" D ^DIR K DIR D:$G(Y)  I '$G(Y) S PSZLQUIT=1 W ! Q
    98         ..W @IOF W !?20,"Pending Outpatient Medication Orders",! I $G(PSZCNT)>1 W ?20,"(signed in under "_$G(PSOINPRT)_")",!
    99         .K ^UTILITY("DIQ1",$J),DIQ,PSOINPRX S DA=$G(PSOINL),DIC=4,DIQ(0)="E",DR=".01" D EN^DIQ1 S PSOINPRX=$G(^UTILITY("DIQ1",$J,4,DA,.01,"E")) K ^UTILITY("DIQ1",$J),DA,DR,DIC,DIQ
    100         .;PSO*7*279 Change division to Institution
    101         .W !,"Institution: ",$G(PSOINPRX)
    102         .W !,"Patients: "_$G(^TMP($J,"PSOCZT",PSOINL,"PAT"))_"  Window: "_$G(^("WIN"))_"  Mail: "_$G(^("MAIL"))_"  Clinic: "_$G(^("CLIN")),!
    103         K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
    104         K ^TMP($J,"PSOCZT"),^TMP($J,"PSODPAT"),RT,PSOINPRT,PSOINPRX,PSI,PSID,PIN,PZA,PZROUT,PSOINL,PSZLQUIT
    105         Q
    106 SUMMCL  ;
    107         ;PSO*7*279 Change Division to Institution
    108         W ! K DIR S DIR(0)="SMB^I:INSTITUTION;C:CLINIC",DIR("A")="Do you want the summary by Institution or Clinic",DIR("B")="Institution",DIR("?")=" "
    109         S DIR("?",1)="Enter 'I' to see the summary by Institution, and within Institution the orders",DIR("?",2)="shown by Mail, Window, or Administered in Clinic.",DIR("?",3)="Enter 'C' to see the summary by Clinic, along with Clinic Sort Groups."
    110         D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S PSOCLSUM=1 Q
    111         Q:$G(Y)="I"
    112         S PSOCLSUM=1
    113         K ^TMP($J,"PSOLOC"),^TMP($J,"PSOLOCP") N PSCX,PSCXL,PSLX,PSCIN,PSCPT,PSCNDE,PSNCL,PSNPAT,PSCLOUT,PSCSFLAG,PCCNT,PSOCAG
    114         F PSCX=0:0 S PSCX=$O(^PS(52.41,"ACL",PSCX)) Q:'PSCX  F PSLX=0:0 S PSLX=$O(^PS(52.41,"ACL",PSCX,PSLX)) Q:'PSLX  F PSCIN=0:0 S PSCIN=$O(^PS(52.41,"ACL",PSCX,PSLX,PSCIN)) Q:'PSCIN  S PSCPT=+$P($G(^PS(52.41,PSCIN,0)),"^",2) D:PSCPT
    115         .S PSCNDE=$G(^PS(52.41,PSCIN,0))
    116         .I $P(PSCNDE,"^",3)'="NW",$P(PSCNDE,"^",3)'="RNW",$P(PSCNDE,"^",3)'="RF" Q
    117         .I $P(PSCNDE,"^",13)="" Q
    118         .S PSNCL=+$P(PSCNDE,"^",13),PSNPAT=+$P(PSCNDE,"^",2)
    119         .I '$D(^TMP($J,"PSOLOC",PSNCL)) S ^TMP($J,"PSOLOC",PSNCL)="1^1",^TMP($J,"PSOLOCP",PSNCL,PSNPAT)="" Q
    120         .S $P(^TMP($J,"PSOLOC",PSNCL),"^",2)=$P(^TMP($J,"PSOLOC",PSNCL),"^",2)+1
    121         .I '$D(^TMP($J,"PSOLOCP",PSNCL,PSNPAT)) S $P(^TMP($J,"PSOLOC",PSNCL),"^")=$P(^TMP($J,"PSOLOC",PSNCL),"^")+1
    122         .S ^TMP($J,"PSOLOCP",PSNCL,PSNPAT)=""
    123         I '$O(^TMP($J,"PSOLOC",0)) G SUMMQ
    124         W @IOF W !?20,"Pending Outpatient Medication Orders" I $G(PSZCNT)>1 W !?20,"(signed in under "_$G(PSOINPRT)_")"
    125         F PSCXL=0:0 S PSCXL=$O(^TMP($J,"PSOLOC",PSCXL)) Q:'PSCXL!($G(PSCLOUT))  D
    126         .I ($Y+7)>IOSL D CLDIR Q:$G(PSCLOUT)
    127         .W !!,"Clinic:   ",$P($G(^SC(+PSCXL,0)),"^")
    128         .W !,"Patients: ",$P($G(^TMP($J,"PSOLOC",PSCXL)),"^"),?16,"Orders: ",$P($G(^TMP($J,"PSOLOC",PSCXL)),"^",2)
    129         .W !,"In Sort Groups:"
    130         .S (PCCNT,PSCSFLAG)=0 F PSCSORT=0:0 S PSCSORT=$O(^PS(59.8,PSCSORT)) Q:'PSCSORT!($G(PSCLOUT))  I $D(^PS(59.8,PSCSORT,1,"B",PSCXL)) S PSOCAG=0 D
    131         ..S PSCSFLAG=1 S:($Y+5)>IOSL&(PCCNT) PSOCAG=1 D:($Y+5)>IOSL&(PCCNT) CLDIR Q:$G(PSCLOUT)  W:$G(PSOCAG) !,"Clinic: "_$P($G(^SC(PSCXL,0)),"^")_"   cont." W:$G(PCCNT)>0 ! W ?16,$P($G(^PS(59.8,PSCSORT,0)),"^") S PCCNT=1
    132         .I '$G(PSCSFLAG) W ?16,"*** NO CLINIC SORT GROUPS ***"
    133         I '$G(PSCLOUT) K DIR S DIR(0)="E",DIR("A")="Press <RET> to continue"  D ^DIR K DIR
    134 SUMMQ   K ^TMP($J,"PSOLOC"),^TMP($J,"PSOLOCP")
    135         Q
    136 CLDIR   K DIR S DIR(0)="E",DIR("A")="Press <RET> to continue, '^' to exit" D ^DIR K DIR I Y'=1 S PSCLOUT=1 Q
    137         W @IOF
    138         Q
    139 RXNCHK  I $G(PSONEW("RX #"))']"" D RXNCHK^PSOORNE5
    140         Q
    141 RDSPL   D RDSPL^PSOORNE5
    142         Q
    143 M3      D M3^PSOOREDX
    144         Q
     1PSOORNE1 ;BIR/SAB - Display new orders from backdoor ;03/06/95
     2 ;;7.0;OUTPATIENT PHARMACY;**11,21,27,32,37,46,71,94,104,117,133,148**;DEC 1997
     3 ;External reference to ^PS(55 is supported by DBIA 2228
     4EN(PSONEW) D DSPL^PSOORNE3,^PSOLMPO2
     5 Q
     6EDT N FLD,LST K DIR,DUOUT,DIRUT S DIR("A")="Select Field to Edit by number",DIR(0)="LO^1:14" D ^DIR I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DTOUT S VALMBCK="" Q
     7EDTSEL S:'$G(COPY) PSOEDIT=1 S (PSONEW("DFLG"),PSONEW("FIELD"),PSONEW3)=0
     8 I +Y S LST=Y D HLDHDR^PSOLMUTL D  Q:$G(PSORX("DFLG"))!($G(PSORX("QFLG")))  S VALMBCK="R" G DSPL^PSOORNE3
     9 .F FLD=1:1:$L(LST,",") Q:$P(LST,",",FLD)']""  D @(+$P(LST,",",FLD)) Q:$G(PSODIR("DFLG"))!($G(PSODIR("QFLG")))
     10 E  S VALMBCK="" D FULL^VALM1
     11 D RDSPL G DSPL^PSOORNE3
     12 Q
     13ACP K VALMSG,DIR,PSORX("DFLG") D VER I $G(PSONEW2("QFLG"))!($G(PSORX("DFLG"))) S VALMBCK="Q" K PSONEW2 Q
     14 N PSONOBCK S PSONOBCK=$S($G(PSOSIGFL):1,1:0)
     15 D NOOR^PSONEW I $D(DIRUT) S PSONEW("DFLG")=1 K DIR,X,Y,DIRUT,DUOUT,DTOUT Q
     16 D RXNCHK,RDSPL
     17 I $G(PSONEW("QFLG")) S PSONEW("DFLG")=1 K DIR,X,Y,DIRUT,DUOUT,DTOUT Q
     18 D DISPLAY^PSONEW2
     19 D ^PSONEWG I $G(PSOCPZ("DFLG")) S PSONEW("DFLG")=1 K PSOANSQ,DIR,X,Y,DIRUT,DUOUT,DTOUT,PSOCPZ("DFLG"),PSOANSQD Q
     20 K PSOCPZ("DFLG")
     21 K DIR,DIRUT,X,Y S DIR(0)="Y",DIR("B")="YES",DIR("A")="Is this correct" D ^DIR
     22 I $D(DIRUT) S PSONEW("DFLG")=1 K PSOANSQ,PSOANSQD,DIR,X,Y,DIRUT,DUOUT,DTOUT Q
     23 I 'Y S VALMBCK="R" K PSOANSQ,DIR,X,Y,DIRUT,DUOUT,DTOUT D DSPL^PSOORNE3 Q
     24 W "..." K PSOANSQD,DIR,X,Y,DIRUT,DUOUT,DTOUT D DCORD^PSONEW2
     25 I $G(NCPDPFLG) D NCPDP^PSOORED6
     26 K:$G(COPY)!($G(PSOSIGFL)) PRC,PHI
     27 S:'$G(PSOID) PSOID=DT S (PSORX("FN"),PSONEW("POE"))=1 D EN^PSON52(.PSONEW) ; Files entry in File 52
     28 I $G(PSOBEDT) D
     29 .I '$D(^TMP("PSOBEDT",$J,PSODFN,0)) S ^TMP("PSOBEDT",$J,PSODFN,0)=PSORXED("IRXN") S:$G(PSONEW("MAIL/WINDOW"))["W" ^TMP("PSOBEDT",$J,PSODFN,1)=1 Q
     30 .S ^TMP("PSOBEDT",$J,PSODFN,0)=^TMP("PSOBEDT",$J,PSODFN,0)_","_PSORXED("IRXN")
     31 .I $G(PSONEW("MAIL/WINDOW"))["W" S ^TMP("PSOBEDT",$J,PSODFN,1)=1
     32 D NPSOSD^PSOUTIL(.PSONEW) ; Adds newly added rx to PSOSD array
     33 D ^PSOBUILD S VALMBCK="Q"
     34 K PSONEW("# OF REFILLS"),PSONEW("DAYS SUPPLY"),SDA,SEG1,SSN1,STA,Z4,ZDA
     35 Q:$G(COPY)  S PSONEW("DFLG")=0
     36 Q
     37VER I $G(PSOAC),$G(PSODRUG("NAME"))']"" D FULL^VALM1,2^PSOORNW1
     38 I $G(PSODRUG("NAME"))']"" S VALMSG="A Dispense Drug Must be Chosen!" S PSONEW2("QFLG")=1 Q
     39 I '$G(PSONEW("ENT")) W !,"Dosing Instruction Missing!!",! D  I PSONEW("DFLG")=1 S PSONEW2("QFLG")=1 Q
     40 .S PSOORRNW=1
     41 .K VALMSG D FULL^VALM1 W !,"Drug: "_PSODRUG("NAME")
     42 .I $O(SIG(0)) F I=1:1 Q:$G(SIG(I))']""  W !,SIG(I)
     43 .E   I $G(^PSRX(PSONEW("OIRXN"),"SIG"))]"" S X=$P(^PSRX(PSONEW("OIRXN"),"SIG"),"^") D SIGONE^PSOHELP W !,$E($G(INS1),2,250)
     44 .W ! D 5 K PSOORRNW I PSONEW("DFLG")=1 D M3 Q
     45 .D 6 D:PSONEW("DFLG")=1 M3
     46 D:$G(COPY) PROV^PSOUTIL(.PSORENW) I PSONEW("DFLG")=1 S PSONEW2("QFLG")=1 Q
     47 D FULL^VALM1,POST^PSODRG:'$G(PSOSIGFL) K PSONOOR I $G(PSORX("DFLG")) S VALMBCK="Q" Q
     48 I +$G(PSEXDT) D
     49 .D FULL^VALM1 S:$G(PSONEW("MAIL/WINDOW"))["W" BINGCRT="Y",BINGRTE="W"
     50 .D:+$G(PSEXDT)
     51 ..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_"."
     52 .S PSONEW2("QFLG")=1,VALMBCK="R" D PAUSE^VALM1
     53 Q
     541 I $G(PSOSIGFL) S PSOAC=1 D 2^PSOORNW1 K PSOAC D RDSPL G DSPL^PSOORNE3 Q
     55 D 6^PSOBKDED D RDSPL G DSPL^PSOORNE3 Q
     56 ;
     572 D 3^PSOBKDED Q
     58 ;
     593 D 1^PSOBKDED Q
     60 ;
     614 D 2^PSOBKDED Q
     62 ;
     635 I '$G(PSODRUG("IEN")) W !,"DRUG NAME REQUIRED!" D 2^PSOORNW1 I '$G(PSODRUG("IEN")) S VALMSG="No Dispense Drug Selected" Q
     64 W !!,"Drug: "_PSODRUG("NAME") D 10^PSOBKDED Q
     65 ;
     666 D INS^PSOBKDED Q:$G(PSONEW("DFLG"))  I $P($G(^PS(55,PSODFN,"LAN")),"^") D SINS^PSODIR(.PSONEW)
     67 Q
     68 ;
     697 D 8^PSOBKDED Q
     70 ;
     718 D 7^PSOBKDED Q
     72 ;
     739 D 9^PSOBKDED Q
     74 ;
     7510 D 12^PSOBKDED Q
     76 ;
     7711 D 5^PSOBKDED Q
     78 ;
     7912 D 4^PSOBKDED Q
     80 ;
     8113 D 11^PSOBKDED Q
     82 ;
     8314 D 13^PSOBKDED Q
     84 ;
     85SUMM ;print break down of orders to be finished
     86 K ^TMP($J,"PSOCZT"),^TMP($J,"PSODPAT"),PAT,RT,DIR,DUOUT,DIRUT,PSZLQUIT
     87 S DIR("A")="Do you want an Order Summary",DIR(0)="Y",DIR("B")="No"
     88 D ^DIR K DIR I 'Y!($D(DIRUT)) K Y,X,DIRUT Q
     89 K PSOINPRT,DIQ,^UTILITY("DIQ1",$J) I $G(PSOPINST) S DA=PSOPINST,DIC=4,DIQ(0)="E",DR=".01" D EN^DIQ1 S PSOINPRT=$G(^UTILITY("DIQ1",$J,4,DA,.01,"E")) K ^UTILITY("DIQ1",$J),DA,DR,DIC,DIQ
     90 I $D(^PS(52.41,"ACL")) N PSOCLSUM D SUMMCL I $G(PSOCLSUM) K PSOINPRT Q
     91 F PSI=0:0 S PSI=$O(^PS(52.41,"AOR",PSI)) Q:'PSI  F PSID=0:0 S PSID=$O(^PS(52.41,"AOR",PSI,PSID)) Q:'PSID  F PIN=0:0 S PIN=$O(^PS(52.41,"AOR",PSI,PSID,PIN)) Q:'PIN  D
     92 .I '$D(^TMP($J,"PSOCZT",PSID,"PAT")) F PZA="PAT","WIN","MAIL","CLIN" S ^TMP($J,"PSOCZT",PSID,PZA)=0
     93 .I '$D(^TMP($J,"PSODPAT",PSID,PSI)) S ^TMP($J,"PSODPAT",PSID,PSI)=1,^TMP($J,"PSOCZT",PSID,"PAT")=^TMP($J,"PSOCZT",PSID,"PAT")+1
     94 .S PZROUT=$P($G(^PS(52.41,PIN,0)),"^",17) I PZROUT'="" S ^TMP($J,"PSOCZT",PSID,$S(PZROUT="C":"CLIN",PZROUT="M":"MAIL",1:"WIN"))=^TMP($J,"PSOCZT",PSID,$S(PZROUT="C":"CLIN",PZROUT="M":"MAIL",1:"WIN"))+1
     95 W @IOF W !?20,"Pending Outpatient Medication Orders",! I $G(PSZCNT)>1 W ?20,"(signed in under "_$G(PSOINPRT)_")",!
     96 F PSOINL=0:0 S PSOINL=$O(^TMP($J,"PSOCZT",PSOINL)) Q:'PSOINL!($G(PSZLQUIT))  D
     97 .I ($Y+6)>IOSL K DIR S DIR(0)="E" D ^DIR K DIR D:$G(Y)  I '$G(Y) S PSZLQUIT=1 W ! Q
     98 ..W @IOF W !?20,"Pending Outpatient Medication Orders",! I $G(PSZCNT)>1 W ?20,"(signed in under "_$G(PSOINPRT)_")",!
     99 .K ^UTILITY("DIQ1",$J),DIQ,PSOINPRX S DA=$G(PSOINL),DIC=4,DIQ(0)="E",DR=".01" D EN^DIQ1 S PSOINPRX=$G(^UTILITY("DIQ1",$J,4,DA,.01,"E")) K ^UTILITY("DIQ1",$J),DA,DR,DIC,DIQ
     100 .W !,"Division: ",$G(PSOINPRX)
     101 .W !,"Patients: "_$G(^TMP($J,"PSOCZT",PSOINL,"PAT"))_"  Window: "_$G(^("WIN"))_"  Mail: "_$G(^("MAIL"))_"  Clinic: "_$G(^("CLIN")),!
     102 K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
     103 K ^TMP($J,"PSOCZT"),^TMP($J,"PSODPAT"),RT,PSOINPRT,PSOINPRX,PSI,PSID,PIN,PZA,PZROUT,PSOINL,PSZLQUIT
     104 Q
     105SUMMCL ;
     106 W ! K DIR S DIR(0)="SMB^D:DIVISION;C:CLINIC",DIR("A")="Do you want the summary by Division or Clinic",DIR("B")="Division",DIR("?")=" "
     107 S DIR("?",1)="Enter 'D' to see the summary by Division, and within Division the orders",DIR("?",2)="shown by Mail, Window, or Administered in Clinic.",DIR("?",3)="Enter 'C' to see the summary by Clinic, along with Clinic Sort Groups."
     108 D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S PSOCLSUM=1 Q
     109 Q:$G(Y)="D"
     110 S PSOCLSUM=1
     111 K ^TMP($J,"PSOLOC"),^TMP($J,"PSOLOCP") N PSCX,PSCXL,PSLX,PSCIN,PSCPT,PSCNDE,PSNCL,PSNPAT,PSCLOUT,PSCSFLAG,PCCNT,PSOCAG
     112 F PSCX=0:0 S PSCX=$O(^PS(52.41,"ACL",PSCX)) Q:'PSCX  F PSLX=0:0 S PSLX=$O(^PS(52.41,"ACL",PSCX,PSLX)) Q:'PSLX  F PSCIN=0:0 S PSCIN=$O(^PS(52.41,"ACL",PSCX,PSLX,PSCIN)) Q:'PSCIN  S PSCPT=+$P($G(^PS(52.41,PSCIN,0)),"^",2) D:PSCPT
     113 .S PSCNDE=$G(^PS(52.41,PSCIN,0))
     114 .I $P(PSCNDE,"^",3)'="NW",$P(PSCNDE,"^",3)'="RNW",$P(PSCNDE,"^",3)'="RF" Q
     115 .I $P(PSCNDE,"^",13)="" Q
     116 .S PSNCL=+$P(PSCNDE,"^",13),PSNPAT=+$P(PSCNDE,"^",2)
     117 .I '$D(^TMP($J,"PSOLOC",PSNCL)) S ^TMP($J,"PSOLOC",PSNCL)="1^1",^TMP($J,"PSOLOCP",PSNCL,PSNPAT)="" Q
     118 .S $P(^TMP($J,"PSOLOC",PSNCL),"^",2)=$P(^TMP($J,"PSOLOC",PSNCL),"^",2)+1
     119 .I '$D(^TMP($J,"PSOLOCP",PSNCL,PSNPAT)) S $P(^TMP($J,"PSOLOC",PSNCL),"^")=$P(^TMP($J,"PSOLOC",PSNCL),"^")+1
     120 .S ^TMP($J,"PSOLOCP",PSNCL,PSNPAT)=""
     121 I '$O(^TMP($J,"PSOLOC",0)) G SUMMQ
     122 W @IOF W !?20,"Pending Outpatient Medication Orders" I $G(PSZCNT)>1 W !?20,"(signed in under "_$G(PSOINPRT)_")"
     123 F PSCXL=0:0 S PSCXL=$O(^TMP($J,"PSOLOC",PSCXL)) Q:'PSCXL!($G(PSCLOUT))  D
     124 .I ($Y+7)>IOSL D CLDIR Q:$G(PSCLOUT)
     125 .W !!,"Clinic:   ",$P($G(^SC(+PSCXL,0)),"^")
     126 .W !,"Patients: ",$P($G(^TMP($J,"PSOLOC",PSCXL)),"^"),?16,"Orders: ",$P($G(^TMP($J,"PSOLOC",PSCXL)),"^",2)
     127 .W !,"In Sort Groups:"
     128 .S (PCCNT,PSCSFLAG)=0 F PSCSORT=0:0 S PSCSORT=$O(^PS(59.8,PSCSORT)) Q:'PSCSORT!($G(PSCLOUT))  I $D(^PS(59.8,PSCSORT,1,"B",PSCXL)) S PSOCAG=0 D
     129 ..S PSCSFLAG=1 S:($Y+5)>IOSL&(PCCNT) PSOCAG=1 D:($Y+5)>IOSL&(PCCNT) CLDIR Q:$G(PSCLOUT)  W:$G(PSOCAG) !,"Clinic: "_$P($G(^SC(PSCXL,0)),"^")_"   cont." W:$G(PCCNT)>0 ! W ?16,$P($G(^PS(59.8,PSCSORT,0)),"^") S PCCNT=1
     130 .I '$G(PSCSFLAG) W ?16,"*** NO CLINIC SORT GROUPS ***"
     131 I '$G(PSCLOUT) K DIR S DIR(0)="E",DIR("A")="Press <RET> to continue"  D ^DIR K DIR
     132SUMMQ K ^TMP($J,"PSOLOC"),^TMP($J,"PSOLOCP")
     133 Q
     134CLDIR K DIR S DIR(0)="E",DIR("A")="Press <RET> to continue, '^' to exit" D ^DIR K DIR I Y'=1 S PSCLOUT=1 Q
     135 W @IOF
     136 Q
     137RXNCHK I $G(PSONEW("RX #"))']"" D RXNCHK^PSOORNE5
     138 Q
     139RDSPL D RDSPL^PSOORNE5
     140 Q
     141M3 D M3^PSOOREDX
     142 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE2.m

    r613 r623  
    1 PSOORNE2        ;BIR/SAB-display finished orders from backdoor ; 9/11/06 10:24am
    2         ;;7.0;OUTPATIENT PHARMACY;**11,21,23,27,32,37,46,84,103,117,131,146,156,210,148,222,238,264,281**;DEC 1997;Build 41
    3         ;^PSDRUG( -  221
    4         ;^YSCL(603.01 - 2697
    5         ;^PS(50.606 - 2174
    6         ;^PS(50.7 - 2223
    7         ;PSO*210 add call to WORDWRAP api
    8         ;$$DAWEXT^PSSDAWUT - 4708
    9         ;
    10 SEL     N ORN,ORD I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
    11         D K1^PSOORNE6 S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DIRUT) D KV^PSOVER1 S VALMBCK="" Q
    12 NEWSEL  N ORN,ORD D K2^PSOORNE6
    13         I +Y S PSOOELSE=1,PSLST=Y K PSOREEDT D
    14         .F ORD=1:1:$L(PSLST,",") Q:$P(PSLST,",",ORD)']""  S ORN=+$P(PSLST,",",ORD) D @$S(+PSOLST(ORN)=52:"ACT",1:"PEN^PSOORNE5") K PSOREEDT,PSOSIGFL,PSONACT,SIGOK,PSOFDR,DRET,SIG,INS1 D UL1 I $G(PSOQUIT) K PSOQUIT Q
    15         K PRC,PHI,RTE I '$G(PSOOELSE) S VALMBCK=""
    16         K PSONACT,PSOOELSE,CLOZPAT D ^PSOBUILD,BLD^PSOORUT1,K3^PSOORNE6
    17         Q
    18         ;
    19 ACT     N REF K ^TMP("PSOAO",$J),PCOMX,PDA,PHI,PRC,ACOM,ANS,PSOFDR,CLOZPAT,ANQREM,DUR,DRET
    20         S RXN=$P(PSOLST(ORN),"^",2),RX0=^PSRX(RXN,0),RX2=$G(^(2)),RX3=$G(^(3)),ST=+$G(^("STA")),RXOR=$G(^("OR1")),POE=$G(^("POE")),EXDT=$S($P($G(^(2)),"^",6)>DT:1,1:0)
    21         I 'RX3 S RX3=$P(RX2,"^",2),$P(^PSRX(RXN,3),"^")=$P(RX2,"^",2)
    22         S PSODRG=+$P(RX0,"^",6),PSODRUG0=^PSDRUG(PSODRG,0),INDT=$G(^("I"))
    23         ;PSO*7*238;SET PSODRUG ARRAY ; PSOY KILLED AT END OF SET^PSODRG
    24         K PSODRUG
    25         S PSOY=PSODRG,PSOY(0)=PSODRUG0 D SET^PSODRG
    26         I 'RXOR,$P(^PSDRUG(PSODRG,2),"^") S $P(^PSRX(RXN,"OR1"),"^")=$P(^PSDRUG(PSODRG,2),"^"),RXOR=$P(^PSDRUG(PSODRG,2),"^")
    27         I $P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1" D
    28         .S CLOZPAT=$O(^YSCL(603.01,"C",PSODFN,0)) Q:'CLOZPAT
    29         .;S CLOZPAT=$S($P(^YSCL(603.01,CLOZPAT,0),"^",3)="B":1,1:0)
    30         .S CLOZPAT=$P(^YSCL(603.01,CLOZPAT,0),"^",3)
    31         .S CLOZPAT=$S(CLOZPAT="M":2,CLOZPAT="B":1,1:0)
    32         I $D(^XUSEC("PSORPH",DUZ)) S RPH=1 D
    33         .S PSOACT=$S('ST&($G(INDT)]"")&(DT>$G(INDT)):"DHPLATC",ST=1:"DVE",ST=4:"DV",ST=3:"DU",ST=5:"ELTD",ST=11:"ETDPCL",ST=12&EXDT:"EDCL",ST=12&'EXDT:"ECL",ST>12&(ST'=16):"L",ST=16:"DL",1:"DHPEATCL")
    34         .D GET^PSOORNE5 S PSOACT=PSOACT_$S(ACTREN:"N",1:""),PSOACT=PSOACT_$S(ACTREF:"R",1:"")
    35         .I ST=5 S SURX=$O(^PS(52.5,"B",RXN,0)) I SURX,$P($G(^PS(52.5,SURX,0)),"^",7)="L" S PSOACT="TL" K SURX Q
    36         .S:ST'=12&('$D(^PS(50.7,+$P(RXOR,"^"),0))) PSOACT="DL",VALMSG="No Pharmacy Orderable Item !",PSONACT=1
    37         .S:ST=12&('$D(^PS(50.7,+$P(RXOR,"^"),0))) PSOACT="L",VALMSG="No Pharmacy Orderable Item !",PSONACT=1
    38         .I ST=14!(ST=15) S VALMSG="Rx Discontinued By "_$S(ST=14:"Provider",1:"Edit")_". Cannot be Reinstated."
    39         .S:ST=16 VALMSG="Rx Placed on HOLD by Provider."
    40         E  D
    41         .I ST=5 S SURX=$O(^PS(52.5,"B",RXN,0)) I SURX,$P($G(^PS(52.5,SURX,0)),"^",7)="L" S PSOACT="TL" Q
    42         .S PSOACT=$S(ST'<1&(ST'>4)!(ST>12):"",ST=12&EXDT&($P($G(PSOPAR),"^",2)):"CDPLT",1:"CPLT")
    43         .D GET^PSOORNE5 S PSOACT=PSOACT_$S(ACTREN:"N",1:""),PSOACT=PSOACT_$S(ACTREF:"R",1:"")
    44         .S:'$D(^PS(50.7,+$P(RXOR,"^"),0)) PSOACT="L",PSONACT=1,VALMSG="No Pharmacy Orderable Item !"
    45         ;K PSOLKFL D PSOL^PSSLOCK(RXN) I '$G(PSOMSG) K PSOMSG S PSOLKFL=1 S PSOACT="",VALMSG="This Order is being edited by another user."
    46         K PSOMSG S IEN=0,$P(RN," ",12)=" "
    47         I $G(RPH),ST=1,$P($G(^PSRX(RXN,"PKI")),"^") N PKI,PKI1,PKIR,PKIE,DA S DA=RXN D CER^PSOPKIV1 K DA D:$G(PKI1) L1^PSOPKIV1
    48         D DIN^PSONFI(+RXOR,$P(RX0,"^",6))
    49         S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=$S($P($G(^PSRX(RXN,"TPB")),"^"):"            TPB Rx #: ",1:"                Rx #: ")
    50         S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_$P(RX0,"^")_$S($G(^PSRX(RXN,"IB")):"$",1:"")_$$ECME^PSOBPSUT(RXN)_$E(RN,$L($P(RX0,"^")_$S($G(^PSRX(RXN,"IB")):"$",1:"")_$$ECME^PSOBPSUT(RXN))+1,12)
    51         S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" ("_$S($P(PSOPAR,"^",3):1,1:"#")_")"_" *Orderable Item: "_$S($D(^PS(50.7,$P(+RXOR,"^"),0)):$P(^PS(50.7,$P(+RXOR,"^"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^"),1:"")_NFIO
    52         S:NFIO["<DIN>" NFIO=IEN_","_($L(^TMP("PSOAO",$J,IEN,0))-4)
    53         S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" ("_$S($P(PSOPAR,"^",3):2,1:"#")_")"_$S($D(^PSDRUG("AQ",$P(RX0,"^",6))):"       CMOP ",1:"            ")_"Drug: "_$P(^PSDRUG($P(RX0,"^",6),0),"^")_NFID
    54         S:NFID["<DIN>" NFID=IEN_","_($L(^TMP("PSOAO",$J,IEN,0))-4)
    55         I $$STATUS^PSOBPSUT(RXN,0)'="",$$RXRLDT^PSOBPSUT(RXN,0) D
    56         . S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" "_$S('$P(PSOPAR,"^",3):"(2)",1:"   ")_"             NDC: "_$$GETNDC^PSONDCUT(RXN,0)
    57         S:$G(^PSRX(RXN,"TN"))]"" IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="          Trade Name: "_$G(^PSRX(RXN,"TN"))
    58         D DOSE^PSOORNE5
    59         S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" (4)Pat Instructions:" D INS^PSOORNE5
    60         D PC^PSOORNE5
    61         S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="                 SIG:"
    62         I '$P($G(^PSRX(RXN,"SIG")),"^",2) S SIGOK=0 D  G PTST
    63         .S X=$P($G(^PSRX(RXN,"SIG")),"^") D SIGONE^PSOHELP S SIG=$E($G(INS1),2,250)
    64         .F SG=1:1:$L(SIG) S:$L(^TMP("PSOAO",$J,IEN,0)_" "_$P(SIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOAO",$J,IEN,0)," ",21)=" " S:$P(SIG," ",SG)'="" ^TMP("PSOAO",$J,IEN,0)=$G(^TMP("PSOAO",$J,IEN,0))_" "_$P(SIG," ",SG)
    65         S SIGOK=1
    66         F I=0:0 S I=$O(^PSRX(RXN,"SIG1",I)) Q:'I  D                  ;PSO*210
    67         . S MIG=$P(^PSRX(RXN,"SIG1",I,0),"^")
    68         . D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAO",$J)),21)
    69         S SIGOK=1 K MIG,SG
    70 PTST    S $P(RN," ",25)=" ",PTST=$S($G(^PS(53,+$P(RX0,"^",3),0))]"":$P($G(^PS(53,+$P(RX0,"^",3),0)),"^"),1:""),IEN=IEN+1
    71         S ^TMP("PSOAO",$J,IEN,0)=" (5)  Patient Status: "_PTST_$E(RN,$L(PTST)+1,25)
    72         S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" (6)      Issue Date: "_$E($P(RX0,"^",13),4,5)_"/"_$E($P(RX0,"^",13),6,7)_"/"_$E($P(RX0,"^",13),2,3)
    73         S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_"               (7)  Fill Date: "_$E($P(RX2,"^",2),4,5)_"/"_$E($P(RX2,"^",2),6,7)_"/"_$E($P(RX2,"^",2),2,3)
    74         S ROU=$S($P(RX0,"^",11)="W":"Window",1:"Mail")
    75         S REFL=$P(RX0,"^",9),I=0 F  S I=$O(^PSRX(RXN,1,I)) Q:'I  S REFL=REFL-1,ROU=$S($P(^PSRX(RXN,1,I,0),"^",2)="W":"Window",1:"Mail")
    76         S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="      Last Fill Date: "_$E($P(RX3,"^"),4,5)_"/"_$E($P(RX3,"^"),6,7)_"/"_$E($P(RX3,"^"),2,3)
    77         D CMOP^PSOORNE3
    78         S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_" ("_ROU_$S($G(PSOCMOP)]"":", "_PSOCMOP,1:"")_")" K ROU,PSOCMOP
    79         S IEN=IEN+1 I $P(RX2,"^",15) S ^TMP("PSOAO",$J,IEN,0)="   Returned to Stock: "_$E($P(RX2,"^",15),4,5)_"/"_$E($P(RX2,"^",15),6,7)_"/"_$E($P(RX2,"^",15),2,3)_$S($P(RX2,"^",14):" (Reprinted)",1:"")
    80         E  S ^TMP("PSOAO",$J,IEN,0)="   Last Release Date: " D
    81         .S RLD=$S($P(RX2,"^",13):$E($P(RX2,"^",13),4,5)_"/"_$E($P(RX2,"^",13),6,7)_"/"_$E($P(RX2,"^",13),2,3),1:"")
    82         .I $O(^PSRX(RXN,1,0)) F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I  D
    83         ..I $P(^PSRX(RXN,1,I,0),"^",18) S RLD=$E($P(^(0),"^",18),4,5)_"/"_$E($P(^(0),"^",18),6,7)_"/"_$E($P(^(0),"^",18),2,3)
    84         .S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_$S($G(RLD)]"":RLD,1:"        ")
    85         S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_"               (8)      Lot #: "_$P($G(RX2),"^",4)
    86         S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="             Expires: "_$E($P(RX2,"^",6),4,5)_"/"_$E($P(RX2,"^",6),6,7)_"/"_$E($P(RX2,"^",6),2,3)
    87         S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_"                          MFG: "_$P($G(RX2),"^",8)
    88         S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(9)      Days Supply: "_$P(RX0,"^",8)_$S($L($P(RX0,"^",8))=1:" ",1:"")
    89         S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_"                    (10)  QTY"_$S($P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)]"":" ("_$P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)_")",1:" (  )")_": "_$P(RX0,"^",7)
    90         I $P($G(^PSDRUG($P(RX0,"^",6),5)),"^")]"" D
    91         .S $P(RN," ",79)=" ",IEN=IEN+1
    92         .S ^TMP("PSOAO",$J,IEN,0)=$E(RN,$L("QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^"))+1,79)_"QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^") K RN
    93         S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(11)    # of Refills: "_$P(RX0,"^",9)_$S($L($P(RX0,"^",9))=1:" ",1:"")_"                          Remaining: "_REFL
    94         S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(12)        Provider: "_$S($D(^VA(200,$P(RX0,"^",4),0)):$P(^VA(200,$P(RX0,"^",4),0),"^"),1:"UNKNOWN")
    95         I $P(RX3,"^",3) S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="        Cos-Provider: "_$P(^VA(200,$S($G(PSORX("COSIGNING PROVIDER")):PSORX("COSIGNING PROVIDER"),1:$P(RX3,"^",3)),0),"^")
    96         S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(13)         Routing: "_$S($P(RX0,"^",11)="M":"MAIL",1:"WINDOW")_"                  (14)     Copies: "_$S($P(RX0,"^",18):$P(RX0,"^",18),1:1)
    97         S:$P(RX0,"^",11)="W"&($P(PSOPAR,"^",12)) IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="    Method of Pickup: "_$G(^PSRX(RXN,"MP"))
    98         S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(15)          Clinic: "_$S($D(^SC(+$P(RX0,"^",5),0)):$P(^SC($P(RX0,"^",5),0),"^"),1:"Not on File")
    99         S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(16)        Division: "_$S($G(^PS(59,+$P(RX2,"^",9),0))]"":$P(^PS(59,$P(RX2,"^",9),0),"^")_" ("_$P(^(0),"^",6)_")",1:"UNKNOWN")
    100         S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(17)      Pharmacist: "_$S($P(RX2,"^",3):$P(^VA(200,$P(RX2,"^",3),0),"^"),1:"")
    101         S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(18)         Remarks:" D RMK^PSOORNE3
    102         S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(19)      Counseling: "_$S($P($G(^PSRX(RXN,"PC")),"^"):"YES",1:"NO")_"                      "_$S($P($G(^PSRX(RXN,"PC")),"^"):"Was Counseling Understood: "_$S($P($G(^PSRX(RXN,"PC")),"^",2):"YES",1:"NO"),1:"")
    103         S:$O(^PSRX(RXN,1,0)) REF=1,IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(20)     Refill Data"
    104         I $$STATUS^PSOBPSUT(RXN,0)'="" D
    105         . N DAW S IEN=IEN+1,DAW=$$GETDAW^PSODAWUT(RXN,0)
    106         . S ^TMP("PSOAO",$J,IEN,0)="(21)        DAW Code: "_DAW_" - "_$$DAWEXT^PSSDAWUT(DAW)
    107         D DISP^PSOORNE6
    108         I $G(PSOBEDT),PSOACT["E" S PSOACT="E"
    109         I $G(PSOBEDT),PSOACT'["E" S PSOACT=""
    110         Q:$G(PSORXED)!($G(COPY))!($G(UPMI))  S:$G(PSOBEDT) (PSOEDIT,PSORXED)=1 D ^PSOLMLST ; I '$G(PSOLKFL) D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
    111         K DRET,SIG
    112         Q
    113 UL1     ;
    114         ;I +PSOLST(ORN)=52 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q
    115         ;I $D(^PS(52.41,$P(PSOLST(ORN),"^",2),0)) D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)_"S")
    116         Q
     1PSOORNE2 ;BIR/SAB-display finished orders from backdoor ; 9/11/06 10:24am
     2 ;;7.0;OUTPATIENT PHARMACY;**11,21,23,27,32,37,46,84,103,117,131,146,156,210,148,222,238,264**;DEC 1997;Build 19
     3 ;^PSDRUG( -  221
     4 ;^YSCL(603.01 - 2697
     5 ;^PS(50.606 - 2174
     6 ;^PS(50.7 - 2223
     7 ;PSO*210 add call to WORDWRAP api
     8 ;$$DAWEXT^PSSDAWUT - 4708
     9 ;
     10SEL N ORN,ORD I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
     11 D K1^PSOORNE6 S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DIRUT) D KV^PSOVER1 S VALMBCK="" Q
     12NEWSEL N ORN,ORD D K2^PSOORNE6
     13 I +Y S PSOOELSE=1,PSLST=Y K PSOREEDT D
     14 .F ORD=1:1:$L(PSLST,",") Q:$P(PSLST,",",ORD)']""  S ORN=+$P(PSLST,",",ORD) D @$S(+PSOLST(ORN)=52:"ACT",1:"PEN^PSOORNE5") K PSOREEDT,PSOSIGFL,PSONACT,SIGOK,PSOFDR,DRET,SIG,INS1 D UL1 I $G(PSOQUIT) K PSOQUIT Q
     15 K PRC,PHI,RTE I '$G(PSOOELSE) S VALMBCK=""
     16 K PSONACT,PSOOELSE,CLOZPAT D ^PSOBUILD,BLD^PSOORUT1,K3^PSOORNE6
     17 Q
     18 ;
     19ACT N REF K ^TMP("PSOAO",$J),PCOMX,PDA,PHI,PRC,ACOM,ANS,PSOFDR,CLOZPAT,ANQREM,DUR,DRET
     20 S RXN=$P(PSOLST(ORN),"^",2),RX0=^PSRX(RXN,0),RX2=$G(^(2)),RX3=$G(^(3)),ST=+$G(^("STA")),RXOR=$G(^("OR1")),POE=$G(^("POE")),EXDT=$S($P($G(^(2)),"^",6)>DT:1,1:0)
     21 I 'RX3 S RX3=$P(RX2,"^",2),$P(^PSRX(RXN,3),"^")=$P(RX2,"^",2)
     22 S PSODRG=+$P(RX0,"^",6),PSODRUG0=^PSDRUG(PSODRG,0),INDT=$G(^("I"))
     23 ;PSO*7*238;SET PSODRUG ARRAY ; PSOY KILLED AT END OF SET^PSODRG
     24 K PSODRUG
     25 S PSOY=PSODRG,PSOY(0)=PSODRUG0 D SET^PSODRG
     26 I 'RXOR,$P(^PSDRUG(PSODRG,2),"^") S $P(^PSRX(RXN,"OR1"),"^")=$P(^PSDRUG(PSODRG,2),"^"),RXOR=$P(^PSDRUG(PSODRG,2),"^")
     27 I $P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1" D
     28 .S CLOZPAT=$O(^YSCL(603.01,"C",PSODFN,0)) Q:'CLOZPAT
     29 .;S CLOZPAT=$S($P(^YSCL(603.01,CLOZPAT,0),"^",3)="B":1,1:0)
     30 .S CLOZPAT=$P(^YSCL(603.01,CLOZPAT,0),"^",3)
     31 .S CLOZPAT=$S(CLOZPAT="M":2,CLOZPAT="B":1,1:0)
     32 I $D(^XUSEC("PSORPH",DUZ)) S RPH=1 D
     33 .S PSOACT=$S('ST&($G(INDT)]"")&(DT>$G(INDT)):"DHPLATC",ST=1:"DVE",ST=4:"DV",ST=3:"DU",ST=5:"ELTD",ST=11:"TDPCL",ST=12&EXDT:"DCL",ST=12&'EXDT:"CL",ST>12&(ST'=16):"L",ST=16:"DL",1:"DHPEATCL")
     34 .D GET^PSOORNE5 S PSOACT=PSOACT_$S(ACTREN:"N",1:""),PSOACT=PSOACT_$S(ACTREF:"R",1:"")
     35 .I ST=5 S SURX=$O(^PS(52.5,"B",RXN,0)) I SURX,$P($G(^PS(52.5,SURX,0)),"^",7)="L" S PSOACT="TL" K SURX Q
     36 .S:ST'=12&('$D(^PS(50.7,+$P(RXOR,"^"),0))) PSOACT="DL",VALMSG="No Pharmacy Orderable Item !",PSONACT=1
     37 .S:ST=12&('$D(^PS(50.7,+$P(RXOR,"^"),0))) PSOACT="L",VALMSG="No Pharmacy Orderable Item !",PSONACT=1
     38 .I ST=14!(ST=15) S VALMSG="Rx Discontinued By "_$S(ST=14:"Provider",1:"Edit")_". Cannot be Reinstated."
     39 .S:ST=16 VALMSG="Rx Placed on HOLD by Provider."
     40 E  D
     41 .I ST=5 S SURX=$O(^PS(52.5,"B",RXN,0)) I SURX,$P($G(^PS(52.5,SURX,0)),"^",7)="L" S PSOACT="TL" Q
     42 .S PSOACT=$S(ST'<1&(ST'>4)!(ST>12):"",ST=12&EXDT&($P($G(PSOPAR),"^",2)):"CDPLT",1:"CPLT")
     43 .D GET^PSOORNE5 S PSOACT=PSOACT_$S(ACTREN:"N",1:""),PSOACT=PSOACT_$S(ACTREF:"R",1:"")
     44 .S:'$D(^PS(50.7,+$P(RXOR,"^"),0)) PSOACT="L",PSONACT=1,VALMSG="No Pharmacy Orderable Item !"
     45 ;K PSOLKFL D PSOL^PSSLOCK(RXN) I '$G(PSOMSG) K PSOMSG S PSOLKFL=1 S PSOACT="",VALMSG="This Order is being edited by another user."
     46 K PSOMSG S IEN=0,$P(RN," ",12)=" "
     47 I $G(RPH),ST=1,$P($G(^PSRX(RXN,"PKI")),"^") N PKI,PKI1,PKIR,PKIE,DA S DA=RXN D CER^PSOPKIV1 K DA D:$G(PKI1) L1^PSOPKIV1
     48 D DIN^PSONFI(+RXOR,$P(RX0,"^",6))
     49 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=$S($P($G(^PSRX(RXN,"TPB")),"^"):"            TPB Rx #: ",1:"                Rx #: ")
     50 S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_$P(RX0,"^")_$S($G(^PSRX(RXN,"IB")):"$",1:"")_$$ECME^PSOBPSUT(RXN)_$E(RN,$L($P(RX0,"^")_$S($G(^PSRX(RXN,"IB")):"$",1:"")_$$ECME^PSOBPSUT(RXN))+1,12)
     51 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" ("_$S($P(PSOPAR,"^",3):1,1:"#")_")"_" *Orderable Item: "_$S($D(^PS(50.7,$P(+RXOR,"^"),0)):$P(^PS(50.7,$P(+RXOR,"^"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^"),1:"")_NFIO
     52 S:NFIO["<DIN>" NFIO=IEN_","_($L(^TMP("PSOAO",$J,IEN,0))-4)
     53 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" ("_$S($P(PSOPAR,"^",3):2,1:"#")_")"_$S($D(^PSDRUG("AQ",$P(RX0,"^",6))):"       CMOP ",1:"            ")_"Drug: "_$P(^PSDRUG($P(RX0,"^",6),0),"^")_NFID
     54 S:NFID["<DIN>" NFID=IEN_","_($L(^TMP("PSOAO",$J,IEN,0))-4)
     55 I $$STATUS^PSOBPSUT(RXN,0)'="",$$RXRLDT^PSOBPSUT(RXN,0) D
     56 . S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" "_$S('$P(PSOPAR,"^",3):"(2)",1:"   ")_"             NDC: "_$$GETNDC^PSONDCUT(RXN,0)
     57 S:$G(^PSRX(RXN,"TN"))]"" IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="          Trade Name: "_$G(^PSRX(RXN,"TN"))
     58 D DOSE^PSOORNE5
     59 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" (4)Pat Instructions:" D INS^PSOORNE5
     60 D PC^PSOORNE5
     61 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="                 SIG:"
     62 I '$P($G(^PSRX(RXN,"SIG")),"^",2) S SIGOK=0 D  G PTST
     63 .S X=$P($G(^PSRX(RXN,"SIG")),"^") D SIGONE^PSOHELP S SIG=$E($G(INS1),2,250)
     64 .F SG=1:1:$L(SIG) S:$L(^TMP("PSOAO",$J,IEN,0)_" "_$P(SIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOAO",$J,IEN,0)," ",21)=" " S:$P(SIG," ",SG)'="" ^TMP("PSOAO",$J,IEN,0)=$G(^TMP("PSOAO",$J,IEN,0))_" "_$P(SIG," ",SG)
     65 S SIGOK=1
     66 F I=0:0 S I=$O(^PSRX(RXN,"SIG1",I)) Q:'I  D                  ;PSO*210
     67 . S MIG=$P(^PSRX(RXN,"SIG1",I,0),"^")
     68 . D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAO",$J)),21)
     69 S SIGOK=1 K MIG,SG
     70PTST S $P(RN," ",25)=" ",PTST=$S($G(^PS(53,+$P(RX0,"^",3),0))]"":$P($G(^PS(53,+$P(RX0,"^",3),0)),"^"),1:""),IEN=IEN+1
     71 S ^TMP("PSOAO",$J,IEN,0)=" (5)  Patient Status: "_PTST_$E(RN,$L(PTST)+1,25)
     72 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" (6)      Issue Date: "_$E($P(RX0,"^",13),4,5)_"/"_$E($P(RX0,"^",13),6,7)_"/"_$E($P(RX0,"^",13),2,3)
     73 S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_"               (7)  Fill Date: "_$E($P(RX2,"^",2),4,5)_"/"_$E($P(RX2,"^",2),6,7)_"/"_$E($P(RX2,"^",2),2,3)
     74 S ROU=$S($P(RX0,"^",11)="W":"Window",1:"Mail")
     75 S REFL=$P(RX0,"^",9),I=0 F  S I=$O(^PSRX(RXN,1,I)) Q:'I  S REFL=REFL-1,ROU=$S($P(^PSRX(RXN,1,I,0),"^",2)="W":"Window",1:"Mail")
     76 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="      Last Fill Date: "_$E($P(RX3,"^"),4,5)_"/"_$E($P(RX3,"^"),6,7)_"/"_$E($P(RX3,"^"),2,3)
     77 D CMOP^PSOORNE3
     78 S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_" ("_ROU_$S($G(PSOCMOP)]"":", "_PSOCMOP,1:"")_")" K ROU,PSOCMOP
     79 S IEN=IEN+1 I $P(RX2,"^",15) S ^TMP("PSOAO",$J,IEN,0)="   Returned to Stock: "_$E($P(RX2,"^",15),4,5)_"/"_$E($P(RX2,"^",15),6,7)_"/"_$E($P(RX2,"^",15),2,3)_$S($P(RX2,"^",14):" (Reprinted)",1:"")
     80 E  S ^TMP("PSOAO",$J,IEN,0)="   Last Release Date: " D
     81 .S RLD=$S($P(RX2,"^",13):$E($P(RX2,"^",13),4,5)_"/"_$E($P(RX2,"^",13),6,7)_"/"_$E($P(RX2,"^",13),2,3),1:"")
     82 .I $O(^PSRX(RXN,1,0)) F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I  D
     83 ..I $P(^PSRX(RXN,1,I,0),"^",18) S RLD=$E($P(^(0),"^",18),4,5)_"/"_$E($P(^(0),"^",18),6,7)_"/"_$E($P(^(0),"^",18),2,3)
     84 .S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_$S($G(RLD)]"":RLD,1:"        ")
     85 S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_"               (8)      Lot #: "_$P($G(RX2),"^",4)
     86 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="             Expires: "_$E($P(RX2,"^",6),4,5)_"/"_$E($P(RX2,"^",6),6,7)_"/"_$E($P(RX2,"^",6),2,3)
     87 S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_"                          MFG: "_$P($G(RX2),"^",8)
     88 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(9)      Days Supply: "_$P(RX0,"^",8)_$S($L($P(RX0,"^",8))=1:" ",1:"")
     89 S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_"                    (10)  QTY"_$S($P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)]"":" ("_$P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)_")",1:" (  )")_": "_$P(RX0,"^",7)
     90 I $P($G(^PSDRUG($P(RX0,"^",6),5)),"^")]"" D
     91 .S $P(RN," ",79)=" ",IEN=IEN+1
     92 .S ^TMP("PSOAO",$J,IEN,0)=$E(RN,$L("QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^"))+1,79)_"QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^") K RN
     93 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(11)    # of Refills: "_$P(RX0,"^",9)_$S($L($P(RX0,"^",9))=1:" ",1:"")_"                          Remaining: "_REFL
     94 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(12)        Provider: "_$S($D(^VA(200,$P(RX0,"^",4),0)):$P(^VA(200,$P(RX0,"^",4),0),"^"),1:"UNKNOWN")
     95 I $P(RX3,"^",3) S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="        Cos-Provider: "_$P(^VA(200,$S($G(PSORX("COSIGNING PROVIDER")):PSORX("COSIGNING PROVIDER"),1:$P(RX3,"^",3)),0),"^")
     96 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(13)         Routing: "_$S($P(RX0,"^",11)="M":"MAIL",1:"WINDOW")_"                  (14)     Copies: "_$S($P(RX0,"^",18):$P(RX0,"^",18),1:1)
     97 S:$P(RX0,"^",11)="W"&($P(PSOPAR,"^",12)) IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="    Method of Pickup: "_$G(^PSRX(RXN,"MP"))
     98 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(15)          Clinic: "_$S($D(^SC(+$P(RX0,"^",5),0)):$P(^SC($P(RX0,"^",5),0),"^"),1:"Not on File")
     99 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(16)        Division: "_$S($G(^PS(59,+$P(RX2,"^",9),0))]"":$P(^PS(59,$P(RX2,"^",9),0),"^")_" ("_$P(^(0),"^",6)_")",1:"UNKNOWN")
     100 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(17)      Pharmacist: "_$S($P(RX2,"^",3):$P(^VA(200,$P(RX2,"^",3),0),"^"),1:"")
     101 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(18)         Remarks:" D RMK^PSOORNE3
     102 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(19)      Counseling: "_$S($P($G(^PSRX(RXN,"PC")),"^"):"YES",1:"NO")_"                      "_$S($P($G(^PSRX(RXN,"PC")),"^"):"Was Counseling Understood: "_$S($P($G(^PSRX(RXN,"PC")),"^",2):"YES",1:"NO"),1:"")
     103 S:$O(^PSRX(RXN,1,0)) REF=1,IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(20)     Refill Data"
     104 I $$STATUS^PSOBPSUT(RXN,0)'="" D
     105 . N DAW S IEN=IEN+1,DAW=$$GETDAW^PSODAWUT(RXN,0)
     106 . S ^TMP("PSOAO",$J,IEN,0)="(21)        DAW Code: "_DAW_" - "_$$DAWEXT^PSSDAWUT(DAW)
     107 D DISP^PSOORNE6
     108 I $G(PSOBEDT),PSOACT["E" S PSOACT="E"
     109 I $G(PSOBEDT),PSOACT'["E" S PSOACT=""
     110 Q:$G(PSORXED)!($G(COPY))!($G(UPMI))  S:$G(PSOBEDT) (PSOEDIT,PSORXED)=1 D ^PSOLMLST ; I '$G(PSOLKFL) D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
     111 K DRET,SIG
     112 Q
     113UL1 ;
     114 ;I +PSOLST(ORN)=52 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q
     115 ;I $D(^PS(52.41,$P(PSOLST(ORN),"^",2),0)) D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)_"S")
     116 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE4.m

    r613 r623  
    1 PSOORNE4        ;BIR/SAB-display renew RXs from backdoor ;07/29/96
    2         ;;7.0;OUTPATIENT PHARMACY;**11,27,32,36,46,75,96,103,99,117,131,225**;DEC 1997;Build 29
    3         ;^SC DBIA-10040;^PS(50.7-2223;^PS(50.606-2174;^PS(50.607-2221;^PS(51.2-2226;^PSDRUG-221;^PS(55-2228
    4 EN(PSONEW)      N FLD,LST,VALMCNT
    5 EN1     K PSOQUIT D:$G(PSONEW("ENT"))'>0  I $G(PSORENW("POE"))=1 S PSOREEDT=1 D SV
    6         .S PSOREEDT=1 D SV
    7         .K PSONEW("DOSE"),PSONEW("UNITS"),PSONEW("DOSE ORDERED"),PSONEW("ROUTE")
    8         .K PSONEW("SCHEDULE"),PSONEW("DURATION"),PSONEW("CONJUNCTION"),PSONEW("NOUN"),PSONEW("VERB"),PSOPRC,PSONEW("ODOSE")
    9 RDD     D DSPL,^PSOLMRN D:$G(PKI1)=2 DCP^PSOPKIV1 I $G(PSORX("FN")) S VALMBCK="Q" K PSOREEDT Q
    10         G:'$G(PSOQUIT) RDD
    11         Q
    12 EDT     D KV^PSOVER1 S DIR("A")="Select Field to Edit by number",DIR(0)="LO^1:"_$S($G(PSOREEDT):10,1:8)
    13         D ^DIR I $D(DTOUT)!($D(DUOUT)) D KV^PSOVER1 S VALMBCK="" Q
    14 EDTSEL  S PSOLM=1,(PSONEW("DFLG"),PSONEW("FIELD"),PSONEW3)=0
    15         I +Y S LST=Y D HLDHDR^PSOLMUTL S PSOEDT=1 D  Q:$G(PSODIR("DFLG"))!($G(PSODIR("QFLG")))
    16         .F FLD=1:1:$L(LST,",") Q:$P(LST,",",FLD)']""  D @(+$P(LST,",",FLD)) Q:$G(PSODIR("DFLG"))!($G(PSODIR("QFLG")))
    17         E  S VALMBCK="" D FULL^VALM1
    18         Q
    19 ACP     I $G(PKI1)=1 D REA^PSOPKIV1 G:$G(PSONEW("QFLG"))=1 PKI
    20         D INST2^PSORENW S PSOFROM1=1 D:$D(^XUSEC("PSORPH",DUZ))!('$P(PSOPAR,"^",2)) VER
    21         K PSOFROM1
    22 PKI     I $G(PSONEW("QFLG")) S POERR("DFLG")=1,VALMBCK="R" K PSONEW2 Q
    23         I PSONEW("ENT")>0,$G(NEWDOSE) K NEWDOSE G EN1 Q
    24         S PSORX("FN")=1 D EN^PSORN52(.PSONEW)
    25         D RNPSOSD^PSOUTIL,ACP1^PSOORNE6,^PSOBUILD S VALMBCK="Q"
    26         Q
    27 VER1(PSONEW)    ;
    28 VER     S (PSONEW("DFLG"),PSONEW("QFLG"))=0 I PSONEW("ENT")=0 D  K PSOORRNW,PSOFROM1 I PSONEW("DFLG")=1 S (PSONEW("QFLG"),POERR("DFLG"))=1 Q
    29         .S (PSOREEDT,PSOORRNW)=1 W !!,"Dosing Instruction Missing!!",!
    30         .S PSONEW("IRXN")=PSONEW("OIRXN") K VALMSG D FULL^VALM1 W !,"Drug: "_PSODRUG("NAME") D
    31         ..I $O(SIG(0)) D  Q
    32         ...F I=1:1 Q:$G(SIG(I))']""  W !,SIG(I)
    33         ..I $P($G(^PSRX(PSONEW("OIRXN"),"SIG")),"^")]"" S X=$P(^PSRX(PSONEW("OIRXN"),"SIG"),"^") D SIGONE^PSOHELP W !,$E($G(INS1),2,250)
    34         .K DIRUT W ! D DOSE^PSODIR(.PSONEW) Q:$G(PSONEW("DFLG"))  D EN^PSOFSIG(.PSONEW)
    35         .I PSONEW("ENT")>0,$O(SIG(0)) S (SIGOK,NEWDOSE)=1
    36         .I '$G(SPEED),PSONEW("DFLG")=1 S VALMSG="Renewal Request Cancelled!" W:$G(SPEED) !,"Renewal Request Cancelled!" Q:$G(PSONEW("DFLG"))
    37         .I +$G(PSONEW("ENT"))'>0 K DIRUT Q
    38         .D INS^PSODIR(.PSONEW),EN^PSOFSIG(.PSONEW),SINS^PSODIR(.PSONEW):$G(^PS(55,PSODFN,"LAN"))
    39         .S:'$G(SPEED)&(PSONEW("DFLG")=1) VALMSG="Renewal Request Cancelled!" W:$G(SPEED)&(PSONEW("DFLG")=1) !,"Renewal Request Cancelled!"
    40         .I $G(SPEED),'$G(PSONEW("DFLG")) D KV^PSOVER1 S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR,KV^PSOVER1 K X,Y
    41         I +$G(PSONEW("ENT"))'>0 G VER
    42         D STOP^PSORENW1 I +$G(PSEXDT) D  S PSORENW("QFLG")=1
    43         .S Y=PSORENW("FILL DATE") X ^DD("DD") S VALMSG=Y_" fill date is past expiration date "
    44         .S Y=$P(PSEXDT,"^",2) X ^DD("DD") S VALMSG=VALMSG_Y_"."
    45         Q
    46 DSPL    G:$G(PSONEW("ENT"))>0 DSP
    47         S PSONEW("ENT")=0 F I=0:0 S I=$O(^PSRX(PSONEW("OIRXN"),6,I)) Q:'I  S DOSE=^PSRX(PSONEW("OIRXN"),6,I,0) D
    48         .S PSONEW("ENT")=PSONEW("ENT")+1,PSONEW("DOSE",PSONEW("ENT"))=$P(DOSE,"^")
    49         .S PSONEW("UNITS",PSONEW("ENT"))=$P(DOSE,"^",3),PSONEW("DOSE ORDERED",PSONEW("ENT"))=$P(DOSE,"^",2),PSONEW("ROUTE",PSONEW("ENT"))=$P(DOSE,"^",7)
    50         .S PSONEW("SCHEDULE",PSONEW("ENT"))=$P(DOSE,"^",8),PSONEW("DURATION",PSONEW("ENT"))=$P(DOSE,"^",5),PSONEW("CONJUNCTION",PSONEW("ENT"))=$P(DOSE,"^",6)
    51         .S PSONEW("NOUN",PSONEW("ENT"))=$P(DOSE,"^",4),PSONEW("VERB",PSONEW("ENT"))=$P(DOSE,"^",9)
    52         .I $G(^PSRX(PSONEW("OIRXN"),6,I,1))]"" S PSONEW("ODOSE",PSONEW("ENT"))=^PSRX(PSONEW("OIRXN"),6,I,1)
    53         .K DOSE
    54 DSP     D ^PSOORUT2 K ^TMP("PSOPO",$J) S IEN=0
    55         D:$G(PSONEW("PENDING ORDER")) LMDISP^PSOORFI5(+PSONEW("PENDING ORDER"))
    56         D:$G(PKI1) L1^PSOPKIV1
    57         D DIN^PSONFI(PSODRUG("OI"),$S($G(PSODRUG("IEN")):PSODRUG("IEN"),1:""))
    58         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                 Rx#: "_PSONEW("NRX #")
    59         I +$G(PSODRUG("OI")) D
    60         .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="      Orderable Item: "_$P(^PS(50.7,+$G(PSODRUG("OI")),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_NFIO
    61         .S:NFIO["<DIN>" NFIO=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
    62         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     "_$S($D(^PSDRUG("AQ",PSODRUG("IEN"))):"      CMOP ",1:"           ")_"Drug: "_PSODRUG("NAME")_NFID
    63         S:NFID["<DIN>" NFID=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
    64         S:$G(PSONEW("TN"))]"" IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          Trade Name: "_$G(PSONEW("TN"))
    65         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="      Patient Status: "_$P(PSONEW("PTST NODE"),"^"),PSONEW("PATIENT STATUS")=$P(PSONEW("PTST NODE"),"^")
    66         S (PSOID,Y)=PSONEW("ISSUE DATE") X ^DD("DD") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (1)     Issue Date: "_Y
    67         S Y=PSONEW("FILL DATE") X ^DD("DD") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (2)      Fill Date: "_Y
    68         I PSONEW("ENT")=0 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(PSOREEDT):"  (9)",1:"     ")_"         Dosage:" G PAT
    69         F I=1:1:PSONEW("ENT") D
    70         .I '$G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                Verb: "_$G(PSONEW("VERB",I))
    71         .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(PSOREEDT)&(I'>1):"  (9)",1:"     ")_"         Dosage: "_$S($E(PSONEW("DOSE",I),1)="."&($G(PSONEW("DOSE ORDERED",I))):"0",1:"")_PSONEW("DOSE",I)
    72         .S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_$S($G(PSONEW("UNITS",I))]"":" ("_$P(^PS(50.607,PSONEW("UNITS",I),0),"^")_")",1:"")
    73         .I $P($G(^PS(55,PSODFN,"LAN")),"^"),'$G(PSONEW("DOSE ORDERED",I)) D
    74         ..S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="   Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I))
    75         .I $G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" D
    76         ..S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                Verb: "_$G(PSONEW("VERB",I))
    77         ..S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="      Dispense Units: "_$S($E($G(PSONEW("DOSE ORDERED",I)),1)=".":"0",1:"")_$G(PSONEW("DOSE ORDERED",I))
    78         ..S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                Noun: "_$G(PSONEW("NOUN",I))
    79         .I $G(PSONEW("ROUTE",I)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Route: "_$P(^PS(51.2,PSONEW("ROUTE",I),0),"^")
    80         .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="            Schedule: "_PSONEW("SCHEDULE",I)
    81         .I $G(PSONEW("DURATION",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="           *Duration: "_$G(PSONEW("DURATION",I))
    82         .I $G(PSONEW("CONJUNCTION",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="         Conjunction: "_$S($G(PSONEW("CONJUNCTION",I))="A":"AND",$G(PSONEW("CONJUNCTION",I))="T":"THEN",$G(PSONEW("CONJUNCTION",I))="X":"EXCEPT",1:"")
    83 PAT     S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(PSOREEDT):" (10)",1:"     ")_"Pat Instruction:" D INS2^PSOBKDED
    84         S RXN=PSONEW("OIRXN") D INST1^PSORENW
    85         ;I $O(PRC(0)) D PC1^PSOORNE5
    86         K RXN S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                 SIG:"
    87         I $G(SIGOK),$O(SIG(0)) D  K SG,MIG
    88         .F I=0:0 S I=$O(SIG(I)) Q:'I  F SG=1:1:$L(SIG(I)) D
    89         ..S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(SIG(I)," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",21)=" "
    90         ..S:$P(SIG(I)," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(SIG(I)," ",SG)
    91         E  D
    92         .S X=$S($G(PSONEW("SIG"))]"":PSONEW("SIG"),1:$P($G(^PSRX(PSONEW("OIRXN"),"SIG")),"^")) D SIGONE^PSOHELP S SIG=$E($G(INS1),2,250)
    93         .F SG=1:1:$L(SIG) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(SIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",21)=" " S:$P(SIG," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(SIG," ",SG)
    94         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="         Days Supply: "_PSONEW("DAYS SUPPLY")_$S($L(PSONEW("DAYS SUPPLY"))=1:" ",1:"")
    95         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                 QTY"_$S($G(PSODRUG("UNIT"))]"":" ("_PSODRUG("UNIT")_")",1:" (  )")_": "_PSONEW("QTY")
    96         I $D(^PSDRUG("AQ",PSODRUG("IEN"))),$P($G(^PSDRUG(PSODRUG("IEN"),5)),"^")]"" D
    97         .S $P(RN," ",79)=" ",IEN=IEN+1
    98         .S ^TMP("PSOPO",$J,IEN,0)="            QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^")
    99         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (3)   # of Refills: "_PSONEW("# OF REFILLS")_$S($L(PSONEW("# OF REFILLS"))=1:" ",1:"")
    100         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (4)        Routing: "_$S($G(PSORENW("MAIL/WINDOW"))["W":"WINDOW",1:"MAIL")
    101         S:$G(PSONEW("METHOD OF PICK-UP"))]""&($P(PSOPAR,"^",12)) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="    Method of Pickup: "_PSONEW("METHOD OF PICK-UP")
    102         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (5)         Clinic: "_$S($G(PSONEW("CLINIC")):$P(^SC(PSONEW("CLINIC"),0),"^"),1:"")
    103         S $P(RN," ",31)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (6)       Provider: "_PSONEW("PROVIDER NAME")_$E(RN,$L(PSONEW("PROVIDER NAME"))+1,31) K RN
    104         I $G(PSONEW("COSIGNING PROVIDER"))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="        Cos-Provider: "_$P(^VA(200,PSONEW("COSIGNING PROVIDER"),0),"^")
    105         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (7)         Copies: "_$S($G(PSONEW("COPIES")):PSONEW("COPIES"),1:1)
    106 RMK     S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (8)        Remarks: "_$S($G(PSONEW("REMARKS"))]"":PSONEW("REMARKS"),1:"")
    107         S $P(RN," ",35)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="   Entry By: "_$P(^VA(200,DUZ,0),"^")_$E(RN,$L($P(^VA(200,DUZ,0),"^"))+1,35)
    108         I $G(PSOFDR) S ^TMP("PSOPO",$J,IEN,0)="   Entry By: "_$P(^VA(200,$P(OR0,"^",4),0),"^")_$E(RN,$L($P(^VA(200,$P(OR0,"^",4),0),"^"))+1,35)
    109         D NOW^%DTC S PSONEW("LOGIN DATE")=$S($P($G(OR0),"^",6):$P($G(OR0),"^",6),1:%) K %,X S Y=PSONEW("LOGIN DATE") X ^DD("DD")
    110         S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"Entry Date: "_$P(Y,"@")_" "_$P(Y,"@",2) K RN
    111         S (VALMCNT,PSOPF)=IEN
    112         Q
    113 1       D 1^PSOBKDED Q
    114 2       D 2^PSOBKDED Q
    115 3       D 9^PSOBKDED Q
    116 4       D 12^PSOBKDED Q
    117 5       D 5^PSOBKDED Q
    118 6       D 4^PSOBKDED Q
    119 7       D 11^PSOBKDED Q
    120 8       D 13^PSOBKDED Q
    121 9       W !!,"Drug: "_PSODRUG("NAME") S PSOORRNW=1 D DOSE1^PSOORED5(.PSONEW)
    122         I $G(PSONEW("DFLG")) S PSODIR("DFLG")=1,VALMBCK="Q" Q
    123         D SV Q
    124 10      D INS^PSODIR(.PSONEW),SINS^PSODIR(.PSONEW) D SV Q
    125 SV      D SV^PSOORNE5 Q
     1PSOORNE4 ;BIR/SAB-display renew RXs from backdoor ;1/27/07  13:28
     2 ;;7.0;OUTPATIENT PHARMACY;**11,27,32,36,46,75,96,103,99,117,131,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; GPL Copyright (C) 2007 WorldVistA
     5 ;^SC DBIA-10040;^PS(50.7-2223;^PS(50.606-2174;^PS(50.607-2221;^PS(51.2-2226;^PSDRUG-221;^PS(55-2228
     6EN(PSONEW) N FLD,LST,VALMCNT
     7EN1 K PSOQUIT D:$G(PSONEW("ENT"))'>0  I $G(PSORENW("POE"))=1 S PSOREEDT=1 D SV
     8 .S PSOREEDT=1 D SV
     9 .K PSONEW("DOSE"),PSONEW("UNITS"),PSONEW("DOSE ORDERED"),PSONEW("ROUTE")
     10 .K PSONEW("SCHEDULE"),PSONEW("DURATION"),PSONEW("CONJUNCTION"),PSONEW("NOUN"),PSONEW("VERB"),PSOPRC,PSONEW("ODOSE")
     11RDD I $G(PSOAFYN)'="Y" D DSPL,^PSOLMRN D:$G(PKI1)=2 DCP^PSOPKIV1 I $G(PSORX("FN")) S VALMBCK="Q" K PSOREEDT Q  ;vfah
     12 I $G(PSOAFYN)="Y" D ACP D:$G(PKI1)=2 DCP^PSOPKIV1 I $G(PSORX("FN")) S VALMBCK="Q" K PSOREEDT Q  ;vfah D ACP from D ACP^PSOLMRN above
     13 I $G(PSOAFYN)'="Y" G:'$G(PSOQUIT) RDD ;vfah
     14 Q
     15EDT D KV^PSOVER1 S DIR("A")="Select Field to Edit by number",DIR(0)="LO^1:"_$S($G(PSOREEDT):10,1:8)
     16 D ^DIR I $D(DTOUT)!($D(DUOUT)) D KV^PSOVER1 S VALMBCK="" Q
     17EDTSEL S PSOLM=1,(PSONEW("DFLG"),PSONEW("FIELD"),PSONEW3)=0
     18 I +Y S LST=Y D HLDHDR^PSOLMUTL S PSOEDT=1 D  Q:$G(PSODIR("DFLG"))!($G(PSODIR("QFLG")))
     19 .F FLD=1:1:$L(LST,",") Q:$P(LST,",",FLD)']""  D @(+$P(LST,",",FLD)) Q:$G(PSODIR("DFLG"))!($G(PSODIR("QFLG")))
     20 E  S VALMBCK="" D FULL^VALM1
     21 Q
     22ACP I $G(PKI1)=1 D REA^PSOPKIV1 G:$G(PSONEW("QFLG"))=1 PKI
     23 D INST2^PSORENW S PSOFROM1=1 D:$D(^XUSEC("PSORPH",DUZ))!('$P(PSOPAR,"^",2)) VER
     24 K PSOFROM1
     25PKI I $G(PSONEW("QFLG")) S POERR("DFLG")=1,VALMBCK="R" K PSONEW2 Q
     26 I PSONEW("ENT")>0,$G(NEWDOSE) K NEWDOSE G EN1 Q
     27 S PSORX("FN")=1 D EN^PSORN52(.PSONEW)
     28 D RNPSOSD^PSOUTIL,ACP1^PSOORNE6,^PSOBUILD S VALMBCK="Q"
     29 Q
     30VER1(PSONEW) ;
     31VER S (PSONEW("DFLG"),PSONEW("QFLG"))=0 I PSONEW("ENT")=0 D  K PSOORRNW,PSOFROM1 I PSONEW("DFLG")=1 S (PSONEW("QFLG"),POERR("DFLG"))=1 Q
     32 .S (PSOREEDT,PSOORRNW)=1 W !!,"Dosing Instruction Missing!!",!
     33 .S PSONEW("IRXN")=PSONEW("OIRXN") K VALMSG D FULL^VALM1 W !,"Drug: "_PSODRUG("NAME") D
     34 ..I $O(SIG(0)) D  Q
     35 ...F I=1:1 Q:$G(SIG(I))']""  W !,SIG(I)
     36 ..I $P($G(^PSRX(PSONEW("OIRXN"),"SIG")),"^")]"" S X=$P(^PSRX(PSONEW("OIRXN"),"SIG"),"^") D SIGONE^PSOHELP W !,$E($G(INS1),2,250)
     37 .K DIRUT W ! D DOSE^PSODIR(.PSONEW) Q:$G(PSONEW("DFLG"))  D EN^PSOFSIG(.PSONEW)
     38 .I PSONEW("ENT")>0,$O(SIG(0)) S (SIGOK,NEWDOSE)=1
     39 .I '$G(SPEED),PSONEW("DFLG")=1 S VALMSG="Renewal Request Cancelled!" W:$G(SPEED) !,"Renewal Request Cancelled!" Q:$G(PSONEW("DFLG"))
     40 .I +$G(PSONEW("ENT"))'>0 K DIRUT Q
     41 .D INS^PSODIR(.PSONEW),EN^PSOFSIG(.PSONEW),SINS^PSODIR(.PSONEW):$G(^PS(55,PSODFN,"LAN"))
     42 .S:'$G(SPEED)&(PSONEW("DFLG")=1) VALMSG="Renewal Request Cancelled!" W:$G(SPEED)&(PSONEW("DFLG")=1) !,"Renewal Request Cancelled!"
     43 .I $G(SPEED),'$G(PSONEW("DFLG")) D KV^PSOVER1 S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR,KV^PSOVER1 K X,Y
     44 I +$G(PSONEW("ENT"))'>0 G VER
     45 D STOP^PSORENW1 I +$G(PSEXDT) D  S PSORENW("QFLG")=1
     46 .S Y=PSORENW("FILL DATE") X ^DD("DD") S VALMSG=Y_" fill date is past expiration date "
     47 .S Y=$P(PSEXDT,"^",2) X ^DD("DD") S VALMSG=VALMSG_Y_"."
     48 Q
     49DSPL G:$G(PSONEW("ENT"))>0 DSP
     50 S PSONEW("ENT")=0 F I=0:0 S I=$O(^PSRX(PSONEW("OIRXN"),6,I)) Q:'I  S DOSE=^PSRX(PSONEW("OIRXN"),6,I,0) D
     51 .S PSONEW("ENT")=PSONEW("ENT")+1,PSONEW("DOSE",PSONEW("ENT"))=$P(DOSE,"^")
     52 .S PSONEW("UNITS",PSONEW("ENT"))=$P(DOSE,"^",3),PSONEW("DOSE ORDERED",PSONEW("ENT"))=$P(DOSE,"^",2),PSONEW("ROUTE",PSONEW("ENT"))=$P(DOSE,"^",7)
     53 .S PSONEW("SCHEDULE",PSONEW("ENT"))=$P(DOSE,"^",8),PSONEW("DURATION",PSONEW("ENT"))=$P(DOSE,"^",5),PSONEW("CONJUNCTION",PSONEW("ENT"))=$P(DOSE,"^",6)
     54 .S PSONEW("NOUN",PSONEW("ENT"))=$P(DOSE,"^",4),PSONEW("VERB",PSONEW("ENT"))=$P(DOSE,"^",9)
     55 .I $G(^PSRX(PSONEW("OIRXN"),6,I,1))]"" S PSONEW("ODOSE",PSONEW("ENT"))=^PSRX(PSONEW("OIRXN"),6,I,1)
     56 .K DOSE
     57DSP D ^PSOORUT2 K ^TMP("PSOPO",$J) S IEN=0 D:$G(PKI1) L1^PSOPKIV1
     58 D DIN^PSONFI(PSODRUG("OI"),$S($G(PSODRUG("IEN")):PSODRUG("IEN"),1:""))
     59 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                 Rx#: "_PSONEW("NRX #")
     60 I +$G(PSODRUG("OI")) D
     61 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="      Orderable Item: "_$P(^PS(50.7,+$G(PSODRUG("OI")),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_NFIO
     62 .S:NFIO["<DIN>" NFIO=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
     63 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="     "_$S($D(^PSDRUG("AQ",PSODRUG("IEN"))):"      CMOP ",1:"           ")_"Drug: "_PSODRUG("NAME")_NFID
     64 S:NFID["<DIN>" NFID=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
     65 S:$G(PSONEW("TN"))]"" IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="          Trade Name: "_$G(PSONEW("TN"))
     66 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="      Patient Status: "_$P(PSONEW("PTST NODE"),"^"),PSONEW("PATIENT STATUS")=$P(PSONEW("PTST NODE"),"^")
     67 S (PSOID,Y)=PSONEW("ISSUE DATE") X ^DD("DD") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (1)     Issue Date: "_Y
     68 S Y=PSONEW("FILL DATE") X ^DD("DD") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (2)      Fill Date: "_Y
     69 I PSONEW("ENT")=0 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(PSOREEDT):"  (9)",1:"     ")_"         Dosage:" G PAT
     70 F I=1:1:PSONEW("ENT") D
     71 .I '$G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                Verb: "_$G(PSONEW("VERB",I))
     72 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(PSOREEDT)&(I'>1):"  (9)",1:"     ")_"         Dosage: "_$S($E(PSONEW("DOSE",I),1)="."&($G(PSONEW("DOSE ORDERED",I))):"0",1:"")_PSONEW("DOSE",I)
     73 .S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_$S($G(PSONEW("UNITS",I))]"":" ("_$P(^PS(50.607,PSONEW("UNITS",I),0),"^")_")",1:"")
     74 .I $P($G(^PS(55,PSODFN,"LAN")),"^"),'$G(PSONEW("DOSE ORDERED",I)) D
     75 ..S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="   Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I))
     76 .I $G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" D
     77 ..S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                Verb: "_$G(PSONEW("VERB",I))
     78 ..S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="      Dispense Units: "_$S($E($G(PSONEW("DOSE ORDERED",I)),1)=".":"0",1:"")_$G(PSONEW("DOSE ORDERED",I))
     79 ..S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                Noun: "_$G(PSONEW("NOUN",I))
     80 .I $G(PSONEW("ROUTE",I)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="               Route: "_$P(^PS(51.2,PSONEW("ROUTE",I),0),"^")
     81 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="            Schedule: "_PSONEW("SCHEDULE",I)
     82 .I $G(PSONEW("DURATION",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="           *Duration: "_$G(PSONEW("DURATION",I))
     83 .I $G(PSONEW("CONJUNCTION",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="         Conjunction: "_$S($G(PSONEW("CONJUNCTION",I))="A":"AND",$G(PSONEW("CONJUNCTION",I))="T":"THEN",$G(PSONEW("CONJUNCTION",I))="X":"EXCEPT",1:"")
     84PAT S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(PSOREEDT):" (10)",1:"     ")_"Pat Instruction:" D INS2^PSOBKDED
     85 S RXN=PSONEW("OIRXN") D INST1^PSORENW
     86 I $O(PRC(0)) D PC1^PSOORNE5
     87 K RXN S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                 SIG:"
     88 I $G(SIGOK),$O(SIG(0)) D  K SG,MIG
     89 .F I=0:0 S I=$O(SIG(I)) Q:'I  F SG=1:1:$L(SIG(I)) D
     90 ..S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(SIG(I)," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",21)=" "
     91 ..S:$P(SIG(I)," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(SIG(I)," ",SG)
     92 E  D
     93 .S X=$S($G(PSONEW("SIG"))]"":PSONEW("SIG"),1:$P($G(^PSRX(PSONEW("OIRXN"),"SIG")),"^")) D SIGONE^PSOHELP S SIG=$E($G(INS1),2,250)
     94 .F SG=1:1:$L(SIG) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(SIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",21)=" " S:$P(SIG," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(SIG," ",SG)
     95 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="         Days Supply: "_PSONEW("DAYS SUPPLY")_$S($L(PSONEW("DAYS SUPPLY"))=1:" ",1:"")
     96 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                 QTY"_$S($G(PSODRUG("UNIT"))]"":" ("_PSODRUG("UNIT")_")",1:" (  )")_": "_PSONEW("QTY")
     97 I $D(^PSDRUG("AQ",PSODRUG("IEN"))),$P($G(^PSDRUG(PSODRUG("IEN"),5)),"^")]"" D
     98 .S $P(RN," ",79)=" ",IEN=IEN+1
     99 .S ^TMP("PSOPO",$J,IEN,0)="            QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^")
     100 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (3)   # of Refills: "_PSONEW("# OF REFILLS")_$S($L(PSONEW("# OF REFILLS"))=1:" ",1:"")
     101 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (4)        Routing: "_$S($G(PSORENW("MAIL/WINDOW"))["W":"WINDOW",1:"MAIL")
     102 S:$G(PSONEW("METHOD OF PICK-UP"))]""&($P(PSOPAR,"^",12)) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="    Method of Pickup: "_PSONEW("METHOD OF PICK-UP")
     103 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (5)         Clinic: "_$S($G(PSONEW("CLINIC")):$P(^SC(PSONEW("CLINIC"),0),"^"),1:"")
     104 S $P(RN," ",31)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (6)       Provider: "_PSONEW("PROVIDER NAME")_$E(RN,$L(PSONEW("PROVIDER NAME"))+1,31) K RN
     105 I $G(PSONEW("COSIGNING PROVIDER"))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="        Cos-Provider: "_$P(^VA(200,PSONEW("COSIGNING PROVIDER"),0),"^")
     106 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (7)         Copies: "_$S($G(PSONEW("COPIES")):PSONEW("COPIES"),1:1)
     107RMK S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  (8)        Remarks: "_$S($G(PSONEW("REMARKS"))]"":PSONEW("REMARKS"),1:"")
     108 S $P(RN," ",35)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="   Entry By: "_$P(^VA(200,DUZ,0),"^")_$E(RN,$L($P(^VA(200,DUZ,0),"^"))+1,35)
     109 I $G(PSOFDR) S ^TMP("PSOPO",$J,IEN,0)="   Entry By: "_$P(^VA(200,$P(OR0,"^",4),0),"^")_$E(RN,$L($P(^VA(200,$P(OR0,"^",4),0),"^"))+1,35)
     110 D NOW^%DTC S PSONEW("LOGIN DATE")=$S($P($G(OR0),"^",6):$P($G(OR0),"^",6),1:%) K %,X S Y=PSONEW("LOGIN DATE") X ^DD("DD")
     111 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"Entry Date: "_$P(Y,"@")_" "_$P(Y,"@",2) K RN
     112 S (VALMCNT,PSOPF)=IEN
     113 Q
     1141 D 1^PSOBKDED Q
     1152 D 2^PSOBKDED Q
     1163 D 9^PSOBKDED Q
     1174 D 12^PSOBKDED Q
     1185 D 5^PSOBKDED Q
     1196 D 4^PSOBKDED Q
     1207 D 11^PSOBKDED Q
     1218 D 13^PSOBKDED Q
     1229 W !!,"Drug: "_PSODRUG("NAME") S PSOORRNW=1 D DOSE1^PSOORED5(.PSONEW)
     123 I $G(PSONEW("DFLG")) S PSODIR("DFLG")=1,VALMBCK="Q" Q
     124 D SV Q
     12510 D INS^PSODIR(.PSONEW),SINS^PSODIR(.PSONEW) D SV Q
     126SV D SV^PSOORNE5 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE5.m

    r613 r623  
    1 PSOORNE5        ;BIR/SAB - display orders from backdoor con't ;5/10/07 8:29am
    2         ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,78,99,117,131,146,171,180,210,222,268,206,225**;DEC 1997;Build 29
    3         ;External reference to ^PSDRUG supported by DBIA 221
    4         ;External references L and UL^PSSLOCK supported by DBIA 2789
    5         ;External reference to ^PS(51.2 supported by DBIA 2226
    6         ;External reference to ^PS(50.607 supported by DBIA 2221
    7         ;External reference ^PS(55 supported by DBIA 2228
    8         ;called from PSOORNE2
    9         ;PSO*210 add call to WORDWRAP api
    10         ;
    11 PEN     ;pending orders
    12         K ^TMP("PSOPO",$J),PSORX("ISSUE DATE"),PSORX("FILL DATE") S ORSV=ORD,ORD=$P(PSOLST(ORN),"^",2)
    13         I $P($G(^PS(52.41,ORD,0)),"^",3)="DC"!($P($G(^(0)),"^",3)="DE") S VALMBCK="R" Q
    14         I $G(PSODFN)'=$P($G(^PS(52.41,ORD,0)),"^",2) S VALMBCK="" Q
    15         I $G(PSOTPBFG) N PSOTPPEN,PSOTPPEX S PSOTPPEN=ORD,PSOTPPEX=0 D VOPNR^PSOTPCAN I PSOTPPEX K PSOTPPEX,PSOTPPEN S VALMBCK="R" Q
    16         K PSOTPPEX,PSOTPPEN
    17         ;I '$G(PSOTPBFG) D DSPL^PSOTPCAN(ORD)
    18         ;S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" Q
    19         I '$G(PSOFIN) S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient."),VALMBCK="" K PSOPLCK Q
    20         K PSOPLCK ; D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)_"S") I '$G(PSOMSG) S VAMLSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),PSOACT="" K PSOMSG G OK ;VALMBCK="" Q
    21         S PSODRG=+$P($G(^PS(52.41,ORD,0)),"^",9) I $G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) S VALMSG="This Drug has been Inactivated."
    22         K PSOMSG S PSOACT=$S($D(^XUSEC("PSORPH",DUZ)):"DEFX",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"")
    23 OK      S PAT=PSODFN,PSORNSV=ORN,PSORNLT=PSLST D ORD^PSOORFIN S PSLST=PSORNLT,ORD=ORSV,ORN=PSORNSV K ORSV,PSORNSV,PSORNLT,PSODRUG S VALMBCK="R"
    24         K ORCHK,ORDRG,PSOFDR,SIGOK,PSONEW,PSORX("ISSUE DATE"),PSORX("FILL DATE"),PSORX("FN")
    25         K:'$G(MEDP) PAT
    26         D CLEAN^PSOVER1 ;S X=PSODFN_";DPT(" D ULK^ORX2
    27         I '$G(PSOFIN) D UL^PSSLOCK(PSODFN)
    28         Q
    29 RXNCHK  S PSOY=$O(PSONEW("OLD LAST RX#","")) I PSOY="" D AUTO^PSONRXN Q
    30         S PSONRXN("TYPE")=$S('+$G(^PS(59,+PSOSITE,2)):8,PSODRUG("DEA")["A"&(+$G(^PS(59,+PSOSITE,2))):3,1:8)
    31         S PSONEW("QFLG")=0 I PSOY'=PSONRXN("TYPE"),$P($G(PSOPAR),"^",7)=1 D
    32         .S DIE="^PS(59,",DA=PSOSITE,PSOX=PSONEW("OLD LAST RX#",PSOY)
    33         .L +^PS(59,+PSOSITE,PSOY):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
    34         .S DR=$S(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX)
    35         .D:PSOX<$P(^PS(59,+PSOSITE,PSOY),"^",3) ^DIE K DIE,X,Y L -^PS(59,+PSOSITE,PSOY)
    36         .L +^PS(59,+PSOSITE,PSONRXN("TYPE")):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
    37         .S PSOX1=^PS(59,+PSOSITE,PSONRXN("TYPE")),PSONRXN("LO")=$P(PSOX1,"^")
    38         .S PSONRXN("HI")=$P(PSOX1,"^",2),PSOI=$P(PSOX1,"^",3),PSONEW("OLD LAST RX#",PSONRXN("TYPE"))=PSOI
    39         .S:PSOI<PSONRXN("LO") PSOI=PSONRXN("LO")
    40         .D LOOP2 I PSONEW("QFLG") L -^PS(59,+PSOSITE,PSONRXN("TYPE")),-^PSRX("B",PSOI) Q
    41         .K DIC,DIE,DA S DIE=59,DA=PSOSITE
    42         .S DR=$S(PSONRXN("TYPE")=8:"2003////"_PSOI,PSONRXN("TYPE")=3:"1002.1////"_PSOI,1:"2003////"_PSOI)
    43         .S PSONEW("RX #")=PSOI D ^DIE K DIE,DIC,DR,DA L -^PS(59,+PSOSITE,PSONRXN("TYPE"))
    44         .K PSOX1,PSONRXN,PSOI,X,Y
    45         Q
    46 LOOP2   F  S PSOI=PSOI+1 D:PSOI>PSONRXN("HI") FATAL^PSONRXN Q:'$D(^PSRX("B",PSOI))!PSONEW("QFLG")
    47         L +^PSRX("B",PSOI):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I $D(^PSRX("B",PSOI))!'$T G LOOP2
    48         L -^PSRX("B",PSOI)
    49         Q
    50 RDSPL   S PSODIR("CS")=0
    51         F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSODIR("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSODIR("CS"),"^",2)=1
    52         I $P($G(PSODIR("CS")),"^",2)=1 S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0 Q
    53         I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0 Q
    54         I $D(CLOZPAT) S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=$S($G(CLOZPAT)=2&(PSONEW("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSONEW("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSONEW("DAYS SUPPLY")=7):1,1:0) Q
    55         I PSODIR("CS") D
    56         .S PSOX=5,PSOX1=$S($P($G(PSONEW("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSONEW("PTST NODE")),"^",4)),PSOX=$S(PSOX1=5:PSOX,1:PSOX1)
    57         .S PSOX=$S('PSOX:0,PSONEW("DAYS SUPPLY")=90:1,1:PSOX),PSDY=PSONEW("DAYS SUPPLY"),PSDY1=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
    58         .I PSONEW("# OF REFILLS")>PSOX S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=PSOX
    59         E  D
    60         .S PSOX=11,PSOX1=$S($P($G(PSONEW("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSONEW("PTST NODE")),"^",4)),PSOX=$S(PSOX1=11:PSOX,1:PSOX1)
    61         .S PSDY=PSONEW("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
    62         .I PSONEW("# OF REFILLS")>PSOX S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=PSOX
    63         Q
    64 GET     ;
    65         I $P(PSODRUG0,"^",3)["2" S (ACTREF,ACTREN)=0 Q
    66         S (ACTREF,ACTREN)=1
    67         ;refills
    68         I ST S ACTREF=0
    69         I '$P(PSOPAR,"^",11),$G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) S ACTREF=0,VALMSG="Inactive Drug, Non Refillable!"
    70         ;I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" S ACTREF=0
    71         S PSORFRM=$P(RX0,"^",9) F PSOJ=0:0 S PSOJ=$O(^PSRX(RXN,1,PSOJ)) Q:'PSOJ  S PSORFRM=PSORFRM-1
    72         S:PSORFRM<0 PSORFRM=0 S:PSORFRM=0 ACTREF=0
    73         I $G(RXFL(RXN))]"",'$P(PSOPAR,"^",6) S ACTREF=0
    74         I $P(PSODRUG0,"^",3)["A"&($P(PSODRUG0,"^",3)'["B")!($P(PSODRUG0,"^",3)["F")!($P(PSODRUG0,"^",3)[1)!($P(PSODRUG0,"^",3)[2) S ACTREF=0
    75         ;renews
    76         I $P(PSOPAR,"^",4)=0 S ACTREN=0 Q
    77         I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" S ACTREN=0
    78         I $G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) S ACTREN=0,VALMSG="This Drug has been Inactivated."
    79         I '$P($G(^PSDRUG(PSODRG,2)),"^"),'$P($G(^PSRX(RXN,"OR1")),"^") S ACTREN=0,VALMSG="Drug must be Matched to an Orderable Item!"
    80         I ($P(PSODRUG0,"^",3)["W")!($P(PSODRUG0,"^",3)[1)!($P(PSODRUG0,"^",3)[2) S ACTREN=0
    81         I $D(^PS(53,+$P(RX0,"^",3),0)),'$P(^(0),"^",5) S ACTREN=0
    82         S PSOLC=$P(RX0,"^"),PSOLC=$E(PSOLC,$L(PSOLC)) I $A(PSOLC)'<90 S ACTREN=0
    83         I ST,ST'=2,ST'=5,ST'=6,ST'=11,ST'=12 S ACTREN=0
    84         K PSORFRM,PSOLC,PSODRG,PSODRUG0
    85         Q
    86 INST    ;formats instruction from front door
    87         D INST^PSOORNE6 Q
    88 PC      ;displays provider comments
    89         D PC^PSOORNE6 Q
    90 INST1   ;formats instruction from front door
    91         D INST1^PSOORNE6 Q
    92 PC1     ;displays provider comments
    93         D PC1^PSOORNE6 Q
    94 DOSE    ;displays dosing instruction for both simple and complex backdoor Rxs.
    95         I '$O(^PSRX(RXN,6,0))  S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" (3)          Dosage: " Q
    96         S DS=1 F I=0:0 S I=$O(^PSRX(RXN,6,I)) Q:'I  S DOSE=^PSRX(RXN,6,I,0) D
    97         .I '$P(DOSE,"^",2),$P(DOSE,"^",9)]"" S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="                Verb: "_$P(DOSE,"^",9)
    98         .I $G(DS)=1 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" (3)"
    99         .D DOSE1 S PSORXED("ENT")=$G(PSORXED("ENT"))+1
    100         K DOSE,I
    101         Q
    102 DOSE1   ;
    103         I $G(DS)=1 S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_"         *Dosage: "_$S($E($P(DOSE,"^"),1)="."&($P(DOSE,"^",2)):"0",1:"")_$P(DOSE,"^")_$S($P(DOSE,"^",3)]"":" ("_$P(^PS(50.607,$P(DOSE,"^",3),0),"^")_")",1:"") K DS G DU
    104         S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="             *Dosage: "_$S($E($P(DOSE,"^"),1)="."&($P(DOSE,"^",2)):"0",1:"")_$P(DOSE,"^")_$S($P(DOSE,"^",3)]"":" ("_$P(^PS(50.607,$P(DOSE,"^",3),0),"^")_")",1:"")
    105 DU      I '$P(DOSE,"^",2),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="   Oth. Lang. Dosage: "_$G(^PSRX(RXN,6,I,1))
    106         I $P(DOSE,"^",2),$P(DOSE,"^",9)]"" D
    107         .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="                Verb: "_$P(DOSE,"^",9)
    108         .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="      Dispense Units: "_$S($E($P(DOSE,"^",2),1)=".":"0",1:"")_$P(DOSE,"^",2)
    109         .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="                Noun: "_$P(DOSE,"^",4)
    110         I $P(DOSE,"^",7) S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="              *Route: "_$P(^PS(51.2,$P(DOSE,"^",7),0),"^")
    111         S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="           *Schedule: "_$P(DOSE,"^",8)
    112         I $P(DOSE,"^",5)]"" D
    113         .S DUR=$S($E($P(DOSE,"^",5),1)'?.N:$E($P(DOSE,"^",5),2,99)_$E($P(DOSE,"^",5),1),1:$P(DOSE,"^",5))
    114         .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="           *Duration: "_DUR_" ("_$S($P(DOSE,"^",5)["M":"MINUTES",$P(DOSE,"^",5)["H":"HOURS",$P(DOSE,"^",5)["L":"MONTHS",$P(DOSE,"^",5)["W":"WEEKS",1:"DAYS")_")" K DUR
    115         I $P(DOSE,"^",6)]"" S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="        *Conjunction: "_$S($P(DOSE,"^",6)="A":"AND",$P(DOSE,"^",6)="T":"THEN",$P(DOSE,"^",6)="X":"EXCEPT",1:"")
    116         Q
    117 INS     ;patient instructions                                        ;PSO*210
    118         I $G(^PSRX(RXN,"INS"))]"",'$O(^PSRX(RXN,"INS1",0)) D  K SG G SPINS
    119         .S PSORXED("SIG",1)=^PSRX(RXN,"INS")
    120         .D WORDWRAP^PSOUTLA2(^PSRX(RXN,"INS"),.IEN,$NA(^TMP("PSOAO",$J)),21)
    121         ;
    122         I $O(^PSRX(RXN,"INS1",0)) D
    123         .S T=0 F  S T=$O(^PSRX(RXN,"INS1",T)) Q:'T  D
    124         .. S (PSORXED("SIG",T),MIG)=^PSRX(RXN,"INS1",T,0)
    125         .. D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAO",$J)),21)
    126 SPINS   K T,SG,MIG
    127         I $P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="  Other Pat. Instruc: "_$S($G(^PSRX(RXN,"INSS"))]"":^PSRX(RXN,"INSS"),1:"")
    128         Q
    129 SV      S VALMSG="Pre-POE Rx. Please Compare Dosing Fields with SIG!"
    130         Q
     1PSOORNE5 ;BIR/SAB - display orders from backdoor con't ;5/23/05 1:46pm
     2 ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,78,99,117,131,146,171,180,210,222,268**;DEC 1997;Build 9
     3 ;External reference to ^PSDRUG supported by DBIA 221
     4 ;External references L and UL^PSSLOCK supported by DBIA 2789
     5 ;External reference to ^PS(51.2 supported by DBIA 2226
     6 ;External reference to ^PS(50.607 supported by DBIA 2221
     7 ;External reference ^PS(55 supported by DBIA 2228
     8 ;called from PSOORNE2
     9 ;PSO*210 add call to WORDWRAP api
     10 ;
     11PEN ;pending orders
     12 K ^TMP("PSOPO",$J),PSORX("ISSUE DATE"),PSORX("FILL DATE") S ORSV=ORD,ORD=$P(PSOLST(ORN),"^",2)
     13 I $P($G(^PS(52.41,ORD,0)),"^",3)="DC"!($P($G(^(0)),"^",3)="DE") S VALMBCK="R" Q
     14 I $G(PSODFN)'=$P($G(^PS(52.41,ORD,0)),"^",2) S VALMBCK="" Q
     15 I $G(PSOTPBFG) N PSOTPPEN,PSOTPPEX S PSOTPPEN=ORD,PSOTPPEX=0 D VOPNR^PSOTPCAN I PSOTPPEX K PSOTPPEX,PSOTPPEN S VALMBCK="R" Q
     16 K PSOTPPEX,PSOTPPEN
     17 ;I '$G(PSOTPBFG) D DSPL^PSOTPCAN(ORD)
     18 ;S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" Q
     19 I '$G(PSOFIN) S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient."),VALMBCK="" K PSOPLCK Q
     20 K PSOPLCK ; D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)_"S") I '$G(PSOMSG) S VAMLSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),PSOACT="" K PSOMSG G OK ;VALMBCK="" Q
     21 S PSODRG=+$P($G(^PS(52.41,ORD,0)),"^",9) I $G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) S VALMSG="This Drug has been Inactivated."
     22 K PSOMSG S PSOACT=$S($D(^XUSEC("PSORPH",DUZ)):"DEF",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"")
     23OK S PAT=PSODFN,PSORNSV=ORN,PSORNLT=PSLST D ORD^PSOORFIN S PSLST=PSORNLT,ORD=ORSV,ORN=PSORNSV K ORSV,PSORNSV,PSORNLT,PSODRUG S VALMBCK="R"
     24 K ORCHK,ORDRG,PSOFDR,SIGOK,PSONEW,PSORX("ISSUE DATE"),PSORX("FILL DATE"),PSORX("FN")
     25 K:'$G(MEDP) PAT
     26 D CLEAN^PSOVER1 ;S X=PSODFN_";DPT(" D ULK^ORX2
     27 I '$G(PSOFIN) D UL^PSSLOCK(PSODFN)
     28 Q
     29RXNCHK S PSOY=$O(PSONEW("OLD LAST RX#","")) I PSOY="" D AUTO^PSONRXN Q
     30 S PSONRXN("TYPE")=$S('+$G(^PS(59,+PSOSITE,2)):8,PSODRUG("DEA")["A"&(+$G(^PS(59,+PSOSITE,2))):3,1:8)
     31 S PSONEW("QFLG")=0 I PSOY'=PSONRXN("TYPE"),$P($G(PSOPAR),"^",7)=1 D
     32 .S DIE="^PS(59,",DA=PSOSITE,PSOX=PSONEW("OLD LAST RX#",PSOY)
     33 .L +^PS(59,+PSOSITE,PSOY):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
     34 .S DR=$S(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX)
     35 .D:PSOX<$P(^PS(59,+PSOSITE,PSOY),"^",3) ^DIE K DIE,X,Y L -^PS(59,+PSOSITE,PSOY)
     36 .L +^PS(59,+PSOSITE,PSONRXN("TYPE")):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
     37 .S PSOX1=^PS(59,+PSOSITE,PSONRXN("TYPE")),PSONRXN("LO")=$P(PSOX1,"^")
     38 .S PSONRXN("HI")=$P(PSOX1,"^",2),PSOI=$P(PSOX1,"^",3),PSONEW("OLD LAST RX#",PSONRXN("TYPE"))=PSOI
     39 .S:PSOI<PSONRXN("LO") PSOI=PSONRXN("LO")
     40 .D LOOP2 I PSONEW("QFLG") L -^PS(59,+PSOSITE,PSONRXN("TYPE")),-^PSRX("B",PSOI) Q
     41 .K DIC,DIE,DA S DIE=59,DA=PSOSITE
     42 .S DR=$S(PSONRXN("TYPE")=8:"2003////"_PSOI,PSONRXN("TYPE")=3:"1002.1////"_PSOI,1:"2003////"_PSOI)
     43 .S PSONEW("RX #")=PSOI D ^DIE K DIE,DIC,DR,DA L -^PS(59,+PSOSITE,PSONRXN("TYPE"))
     44 .K PSOX1,PSONRXN,PSOI,X,Y
     45 Q
     46LOOP2 F  S PSOI=PSOI+1 D:PSOI>PSONRXN("HI") FATAL^PSONRXN Q:'$D(^PSRX("B",PSOI))!PSONEW("QFLG")
     47 L +^PSRX("B",PSOI):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I $D(^PSRX("B",PSOI))!'$T G LOOP2
     48 L -^PSRX("B",PSOI)
     49 Q
     50RDSPL S PSODIR("CS")=0
     51 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSODIR("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSODIR("CS"),"^",2)=1
     52 I $P($G(PSODIR("CS")),"^",2)=1 S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0 Q
     53 I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0 Q
     54 I $D(CLOZPAT) S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=$S($G(CLOZPAT)=2&(PSONEW("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSONEW("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSONEW("DAYS SUPPLY")=7):1,1:0) Q
     55 I PSODIR("CS") D
     56 .S PSOX=5,PSOX1=$S($P($G(PSONEW("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSONEW("PTST NODE")),"^",4)),PSOX=$S(PSOX1=5:PSOX,1:PSOX1)
     57 .S PSOX=$S('PSOX:0,PSONEW("DAYS SUPPLY")=90:1,1:PSOX),PSDY=PSONEW("DAYS SUPPLY"),PSDY1=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
     58 .I PSONEW("# OF REFILLS")>PSOX S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=PSOX
     59 E  D
     60 .S PSOX=11,PSOX1=$S($P($G(PSONEW("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSONEW("PTST NODE")),"^",4)),PSOX=$S(PSOX1=11:PSOX,1:PSOX1)
     61 .S PSDY=PSONEW("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
     62 .I PSONEW("# OF REFILLS")>PSOX S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=PSOX
     63 Q
     64GET ;
     65 I $P(PSODRUG0,"^",3)["2" S (ACTREF,ACTREN)=0 Q
     66 S (ACTREF,ACTREN)=1
     67 ;refills
     68 I ST S ACTREF=0
     69 I '$P(PSOPAR,"^",11),$G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) S ACTREF=0,VALMSG="Inactive Drug, Non Refillable!"
     70 ;I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" S ACTREF=0
     71 S PSORFRM=$P(RX0,"^",9) F PSOJ=0:0 S PSOJ=$O(^PSRX(RXN,1,PSOJ)) Q:'PSOJ  S PSORFRM=PSORFRM-1
     72 S:PSORFRM<0 PSORFRM=0 S:PSORFRM=0 ACTREF=0
     73 I $G(RXFL(RXN))]"",'$P(PSOPAR,"^",6) S ACTREF=0
     74 I $P(PSODRUG0,"^",3)["A"&($P(PSODRUG0,"^",3)'["B")!($P(PSODRUG0,"^",3)["F") S ACTREF=0
     75 ;renews
     76 I $P(PSOPAR,"^",4)=0 S ACTREN=0 Q
     77 I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" S ACTREN=0
     78 I $G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) S ACTREN=0,VALMSG="This Drug has been Inactivated."
     79 I '$P($G(^PSDRUG(PSODRG,2)),"^"),'$P($G(^PSRX(RXN,"OR1")),"^") S ACTREN=0,VALMSG="Drug must be Matched to an Orderable Item!"
     80 I $P(PSODRUG0,"^",3)["A",$P(PSODRUG0,"^",3)'["B" S ACTREN=0
     81 I $P(PSODRUG0,"^",3)["W" S ACTREN=0
     82 I $D(^PS(53,+$P(RX0,"^",3),0)),'$P(^(0),"^",5) S ACTREN=0
     83 S PSOLC=$P(RX0,"^"),PSOLC=$E(PSOLC,$L(PSOLC)) I $A(PSOLC)'<90 S ACTREN=0
     84 I ST,ST'=2,ST'=5,ST'=6,ST'=11,ST'=12 S ACTREN=0
     85 K PSORFRM,PSOLC,PSODRG,PSODRUG0
     86 Q
     87INST ;formats instruction from front door
     88 D INST^PSOORNE6 Q
     89PC ;displays provider comments
     90 D PC^PSOORNE6 Q
     91INST1 ;formats instruction from front door
     92 D INST1^PSOORNE6 Q
     93PC1 ;displays provider comments
     94 D PC1^PSOORNE6 Q
     95DOSE ;displays dosing instruction for both simple and complex backdoor Rxs.
     96 I '$O(^PSRX(RXN,6,0))  S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" (3)          Dosage: " Q
     97 S DS=1 F I=0:0 S I=$O(^PSRX(RXN,6,I)) Q:'I  S DOSE=^PSRX(RXN,6,I,0) D
     98 .I '$P(DOSE,"^",2),$P(DOSE,"^",9)]"" S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="                Verb: "_$P(DOSE,"^",9)
     99 .I $G(DS)=1 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" (3)"
     100 .D DOSE1 S PSORXED("ENT")=$G(PSORXED("ENT"))+1
     101 K DOSE,I
     102 Q
     103DOSE1 ;
     104 I $G(DS)=1 S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_"         *Dosage: "_$S($E($P(DOSE,"^"),1)="."&($P(DOSE,"^",2)):"0",1:"")_$P(DOSE,"^")_$S($P(DOSE,"^",3)]"":" ("_$P(^PS(50.607,$P(DOSE,"^",3),0),"^")_")",1:"") K DS G DU
     105 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="             *Dosage: "_$S($E($P(DOSE,"^"),1)="."&($P(DOSE,"^",2)):"0",1:"")_$P(DOSE,"^")_$S($P(DOSE,"^",3)]"":" ("_$P(^PS(50.607,$P(DOSE,"^",3),0),"^")_")",1:"")
     106DU I '$P(DOSE,"^",2),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="   Oth. Lang. Dosage: "_$G(^PSRX(RXN,6,I,1))
     107 I $P(DOSE,"^",2),$P(DOSE,"^",9)]"" D
     108 .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="                Verb: "_$P(DOSE,"^",9)
     109 .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="      Dispense Units: "_$S($E($P(DOSE,"^",2),1)=".":"0",1:"")_$P(DOSE,"^",2)
     110 .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="                Noun: "_$P(DOSE,"^",4)
     111 I $P(DOSE,"^",7) S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="              *Route: "_$P(^PS(51.2,$P(DOSE,"^",7),0),"^")
     112 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="           *Schedule: "_$P(DOSE,"^",8)
     113 I $P(DOSE,"^",5)]"" D
     114 .S DUR=$S($E($P(DOSE,"^",5),1)'?.N:$E($P(DOSE,"^",5),2,99)_$E($P(DOSE,"^",5),1),1:$P(DOSE,"^",5))
     115 .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="           *Duration: "_DUR_" ("_$S($P(DOSE,"^",5)["M":"MINUTES",$P(DOSE,"^",5)["H":"HOURS",$P(DOSE,"^",5)["L":"MONTHS",$P(DOSE,"^",5)["W":"WEEKS",1:"DAYS")_")" K DUR
     116 I $P(DOSE,"^",6)]"" S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="        *Conjunction: "_$S($P(DOSE,"^",6)="A":"AND",$P(DOSE,"^",6)="T":"THEN",$P(DOSE,"^",6)="X":"EXCEPT",1:"")
     117 Q
     118INS ;patient instructions                                        ;PSO*210
     119 I $G(^PSRX(RXN,"INS"))]"",'$O(^PSRX(RXN,"INS1",0)) D  K SG G SPINS
     120 .S PSORXED("SIG",1)=^PSRX(RXN,"INS")
     121 .D WORDWRAP^PSOUTLA2(^PSRX(RXN,"INS"),.IEN,$NA(^TMP("PSOAO",$J)),21)
     122 ;
     123 I $O(^PSRX(RXN,"INS1",0)) D
     124 .S T=0 F  S T=$O(^PSRX(RXN,"INS1",T)) Q:'T  D
     125 .. S (PSORXED("SIG",T),MIG)=^PSRX(RXN,"INS1",T,0)
     126 .. D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAO",$J)),21)
     127SPINS K T,SG,MIG
     128 I $P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="  Other Pat. Instruc: "_$S($G(^PSRX(RXN,"INSS"))]"":^PSRX(RXN,"INSS"),1:"")
     129 Q
     130SV S VALMSG="Pre-POE Rx. Please Compare Dosing Fields with SIG!"
     131 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNEW.m

    r613 r623  
    1 PSOORNEW        ;BIR/SAB - display orders from oerr ;4/25/07 8:50am
    2         ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,55,46,71,90,94,106,131,133,143,237,222,258,206,225**;DEC 1997;Build 29
    3         ;^PS(50.7 -2223
    4         ;^PSDRUG -221
    5         ;^PS(50.606 -2174
    6         ;^PS(55 -2228
    7         ;EN1^ORCFLAG -3620
    8         ;
    9         ;PSO*237 quit Finish if Today > Issue date + 365
    10         ;
    11 DSPL    I $G(PSODSPL) S VALMBCK="Q" K PSODSPL,PSOANSQD Q
    12         Q:'$D(PSOLMC)  K ^TMP("PSOPO",$J) S PSOLMC=PSOLMC+1
    13         I $D(CLOZPAT) S PSONEW("DAYS SUPPLY")=$S($G(PSONEW("DAYS SUPPLY")):PSONEW("DAYS SUPPLY"),1:7) G OI
    14         S PSONEW("DAYS SUPPLY")=$S($G(PSONEW("DAYS SUPPLY")):PSONEW("DAYS SUPPLY"),+$G(^PS(55,PSODFN,"PS"))&($P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3))&('$G(PSONEW("DAYS SUPPLY"))):$P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3),1:30)
    15 OI      I '$G(PSODRUG("OI")) D
    16         .S (OI,PSODRUG("OI"))=$P(OR0,"^",8),PSODRUG("OIN")=$P(^PS(50.7,$P(OR0,"^",8),0),"^"),OID=$P(OR0,"^",9)
    17         .I $P($G(OR0),"^",9) S POERR=1,DREN=$P(OR0,"^",9) D DRG^PSOORDRG K POERR
    18         I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A",$G(PSODRUG("DEA"))'["B"!($G(PSODRUG("DEA"))["F")!($G(PSODRUG("DEA"))[1)!($G(PSODRUG("DEA"))[2) S PSONEW("# OF REFILLS")=0
    19         I $D(CLOZPAT) S PSONEW("# OF REFILLS")=$S($D(PSONEW("# OF REFILLS")):PSONEW("# OF REFILLS"),$G(CLOZPAT)=2&($P(OR0,"^",11)>2):3,$G(CLOZPAT)&($P(OR0,"^",11)>1):1,1:0)
    20         S IEN=0 D OBX^PSOORFI1,LMDISP^PSOORFI5(ORD),DIN^PSONFI(PSODRUG("OI"),$S($G(PSODRUG("IEN")):PSODRUG("IEN"),1:""))
    21         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="*(1) Orderable Item: "_$P(^PS(50.7,PSODRUG("OI"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_NFIO
    22         S:NFIO["<DIN>" NFIO=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
    23         K LST I $G(PSODRUG("NAME"))]"" D  G PT
    24         .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2)"_$S($D(^PSDRUG("AQ",PSODRUG("IEN"))):"      CMOP ",1:"           ")_"Drug: "_PSODRUG("NAME")_NFID
    25         .S:NFID["<DIN>" NFID=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
    26         .I $P($G(^PSDRUG(PSODRUG("IEN"),0)),"^",10)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       Drug Message:" D DRGMSG
    27         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2)           Drug: No Dispense Drug Selected"
    28 PT      D DOSE2^PSOORFI4
    29         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (4)   Pat Instruct:" D:$O(PSONEW("SIG",0)) INST^PSOORFI4
    30         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  Provider Comments:" S TY=3 D INST^PSOORFI1
    31         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       Instructions:" S TY=2 D INST^PSOORFI1
    32         K PSOELSE S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                SIG:"
    33         F I=0:0 S I=$O(SIG(I)) Q:'I  S SIG=SIG(I) D
    34         .F SG=1:1:$L(SIG) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(SIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S:$P(SIG," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(SIG," ",SG)
    35         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (5) Patient Status: "_$P($G(^PS(53,+PSONEW("PATIENT STATUS"),0)),"^")
    36         K PSOELSE I $G(PSONEW("ISSUE DATE"))']"" S PSOELSE=1 S IEN=IEN+1,(PSOID,Y)=$E($P(OR0,"^",6),1,7) X ^DD("DD") S PSONEW("ISSUE DATE")=Y,^TMP("PSOPO",$J,IEN,0)=" (4)     Issue Date: "_Y
    37         I '$G(PSOELSE) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (6)     Issue Date: "_PSONEW("ISSUE DATE")
    38         K PSOELSE I $G(PSORX("FILL DATE"))']"" S PSOELSE=1 D
    39         .S (Y,PSORX("FILL DATE"))=$S($E($P(OR0,"^",6),1,7)<DT:DT,1:$E($P(OR0,"^",6),1,7)) X ^DD("DD") S PSONEW("FILL DATE")=Y,^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"                  (5) Fill Date: "_Y
    40         I '$G(PSOELSE) S Y=PSORX("FILL DATE") X ^DD("DD") S PSORX("FILL DATE")=Y,^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"       (7) Fill Date: "_PSORX("FILL DATE")
    41         I $P(OR0,"^",18) S IEN=IEN+1,Y=$P(OR0,"^",18) X ^DD("DD") S $P(^TMP("PSOPO",$J,IEN,0)," ",39)="Effective Date: "_Y
    42         I $D(CLOZPAT) D ELIG^PSOORFI2 S:'$D(PSONEW("QTY")) PSONEW("QTY")=0
    43         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (8)    Days Supply: "_PSONEW("DAYS SUPPLY")
    44         S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"               (9)   QTY"_$S($P($G(^PSDRUG(+$G(PSODRUG("IEN")),660)),"^",8)]"":" ("_$P($G(^PSDRUG(+PSODRUG("IEN"),660)),"^",8)_")",1:" (  )")
    45         S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_": "_$S($G(PSONEW("QTY"))]"":PSONEW("QTY"),1:$P(OR0,"^",10))
    46         I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),5)),"^")]"" D
    47         .S $P(RN," ",79)=" ",IEN=IEN+1
    48         .S ^TMP("PSOPO",$J,IEN,0)=$E(RN,$L("QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^"))+1,79)_"QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^") K RN
    49         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       Provider ordered "_+$P(OR0,"^",11)_" refills"
    50         D:$D(CLOZPAT) PQTY^PSOORFI4
    51         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(10)   # of Refills: "_$S($G(PSONEW("# OF REFILLS"))]"":PSONEW("# OF REFILLS"),1:$P(OR0,"^",11))_"               (11)   Routing: "_$S($G(PSONEW("MAIL/WINDOW"))="M":"MAIL",1:"WINDOW")
    52         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(12)         Clinic: "_PSORX("CLINIC")
    53         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(13)       Provider: "_PSONEW("PROVIDER NAME")
    54         I $P($G(^VA(200,$S($G(PSONEW("PROVIDER")):PSONEW("PROVIDER"),1:$P(OR0,"^",5)),"PS")),"^",7)&($P($G(^("PS")),"^",8)) D
    55         .S IEN=IEN+1,PSONEW("COSIGNING PROVIDER")=$S($G(PSONEW("COSIGNING PROVIDER")):PSONEW("COSIGNING PROVIDER"),1:$P(^("PS"),"^",8))
    56         .S ^TMP("PSOPO",$J,IEN,0)="       Cos-Provider: "_$P(^VA(200,PSONEW("COSIGNING PROVIDER"),0),"^")
    57         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(14)         Copies: "_$S($G(PSONEW("COPIES")):PSONEW("COPIES"),1:1)
    58         S PSONEW("REMARKS")=$S($G(PSONEW("REMARKS"))]"":PSONEW("REMARKS"),$P(OR0,"^",17)="C":"Administered in Clinic.",1:"")
    59         S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(15)        Remarks:"
    60         I $G(PSONEW("REMARKS"))]"" D
    61         .F SG=1:1:$L(PSONEW("REMARKS")) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(PSONEW("REMARKS")," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " D
    62         ..S:$P(PSONEW("REMARKS")," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(PSONEW("REMARKS")," ",SG)
    63         I $G(PSOSIGFL)!(PSODRUG("OI")'=$P(OR0,"^",8)) S PSONEW("CLERK CODE")=DUZ,PSORX("CLERK CODE")=$P(^VA(200,DUZ,0),"^"),VALMSG="This change will create a new prescription!"
    64         S $P(RN," ",35)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="   Entry By: "_$P(^VA(200,PSONEW("CLERK CODE"),0),"^")_$E(RN,$L($P(^VA(200,PSONEW("CLERK CODE"),0),"^"))+1,35)
    65         S Y=$P(OR0,"^",12) X ^DD("DD") S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"Entry Date: "_$E($P(OR0,"^",12),4,5)_"/"_$E($P(OR0,"^",12),6,7)_"/"_$E($P(OR0,"^",12),2,3)_" "_$P(Y,"@",2) K RN
    66         I PSOLMC<2 D ^PSOLMPO1 S VALMBCK="Q",PSOLMC=0
    67         S:PSOLMC>1 VALMBCK="R"
    68         Q
    69 ORCHK   D PROVCOM^PSOORFI4,ORCHK^PSOORFI4
    70         Q
    71 EDT     D KV S DIR("A",1)="* Indicates which fields will create an new Order",DIR("A")="Select Field to Edit by number",DIR(0)="LO^1:15" D ^DIR Q:$D(DTOUT)!($D(DUOUT))
    72 EDTSEL  N LST,FLD,OUT D KV S OUT=0
    73         I +Y S LST=Y D FULL^VALM1 N PSODOSE M PSODOSE=PSONEW D  G DSPL
    74         .F FLD=1:1:$L(LST,",") Q:$P(LST,",",FLD)']""!(OUT)  D @(+$P(LST,",",FLD)) D:$P(LST,",",FLD)=8 REF D KV
    75         E  S VALMBCK="" Q
    76         Q
    77 ACP     ;
    78         I $G(ORD),+$P($G(^PS(52.41,+ORD,0)),"^",23)=1 D  Q:$D(DIRUT)!'Y  D EN1^ORCFLAG(+$P($G(^PS(52.41,ORD,0)),"^")) H 1
    79         . D FULL^VALM1 D KV
    80         . S DIR("A",1)="This Order is flagged. In order to finish it"
    81         . S DIR("A",2)="you must unflag it first."
    82         . S DIR("A",3)=""
    83         . S DIR(0)="Y",DIR("A")="Unflag Order",DIR("B")="NO"
    84         . W ! D ^DIR I $D(DIRUT)!'Y S VALMBCK="Q"
    85         I $G(ORD),+$P($G(^PS(52.41,+ORD,0)),"^",23)=1 Q
    86         ;
    87         I $D(CLOZPAT),+$G(PSONEW("QTY"))=0 S VALMSG="Unable to calculate the quantity, enter a quantity" G DSPL
    88         S (PSODIR("DFLG"),PSORX("DFLG"),PSODIR("QFLD"))=0,ACP=1 D ORCHK
    89         G:$G(PSONEW("QFLG")) DSPL
    90         I $G(PSODIR("DFLG"))!$G(PSORX("DFLG")) Q
    91         I $G(PSONEW("FLD"))!($G(PSODRUG("NAME"))']"")!('$O(SIG(0))) G DSPL
    92         I $G(PSODRUG("NAME"))]"",'$G(ORCHK)!($G(ORDRG)'=PSODRUG("NAME")) D  I $G(PSORX("DFLG")) D CLEAN^PSOVER1 G DSPL
    93         .D POST^PSODRG S:'$G(PSORX("DFLG")) ORCHK=1,ORDRG=PSODRUG("NAME")
    94         I '$D(PSONEW("RX #")) S PSOFROM="NEW",RTN=$S($P($G(PSOPAR),"^",7):"AUTO^PSONRXN",1:"MANUAL^PSONRXN") D @RTN Q:PSONEW("QFLG")  I '$P($G(PSOPAR),"^",7) S PSOX=PSONEW("RX #") D CHECK^PSONRXN
    95         D RXNCHK^PSOORNE1 I $G(PSONEW("QFLG")) S PSONEW("DFLG")=1 Q
    96         I DT>$$FMADD^XLFDT($P(OR0,"^",6),365) D EXPR^PSONEW2 G DSPL
    97         D STOP^PSONEW2,DISPLAY^PSONEW2,^PSONEWF
    98         I $G(PSOCPZ("DFLG")) W !!,"No action taken!",! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR,KV K PSOCPZ("DFLG"),DRET,PSOANSQD S VALMBCK="Q" Q
    99         ;
    100         K PSOCPZ("DFLG") D KV S DIR(0)="Y",DIR("A")="Are you sure you want to Accept this Order",DIR("B")="NO" D ^DIR I $D(DIRUT) D KV K DRET,PSOANSQ,PSOANSQD S VALMBCK="Q" Q
    101         D KV I 'Y K PSOANSQ G DSPL
    102         I $G(PSONEW("MAIL/WINDOW"))["W" D:$P($G(PSOPAR),"^",12)  S BINGCRT="Y",BINGRTE="W",PSORX("MAIL/WINDOW")="WINDOW" K RTN
    103         .W ! K DIR,DIRUT S DIR(0)="52,35O"
    104         .S:$G(PSORX("METHOD OF PICK-UP"))]"" DIR("B")=PSORX("METHOD OF PICK-UP") D ^DIR I $D(DIRUT) K DIR,DIRUT Q
    105         .S (PSONEW("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y K X,Y
    106         S PSONEW("POE")=1 D EN^PSON52(.PSONEW) G:$G(PSONEW("DFLG")) ABORT D DCORD^PSONEW2
    107         D NPSOSD^PSOUTIL(.PSONEW),FULL^VALM1 K PSORX("MAIL/WINDOW")
    108         D EOJ^PSONEW
    109 ABORT   S VALMBCK="Q",DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR,CLEAN^PSOVER1,KV
    110         Q
    111 KV      K DIRUT,DUOUT,DTOUT,DIR
    112         Q
    113 REF     D REF^PSOORFI4
    114         Q
    115 1       N PSOBDR,PSOBDRG S PSOBDRG=1 D 1^PSOORNW2 Q  ;oi
    116         ;
    117 4       D INS^PSOORNW2 Q
    118         ;
    119 3       D DOSE^PSOORED4(.PSONEW) Q
    120         ;
    121 6       D 4^PSOORNW2 Q  ;idt
    122         ;
    123 7       D 5^PSOORNW2 Q  ;fdt
    124         ;
    125 5       D 3^PSOORNW2 Q  ;pstat
    126         ;
    127 13      D 12^PSOORNW2 Q  ;doc
    128         ;
    129 12      D 11^PSOORNW2 Q  ;cli
    130         ;
    131 2       N PSOCSIG I '$G(PSOBDRG) N PSOBDR,PSOBDRG S PSOBDRG=1
    132         D 2^PSOORNW1 Q:$G(PSOQFLG)  D EN^PSODIAG  ;drg/ICD
    133         I $G(PSOCSIG) K PSOCSIG G 3
    134         Q
    135         ;
    136 9       D 8^PSOORNW2 Q  ;qty
    137         ;
    138 8       D 7^PSOORNW2 Q  ;ds
    139         ;
    140 10      D 9^PSOORNW2 Q  ;#rfs
    141         ;
    142 14      D 13^PSOORNW2 Q  ;cop
    143         ;
    144 11      D 10^PSOORNW2 Q  ;m/w
    145         ;
    146 15      D 14^PSOORNW2 Q  ;rem
    147         ;
    148 DRGMSG  ;
    149         F SG=1:1:$L($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " D
    150         .S:$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG)
    151         K SG Q
     1PSOORNEW ;BIR/SAB - display orders from oerr ;1/27/07  13:29
     2 ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,55,46,71,90,94,106,131,133,143,237,222,258,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ;^PS(50.7 -2223
     12 ;^PSDRUG -221
     13 ;^PS(50.606 -2174
     14 ;^PS(55 -2228
     15 ;PSO*237 quit Finish if Today > Issue date + 365
     16DSPL I $G(PSODSPL) S VALMBCK="Q" K PSODSPL,PSOANSQD Q
     17 Q:'$D(PSOLMC)  K ^TMP("PSOPO",$J) S PSOLMC=PSOLMC+1
     18 I $D(CLOZPAT) S PSONEW("DAYS SUPPLY")=$S($G(PSONEW("DAYS SUPPLY")):PSONEW("DAYS SUPPLY"),1:7) G OI
     19 S PSONEW("DAYS SUPPLY")=$S($G(PSONEW("DAYS SUPPLY")):PSONEW("DAYS SUPPLY"),+$G(^PS(55,PSODFN,"PS"))&($P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3))&('$G(PSONEW("DAYS SUPPLY"))):$P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3),1:30)
     20OI I '$G(PSODRUG("OI")) D
     21 .S (OI,PSODRUG("OI"))=$P(OR0,"^",8),PSODRUG("OIN")=$P(^PS(50.7,$P(OR0,"^",8),0),"^"),OID=$P(OR0,"^",9)
     22 .I $P($G(OR0),"^",9) S POERR=1,DREN=$P(OR0,"^",9) D DRG^PSOORDRG K POERR
     23 I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A",$G(PSODRUG("DEA"))'["B"!($G(PSODRUG("DEA"))["F") S PSONEW("# OF REFILLS")=0
     24 I $D(CLOZPAT) S PSONEW("# OF REFILLS")=$S($D(PSONEW("# OF REFILLS")):PSONEW("# OF REFILLS"),$G(CLOZPAT)=2&($P(OR0,"^",11)>2):3,$G(CLOZPAT)&($P(OR0,"^",11)>1):1,1:0)
     25 S IEN=0 D OBX^PSOORFI1,DIN^PSONFI(PSODRUG("OI"),$S($G(PSODRUG("IEN")):PSODRUG("IEN"),1:""))
     26 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="*(1) Orderable Item: "_$P(^PS(50.7,PSODRUG("OI"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_NFIO
     27 S:NFIO["<DIN>" NFIO=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
     28 K LST I $G(PSODRUG("NAME"))]"" D  G PT
     29 .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2)"_$S($D(^PSDRUG("AQ",PSODRUG("IEN"))):"      CMOP ",1:"           ")_"Drug: "_PSODRUG("NAME")_NFID
     30 .S:NFID["<DIN>" NFID=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4)
     31 .I $P($G(^PSDRUG(PSODRUG("IEN"),0)),"^",10)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       Drug Message:" D DRGMSG
     32 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2)           Drug: No Dispense Drug Selected"
     33PT D DOSE2^PSOORFI4
     34 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (4)   Pat Instruct:" D:$O(PSONEW("SIG",0)) INST^PSOORFI4
     35 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="  Provider Comments:" S TY=3 D INST^PSOORFI1
     36 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       Instructions:" S TY=2 D INST^PSOORFI1
     37 K PSOELSE S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="                SIG:"
     38 F I=0:0 S I=$O(SIG(I)) Q:'I  S SIG=SIG(I) D
     39 .F SG=1:1:$L(SIG) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(SIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S:$P(SIG," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(SIG," ",SG)
     40 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (5) Patient Status: "_$P($G(^PS(53,+PSONEW("PATIENT STATUS"),0)),"^")
     41 K PSOELSE I $G(PSONEW("ISSUE DATE"))']"" S PSOELSE=1 S IEN=IEN+1,(PSOID,Y)=$E($P(OR0,"^",6),1,7) X ^DD("DD") S PSONEW("ISSUE DATE")=Y,^TMP("PSOPO",$J,IEN,0)=" (4)     Issue Date: "_Y
     42 I '$G(PSOELSE) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (6)     Issue Date: "_PSONEW("ISSUE DATE")
     43 K PSOELSE I $G(PSORX("FILL DATE"))']"" S PSOELSE=1 D
     44 .S (Y,PSORX("FILL DATE"))=$S($E($P(OR0,"^",6),1,7)<DT:DT,1:$E($P(OR0,"^",6),1,7)) X ^DD("DD") S PSONEW("FILL DATE")=Y,^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"                  (5) Fill Date: "_Y
     45 I '$G(PSOELSE) S Y=PSORX("FILL DATE") X ^DD("DD") S PSORX("FILL DATE")=Y,^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"       (7) Fill Date: "_PSORX("FILL DATE")
     46 I $P(OR0,"^",18) S IEN=IEN+1,Y=$P(OR0,"^",18) X ^DD("DD") S $P(^TMP("PSOPO",$J,IEN,0)," ",39)="Effective Date: "_Y
     47 I $D(CLOZPAT) D ELIG^PSOORFI2 S:'$D(PSONEW("QTY")) PSONEW("QTY")=0
     48 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (8)    Days Supply: "_PSONEW("DAYS SUPPLY")
     49 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"               (9)   QTY"_$S($P($G(^PSDRUG(+$G(PSODRUG("IEN")),660)),"^",8)]"":" ("_$P($G(^PSDRUG(+PSODRUG("IEN"),660)),"^",8)_")",1:" (  )")
     50 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_": "_$S($G(PSONEW("QTY"))]"":PSONEW("QTY"),1:$P(OR0,"^",10))
     51 I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),5)),"^")]"" D
     52 .S $P(RN," ",79)=" ",IEN=IEN+1
     53 .S ^TMP("PSOPO",$J,IEN,0)=$E(RN,$L("QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^"))+1,79)_"QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^") K RN
     54 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="       Provider ordered "_+$P(OR0,"^",11)_" refills"
     55 D:$D(CLOZPAT) PQTY^PSOORFI4
     56 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(10)   # of Refills: "_$S($G(PSONEW("# OF REFILLS"))]"":PSONEW("# OF REFILLS"),1:$P(OR0,"^",11))_"               (11)   Routing: "_$S($G(PSONEW("MAIL/WINDOW"))="M":"MAIL",1:"WINDOW")
     57 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(12)         Clinic: "_PSORX("CLINIC")
     58 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(13)       Provider: "_PSONEW("PROVIDER NAME")
     59 I $P($G(^VA(200,$S($G(PSONEW("PROVIDER")):PSONEW("PROVIDER"),1:$P(OR0,"^",5)),"PS")),"^",7)&($P($G(^("PS")),"^",8)) D
     60 .S IEN=IEN+1,PSONEW("COSIGNING PROVIDER")=$S($G(PSONEW("COSIGNING PROVIDER")):PSONEW("COSIGNING PROVIDER"),1:$P(^("PS"),"^",8))
     61 .S ^TMP("PSOPO",$J,IEN,0)="       Cos-Provider: "_$P(^VA(200,PSONEW("COSIGNING PROVIDER"),0),"^")
     62 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(14)         Copies: "_$S($G(PSONEW("COPIES")):PSONEW("COPIES"),1:1)
     63 S PSONEW("REMARKS")=$S($G(PSONEW("REMARKS"))]"":PSONEW("REMARKS"),$P(OR0,"^",17)="C":"Administered in Clinic.",1:"")
     64 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(15)        Remarks:"
     65 I $G(PSONEW("REMARKS"))]"" D
     66 .F SG=1:1:$L(PSONEW("REMARKS")) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(PSONEW("REMARKS")," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " D
     67 ..S:$P(PSONEW("REMARKS")," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(PSONEW("REMARKS")," ",SG)
     68 I $G(PSOSIGFL)!(PSODRUG("OI")'=$P(OR0,"^",8)) S PSONEW("CLERK CODE")=DUZ,PSORX("CLERK CODE")=$P(^VA(200,DUZ,0),"^"),VALMSG="This change will create a new prescription!"
     69 S $P(RN," ",35)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="   Entry By: "_$P(^VA(200,PSONEW("CLERK CODE"),0),"^")_$E(RN,$L($P(^VA(200,PSONEW("CLERK CODE"),0),"^"))+1,35)
     70 S Y=$P(OR0,"^",12) X ^DD("DD") S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"Entry Date: "_$E($P(OR0,"^",12),4,5)_"/"_$E($P(OR0,"^",12),6,7)_"/"_$E($P(OR0,"^",12),2,3)_" "_$P(Y,"@",2) K RN
     71 I PSOLMC<2 D ^PSOLMPO1 S VALMBCK="Q",PSOLMC=0
     72 S:PSOLMC>1 VALMBCK="R"
     73 Q
     74ORCHK D PROVCOM^PSOORFI4
     75 I $G(PSOAFYN)'="Y" D ORCHK^PSOORFI4
     76 Q
     77EDT D KV S DIR("A",1)="* Indicates which fields will create an new Order",DIR("A")="Select Field to Edit by number",DIR(0)="LO^1:15" D ^DIR Q:$D(DTOUT)!($D(DUOUT))
     78EDTSEL N LST,FLD,OUT D KV S OUT=0
     79 I +Y S LST=Y D FULL^VALM1 N PSODOSE M PSODOSE=PSONEW D  G DSPL
     80 .F FLD=1:1:$L(LST,",") Q:$P(LST,",",FLD)']""!(OUT)  D @(+$P(LST,",",FLD)) D:$P(LST,",",FLD)=8 REF D KV
     81 E  S VALMBCK="" Q
     82 Q
     83ACP ;
     84 I $D(CLOZPAT),+$G(PSONEW("QTY"))=0 S VALMSG="Unable to calculate the quantity, enter a quantity" G DSPL
     85 S (PSODIR("DFLG"),PSORX("DFLG"),PSODIR("QFLD"))=0,ACP=1 D ORCHK
     86 G:$G(PSONEW("QFLG")) DSPL
     87 I $G(PSODIR("DFLG"))!$G(PSORX("DFLG")) Q
     88 I $G(PSONEW("FLD"))!($G(PSODRUG("NAME"))']"")!('$O(SIG(0))) G DSPL
     89 I $G(PSODRUG("NAME"))]"",'$G(ORCHK)!($G(ORDRG)'=PSODRUG("NAME")) D  I $G(PSORX("DFLG")) D CLEAN^PSOVER1 G DSPL
     90 .D POST^PSODRG S:'$G(PSORX("DFLG")) ORCHK=1,ORDRG=PSODRUG("NAME")
     91 I '$D(PSONEW("RX #")) S PSOFROM="NEW",RTN=$S($P($G(PSOPAR),"^",7):"AUTO^PSONRXN",1:"MANUAL^PSONRXN") D @RTN Q:PSONEW("QFLG")  I '$P($G(PSOPAR),"^",7) S PSOX=PSONEW("RX #") D CHECK^PSONRXN
     92 D RXNCHK^PSOORNE1 I $G(PSONEW("QFLG")) S PSONEW("DFLG")=1 Q
     93 I DT>$$FMADD^XLFDT($P(OR0,"^",6),365) D EXPR^PSONEW2 G DSPL
     94 I $G(PSOAFYN)'="Y" D STOP^PSONEW2,DISPLAY^PSONEW2,^PSONEWF
     95 I $G(PSOAFYN)="Y" D STOP^PSONEW2
     96 I $G(PSOCPZ("DFLG")) W !!,"No action taken!",! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR,KV K PSOCPZ("DFLG"),DRET,PSOANSQD S VALMBCK="Q" Q
     97 I $G(PSOAFYN)'="Y" K PSOCPZ("DFLG") D KV S DIR(0)="Y",DIR("A")="Are you sure you want to Accept this Order",DIR("B")="NO" D ^DIR I $D(DIRUT) D KV K DRET,PSOANSQ,PSOANSQD S VALMBCK="Q" Q
     98 I $G(PSOAFYN)="Y" S Y="1"
     99 D KV I 'Y K PSOANSQ G DSPL
     100 I $G(PSONEW("MAIL/WINDOW"))["W" D:$P($G(PSOPAR),"^",12)  S BINGCRT="Y",BINGRTE="W",PSORX("MAIL/WINDOW")="WINDOW" K RTN
     101 .I $G(PSOAFYN)'="Y" W ! K DIR,DIRUT S DIR(0)="52,35O"
     102 .I $G(PSOAFYN)'="Y" S:$G(PSORX("METHOD OF PICK-UP"))]"" DIR("B")=PSORX("METHOD OF PICK-UP") D ^DIR I $D(DIRUT) K DIR,DIRUT Q
     103 .I $G(PSOAFYN)'="Y" S (PSONEW("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y K X,Y
     104 .I $G(PSOAFYN)="Y" S (PSONEW("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))="AutoFinished for Rx Printing"
     105 S PSONEW("POE")=1 D EN^PSON52(.PSONEW) G:$G(PSONEW("DFLG")) ABORT D DCORD^PSONEW2
     106 D NPSOSD^PSOUTIL(.PSONEW),FULL^VALM1 K PSORX("MAIL/WINDOW")
     107 D EOJ^PSONEW
     108ABORT ;
     109 I $G(PSOAFYN)'="Y" S VALMBCK="Q",DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR,CLEAN^PSOVER1,KV ;vfah
     110 I $G(PSOAFYN)="Y" D CLEAN^PSOVER1,KV ;vfah
     111 Q
     112KV K DIRUT,DUOUT,DTOUT,DIR
     113 Q
     114REF D REF^PSOORFI4
     115 Q
     1161 N PSOBDR,PSOBDRG S PSOBDRG=1 D 1^PSOORNW2 Q  ;oi
     117 ;
     1184 D INS^PSOORNW2 Q
     119 ;
     1203 D DOSE^PSOORED4(.PSONEW) Q
     121 ;
     1226 D 4^PSOORNW2 Q  ;idt
     123 ;
     1247 D 5^PSOORNW2 Q  ;fdt
     125 ;
     1265 D 3^PSOORNW2 Q  ;pstat
     127 ;
     12813 D 12^PSOORNW2 Q  ;doc
     129 ;
     13012 D 11^PSOORNW2 Q  ;cli
     131 ;
     1322 N PSOCSIG I '$G(PSOBDRG) N PSOBDR,PSOBDRG S PSOBDRG=1
     133 D 2^PSOORNW1 Q:$G(PSOQFLG)  D EN^PSODIAG  ;drg/ICD
     134 I $G(PSOCSIG) K PSOCSIG G 3
     135 Q
     136 ;
     1379 D 8^PSOORNW2 Q  ;qty
     138 ;
     1398 D 7^PSOORNW2 Q  ;ds
     140 ;
     14110 D 9^PSOORNW2 Q  ;#rfs
     142 ;
     14314 D 13^PSOORNW2 Q  ;cop
     144 ;
     14511 D 10^PSOORNW2 Q  ;m/w
     146 ;
     14715 D 14^PSOORNW2 Q  ;rem
     148 ;
     149DRGMSG ;
     150 D DRGMSG^PSOORNW2 Q  ;vfam
     151 ;

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNW1.m

    r613 r623  
    1 PSOORNW1        ;ISC BHAM/SAB - continuation of finish of new order ;5/10/07 8:30am
    2         ;;7.0;OUTPATIENT PHARMACY;**23,46,78,117,131,133,172,148,222,268,206**;DEC 1997;Build 39
    3         ;Reference ^YSCL(603.01 supported by DBIA 2697
    4         ;Reference ^PS(55 supported by DBIA 2228
    5         ;Reference ^PSDRUG( supported by DBIA 221
    6         ;Reference to $$GETNDC^PSSNDCUT supported by IA 4707
    7         ;
    8 2       I $G(ORD) W !!,"Instructions: " D
    9         .S INST=0 F  S INST=$O(^PS(52.41,ORD,2,INST)) Q:'INST  S (MIG,INST(INST))=^PS(52.41,ORD,2,INST,0) D
    10         ..F SG=1:1:$L(MIG," ") W:$X+$L($P(MIG," ",SG)_" ")>IOM !?14 W $P(MIG," ",SG)_" "
    11         .S:'$D(PSODRUG("OI")) PSODRUG("OI")=$P(OR0,"^",8)
    12         .K INST,TY,MIG,SG
    13         S (PSDC,PSI)=0 W !!,"The following Drug(s) are available for selection:"
    14         F PSI=0:0 S PSI=$O(^PSDRUG("ASP",PSODRUG("OI"),PSI)) Q:'PSI  I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($P($G(^PSDRUG(PSI,2)),"^",3)'["O":0,1:1) D
    15         .S PSDC=PSDC+1 W !,PSDC_". "_$P(^PSDRUG(PSI,0),"^")_$S($P(^(0),"^",9):"     (N/F)",1:"")
    16         .S PSDC(PSDC)=PSI
    17         I PSDC=0 D
    18         . N X,DRG
    19         . S DRG=+$P($G(^PS(52.41,+$G(ORD),0)),"^",9)
    20         . S X=$$GET1^DIQ(50,DRG,100)
    21         . I X'="",(DT>X) D
    22         . . W !!,"   This Dispense Drug is now Inactive. You may select a"
    23         . . W !,"    new Orderable Item, or you can enter a new Order with"
    24         . . W !,"    an Active Drug.",!
    25         . E  W !!,"No drugs available!",!
    26         . K DIR S DIR(0)="E",DIR("A")="Press return to continue"
    27         . D ^DIR K DIR
    28         G:'PSDC ETX I $G(PSOBDRG),'$D(PSOBDR) M PSOBDR=PSODRUG
    29         I PSDC'=1 D
    30         .I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),2)),"^")=$G(PSODRUG("OI")) Q
    31         .K PSODRUG("NAME"),PSODRUG("IEN")
    32         W ! D KV S DIR(0)="N^1:"_PSDC,DIR("A")="Select Drug by number" D ^DIR
    33         I $D(DIRUT) S OUT=1 G EX
    34         D KV K PSOY S PSOY=PSDC(Y),PSOY(0)=^PSDRUG(PSOY,0),PSOCSIG=0
    35         I $G(PSOBDR("IEN")),PSOBDR("IEN")'=+PSOY D:$G(ORD)  G:$D(DIRUT) EX
    36         .D KV S DIR(0)="Y",DIR("B")="YES",DIR("A",1)="You have changed the dispense drug from",DIR("A",2)=PSOBDR("NAME")_" to "_$P(^PSDRUG(+PSOY,0),"^")_".",DIR("A")="Do You want to Edit the SIG"
    37         .D ^DIR I $D(DIRUT) S OUT=1 Q
    38         .S:Y PSOCSIG=1
    39         .I 'Y D URX I $D(DIRUT) S OUT=1 Q
    40         D KV
    41 CT1     I $P($G(^PSDRUG(PSOY,"CLOZ1")),"^")="PSOCLO1",'$O(^YSCL(603.01,"C",PSODFN,0)) S VALMSG="Patient Not Registered in Clozapine Program",VALMBCK="Q" K PSOY,PSDC Q
    42         S PSODRUG("IEN")=+PSOY,PSODRUG("VA CLASS")=$P(PSOY(0),"^",2),PSODRUG("NAME")=$P(PSOY(0),"^")
    43         S PSODRUG("NDF")=$S($G(^PSDRUG(+PSOY,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)
    44         S PSODRUG("MAXDOSE")=$P(PSOY(0),"^",4),PSODRUG("DEA")=$P(PSOY(0),"^",3),PSODRUG("CLN")=$S($D(^PSDRUG(+PSOY,"ND")):+$P(^("ND"),"^",6),1:0)
    45         S PSODRUG("SIG")=$P(PSOY(0),"^",5),PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSOY,$G(PSOSITE)),PSODRUG("STKLVL")=$G(^PSDRUG(+PSOY,660.1))
    46         S PSODRUG("DAW")=+$$GET1^DIQ(50,+PSOY,81)
    47         I $G(^PSDRUG(+PSOY,660))']"" D:'$G(PSOFIN)&('$G(PSOCOPY)) POST^PSODRG G ETX
    48         S PSOX1=$G(^PSDRUG(+PSOY,660)),PSODRUG("COST")=$P($G(PSOX1),"^",6),PSODRUG("UNIT")=$P($G(PSOX1),"^",8),PSODRUG("EXPIRATION DATE")=$P($G(PSOX1),"^",9)
    49         D:'$G(PSOFIN)&('$G(PSOCOPY)) POST^PSODRG
    50         I $G(PSORX("DFLG")) K PSODRUG N LST Q:$G(PSOAC)!($G(NEWEDT))  D DSPL^PSOORFI1 S VALMBCK="Q" Q
    51 ETX     D REF S VALMBCK="R" I 'PSDC S VALMSG="NO dispense drugs tied to this orderable item!" S PSOQFLG=1
    52 TX      D KV K PSDC,PSI,X,Y,PSOX1,PSOY
    53         Q
    54 EX      M PSODRUG=PSOBDR K PSOBDR,PSOBDRG S PSOQFLG=1,VALMBCK="R" D MP1^PSOOREDX
    55         D TX Q
    56 URX     D KV S DIR(0)="Y",DIR("A")="Are You Sure You Want to Update Rx",DIR("B")="Yes"
    57         D ^DIR S:$D(DIRUT)!('Y) DIRUT=1
    58         Q
    59 REF     Q:'$D(PSODRUG("DEA"))!('$G(PSODRUG("IEN")))!('$G(^PS(55,PSODFN,"PS")))
    60         S PSONEW("CS")=0,PTRF=$S(+$G(^PS(55,PSODFN,"PS"))&($P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",4)]""):$P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",4),1:5)
    61         F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSONEW("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSONEW("CS"),"^",2)=1
    62         I $P($G(PSONEW("CS")),"^",2)=1 S PSONEW("# OF REFILLS")=0 Q
    63         I +PSONEW("CS") D
    64         .S PSOX=$S($P($G(OR0),"^",11)>5:5,1:+$P($G(OR0),"^",11))
    65         .S PSOX=$S(PSOX>PTRF:PTRF,1:PSOX)
    66         .S PSONEW("# OF REFILLS")=PSOX
    67         E  D
    68         .S PSOX=$S($P($G(OR0),"^",11)'>PTRF&($P($G(OR0),"^",11)'>11):11,1:PTRF)
    69         I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) S PSOX=0,PSONEW("# OF REFILLS")=0 K PSDY,PSDY1,PTRF Q
    70         I $D(CLOZPAT) S (PSOX,PSONEW("N# REF"),PSONEW("# OF REFILLS"))=$S(CLOZPAT=2&($G(PSONEW("# OF REFILLS"))>2):3,CLOZPAT&($G(PSONEW("# OF REFILLS"))>1):1,1:0),PSONEW("DAYS SUPPLY")=7,ORCHK=1 K PSDY,PSDY1,PTRF Q
    71         S PSONEW("# OF REFILLS")=$S($G(PSONEW("# OF REFILLS"))'="":$G(PSONEW("# OF REFILLS")),1:PSOX) K PSDY,PSDY1,PTRF
    72         Q
    73 EDNEW   K PSMAX,PSFMAX F DEA=1:1 Q:$E(PSODEA,DEA)=""  I $E(+PSODEA,DEA)>1,$E(+PSODEA,DEA)<6 S CS=1
    74         I CS D
    75         .S PSOX1=$S(PTRF>5:5,1:PTRF),PSOX=$S(PSOX1=5:5,1:PSOX1)
    76         .S PSOX=$S('PSOX:0,PSDAYS=90:1,1:PSOX),PSDY1=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0) S MAX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
    77         E  D
    78         .S PSOX1=PTRF,PSOX=$S(PSOX1=11:11,1:PSOX1),PSOX=$S('PSOX:0,PSDAYS=90:3,1:PSOX)
    79         .S PSDY1=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0) S MAX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
    80         I PSRF>MAX D
    81         .W $C(7),!!,PSRF_" refills are not correct for a "_PSDAYS_" day supply.",!,"Please enter correct # of refills for a "_PSDAYS_" day supply. Max refills allowed is "_MAX_".",!
    82         .S (PSMAX("MAX"),PSFMAX("MAX"))=MAX,(PSMAX("RF"),PSFMAX("RF"))=PSRF,(PSMAX("DAYS"),PSFMAX("DAYS"))=PSDAYS,(PSMAX,PSFMAX)=1
    83         K PSTMAX D EDSTAT
    84         Q
    85 STATDAY K PSMAX,PSRMAX,PSFMAX,PSTMAX S PSDAYS=$P(^PSRX(DA,0),"^",8),PSRF=$P(^PSRX(DA,0),"^",9),PTST=$P(^PS(53,X,0),"^"),PTDY=$P(^(0),"^",3),PTRF=$P(^(0),"^",4)
    86 EDSTAT  I PSRF>PTRF W !,$C(7),PSRF_" refills are greater than "_PTRF_" allowed for "_$P(PTST,"^")_" Rx Patient Status.",! S PSTMAX=1,PSTMAX("PTRF")=PTRF,PSTMAX("PSRF")=PSRF,PSTMAX("PT")=$P(PTST,"^")
    87         Q
    88 OERF    S DIR(0)="N^0:"_PSOX,DIR("A")="# OF REFILLS"
    89         S DIR("B")=$S($G(POERR):PSONEW("# OF REFILLS"),$G(PSONEW("N# REF"))]"":PSONEW("N# REF"),$G(PSONEW("# OF REFILLS"))]"":PSONEW("# OF REFILLS"),$G(PSOX1)]""&(PSOX>PSOX1):PSOX1,1:PSOX)
    90         S DIR("?")="Enter a whole number.  The maximum is set by the Rx Patient Status because there is no Dispense Drug."
    91         D ^DIR G:$D(DIRUT) REFX
    92         S (PSONEW("N# REF"),PSONEW("# OF REFILLS"))=Y
    93 REFX    S:'$D(PSONEW("# OF REFILLS")) PSONEW("# OF REFILLS")=$S($G(PSONEW("N# REF"))]"":PSONEW("N# REF"),$G(PSOX1)]""&($G(PSOX)>PSOX1):PSOX1,1:PSOX)
    94         K X,Y,PSOX,PSOX1,PSDY,PSDY1,DEA
    95 KV      K DIR,DIRUT,DUOUT,DTOUT
    96         Q
     1PSOORNW1 ;ISC BHAM/SAB - continuation of finish of new order ;07/19/96 12:58 PM
     2 ;;7.0;OUTPATIENT PHARMACY;**23,46,78,117,131,133,172,148,222,268**;DEC 1997;Build 9
     3 ;Reference ^YSCL(603.01 supported by DBIA 2697
     4 ;Reference ^PS(55 supported by DBIA 2228
     5 ;Reference ^PSDRUG( supported by DBIA 221
     6 ;Reference to $$GETNDC^PSSNDCUT supported by IA 4707
     7 ;
     82 I $G(ORD) W !!,"Instructions: " D
     9 .S INST=0 F  S INST=$O(^PS(52.41,ORD,2,INST)) Q:'INST  S (MIG,INST(INST))=^PS(52.41,ORD,2,INST,0) D
     10 ..F SG=1:1:$L(MIG," ") W:$X+$L($P(MIG," ",SG)_" ")>IOM !?14 W $P(MIG," ",SG)_" "
     11 .S:'$D(PSODRUG("OI")) PSODRUG("OI")=$P(OR0,"^",8)
     12 .K INST,TY,MIG,SG
     13 S (PSDC,PSI)=0 W !!,"The following Drug(s) are available for selection:"
     14 F PSI=0:0 S PSI=$O(^PSDRUG("ASP",PSODRUG("OI"),PSI)) Q:'PSI  I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($P($G(^PSDRUG(PSI,2)),"^",3)'["O":0,1:1) D
     15 .S PSDC=PSDC+1 W !,PSDC_". "_$P(^PSDRUG(PSI,0),"^")_$S($P(^(0),"^",9):"     (N/F)",1:"")
     16 .S PSDC(PSDC)=PSI
     17 I PSDC=0 D
     18 . N X,DRG
     19 . S DRG=+$P($G(^PS(52.41,+$G(ORD),0)),"^",9)
     20 . S X=$$GET1^DIQ(50,DRG,100)
     21 . I X'="",(DT>X) D
     22 . . W !!,"   This Dispense Drug is now Inactive. You may select a"
     23 . . W !,"    new Orderable Item, or you can enter a new Order with"
     24 . . W !,"    an Active Drug.",!
     25 . E  W !!,"No drugs available!",!
     26 . K DIR S DIR(0)="E",DIR("A")="Press return to continue"
     27 . D ^DIR K DIR
     28 G:'PSDC ETX I $G(PSOBDRG),'$D(PSOBDR) M PSOBDR=PSODRUG
     29 I PSDC'=1 D
     30 .I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),2)),"^")=$G(PSODRUG("OI")) Q
     31 .K PSODRUG("NAME"),PSODRUG("IEN")
     32 W ! D KV S DIR(0)="N^1:"_PSDC,DIR("A")="Select Drug by number" D ^DIR
     33 I $D(DIRUT) S OUT=1 G EX
     34 D KV K PSOY S PSOY=PSDC(Y),PSOY(0)=^PSDRUG(PSOY,0),PSOCSIG=0
     35 I $G(PSOBDR("IEN")),PSOBDR("IEN")'=+PSOY D:$G(ORD)  G:$D(DIRUT) EX
     36 .D KV S DIR(0)="Y",DIR("B")="YES",DIR("A",1)="You have changed the dispense drug from",DIR("A",2)=PSOBDR("NAME")_" to "_$P(^PSDRUG(+PSOY,0),"^")_".",DIR("A")="Do You want to Edit the SIG"
     37 .D ^DIR I $D(DIRUT) S OUT=1 Q
     38 .S:Y PSOCSIG=1
     39 .I 'Y D URX I $D(DIRUT) S OUT=1 Q
     40 D KV
     41CT1 I $P($G(^PSDRUG(PSOY,"CLOZ1")),"^")="PSOCLO1",'$O(^YSCL(603.01,"C",PSODFN,0)) S VALMSG="Patient Not Registered in Clozapine Program",VALMBCK="Q" K PSOY,PSDC Q
     42 S PSODRUG("IEN")=+PSOY,PSODRUG("VA CLASS")=$P(PSOY(0),"^",2),PSODRUG("NAME")=$P(PSOY(0),"^")
     43 S PSODRUG("NDF")=$S($G(^PSDRUG(+PSOY,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)
     44 S PSODRUG("MAXDOSE")=$P(PSOY(0),"^",4),PSODRUG("DEA")=$P(PSOY(0),"^",3),PSODRUG("CLN")=$S($D(^PSDRUG(+PSOY,"ND")):+$P(^("ND"),"^",6),1:0)
     45 S PSODRUG("SIG")=$P(PSOY(0),"^",5),PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSOY,$G(PSOSITE)),PSODRUG("STKLVL")=$G(^PSDRUG(+PSOY,660.1))
     46 S PSODRUG("DAW")=+$$GET1^DIQ(50,+PSOY,81)
     47 I $G(^PSDRUG(+PSOY,660))']"" D:'$G(PSOFIN)&('$G(PSOCOPY)) POST^PSODRG G ETX
     48 S PSOX1=$G(^PSDRUG(+PSOY,660)),PSODRUG("COST")=$P($G(PSOX1),"^",6),PSODRUG("UNIT")=$P($G(PSOX1),"^",8),PSODRUG("EXPIRATION DATE")=$P($G(PSOX1),"^",9)
     49 D:'$G(PSOFIN)&('$G(PSOCOPY)) POST^PSODRG
     50 I $G(PSORX("DFLG")) K PSODRUG N LST Q:$G(PSOAC)!($G(NEWEDT))  D DSPL^PSOORFI1 S VALMBCK="Q" Q
     51ETX D REF S VALMBCK="R" I 'PSDC S VALMSG="NO dispense drugs tied to this orderable item!" S PSOQFLG=1
     52TX D KV K PSDC,PSI,X,Y,PSOX1,PSOY
     53 Q
     54EX M PSODRUG=PSOBDR K PSOBDR,PSOBDRG S PSOQFLG=1,VALMBCK="R" D MP1^PSOOREDX
     55 D TX Q
     56URX D KV S DIR(0)="Y",DIR("A")="Are You Sure You Want to Update Rx",DIR("B")="Yes"
     57 D ^DIR S:$D(DIRUT)!('Y) DIRUT=1
     58 Q
     59REF Q:'$D(PSODRUG("DEA"))!('$G(PSODRUG("IEN")))!('$G(^PS(55,PSODFN,"PS")))
     60 S PSONEW("CS")=0,PTRF=$S(+$G(^PS(55,PSODFN,"PS"))&($P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",4)]""):$P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",4),1:5)
     61 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSONEW("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSONEW("CS"),"^",2)=1
     62 I $P($G(PSONEW("CS")),"^",2)=1 S PSONEW("# OF REFILLS")=0 Q
     63 I +PSONEW("CS") D
     64 .S PSOX=$S($P($G(OR0),"^",11)>5:5,1:+$P($G(OR0),"^",11))
     65 .S PSOX=$S(PSOX>PTRF:PTRF,1:PSOX)
     66 .S PSONEW("# OF REFILLS")=PSOX
     67 E  D
     68 .S PSOX=$S($P($G(OR0),"^",11)'>PTRF&($P($G(OR0),"^",11)'>11):11,1:PTRF)
     69 I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") S PSOX=0,PSONEW("# OF REFILLS")=0 K PSDY,PSDY1,PTRF Q
     70 I $D(CLOZPAT) S (PSOX,PSONEW("N# REF"),PSONEW("# OF REFILLS"))=$S(CLOZPAT=2&($G(PSONEW("# OF REFILLS"))>2):3,CLOZPAT&($G(PSONEW("# OF REFILLS"))>1):1,1:0),PSONEW("DAYS SUPPLY")=7,ORCHK=1 K PSDY,PSDY1,PTRF Q
     71 S PSONEW("# OF REFILLS")=$S($G(PSONEW("# OF REFILLS"))'="":$G(PSONEW("# OF REFILLS")),1:PSOX) K PSDY,PSDY1,PTRF
     72 Q
     73EDNEW K PSMAX,PSFMAX F DEA=1:1 Q:$E(PSODEA,DEA)=""  I $E(+PSODEA,DEA)>1,$E(+PSODEA,DEA)<6 S CS=1
     74 I CS D
     75 .S PSOX1=$S(PTRF>5:5,1:PTRF),PSOX=$S(PSOX1=5:5,1:PSOX1)
     76 .S PSOX=$S('PSOX:0,PSDAYS=90:1,1:PSOX),PSDY1=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0) S MAX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
     77 E  D
     78 .S PSOX1=PTRF,PSOX=$S(PSOX1=11:11,1:PSOX1),PSOX=$S('PSOX:0,PSDAYS=90:3,1:PSOX)
     79 .S PSDY1=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0) S MAX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
     80 I PSRF>MAX D
     81 .W $C(7),!!,PSRF_" refills are not correct for a "_PSDAYS_" day supply.",!,"Please enter correct # of refills for a "_PSDAYS_" day supply. Max refills allowed is "_MAX_".",!
     82 .S (PSMAX("MAX"),PSFMAX("MAX"))=MAX,(PSMAX("RF"),PSFMAX("RF"))=PSRF,(PSMAX("DAYS"),PSFMAX("DAYS"))=PSDAYS,(PSMAX,PSFMAX)=1
     83 K PSTMAX D EDSTAT
     84 Q
     85STATDAY K PSMAX,PSRMAX,PSFMAX,PSTMAX S PSDAYS=$P(^PSRX(DA,0),"^",8),PSRF=$P(^PSRX(DA,0),"^",9),PTST=$P(^PS(53,X,0),"^"),PTDY=$P(^(0),"^",3),PTRF=$P(^(0),"^",4)
     86EDSTAT I PSRF>PTRF W !,$C(7),PSRF_" refills are greater than "_PTRF_" allowed for "_$P(PTST,"^")_" Rx Patient Status.",! S PSTMAX=1,PSTMAX("PTRF")=PTRF,PSTMAX("PSRF")=PSRF,PSTMAX("PT")=$P(PTST,"^")
     87 Q
     88OERF S DIR(0)="N^0:"_PSOX,DIR("A")="# OF REFILLS"
     89 S DIR("B")=$S($G(POERR):PSONEW("# OF REFILLS"),$G(PSONEW("N# REF"))]"":PSONEW("N# REF"),$G(PSONEW("# OF REFILLS"))]"":PSONEW("# OF REFILLS"),$G(PSOX1)]""&(PSOX>PSOX1):PSOX1,1:PSOX)
     90 S DIR("?")="Enter a whole number.  The maximum is set by the Rx Patient Status because there is no Dispense Drug."
     91 D ^DIR G:$D(DIRUT) REFX
     92 S (PSONEW("N# REF"),PSONEW("# OF REFILLS"))=Y
     93REFX S:'$D(PSONEW("# OF REFILLS")) PSONEW("# OF REFILLS")=$S($G(PSONEW("N# REF"))]"":PSONEW("N# REF"),$G(PSOX1)]""&($G(PSOX)>PSOX1):PSOX1,1:PSOX)
     94 K X,Y,PSOX,PSOX1,PSDY,PSDY1,DEA
     95KV K DIR,DIRUT,DUOUT,DTOUT
     96 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNW2.m

    r613 r623  
    1 PSOORNW2        ;ISC-BHAM/SAB - edit orders from oerr ;9:45 AM  31 Dec 2008
    2         ;;7.0;OUTPATIENT PHARMACY;**10,23,37,46,117,131,133,148,222,269,206;208**;Build 41;Build 39;WorldVistA 30-Jan-08
    3         ;
    4         ;Modified from FOIA VISTA,
    5         ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    6         ;General Public License See attached copy of the License.
    7         ;
    8         ;This program is free software; you can redistribute it and/or modify
    9         ;it under the terms of the GNU General Public License as published by
    10         ;the Free Software Foundation; either version 2 of the License, or
    11         ;(at your option) any later version.
    12         ;
    13         ;This program is distributed in the hope that it will be useful,
    14         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    15         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    16         ;GNU General Public License for more details.
    17         ;
    18         ;You should have received a copy of the GNU General Public License along
    19         ;with this program; if not, write to the Free Software Foundation, Inc.,
    20         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    21         ;
    22         ;Reference to ^YSCL(603.01 supported by DBIA 2697
    23         ;Reference to ^PS(55 supported by DBIA 2228
    24         ;Reference to ^PSDRUG( supported by DBIA 221
    25         ;Reference to ^PS(50.606 supported by DBIA 2174
    26         ;Reference to ^PS(50.7 supported by DBIA 2223
    27         ;Reference to $$GETNDC^PSSNDCUT supported by IA 4707
    28         ;
    29 1       I $G(PSODRUG("OI")) M:$G(PSOBDRG) PSOBDR=PSODRUG W !!,"Current Orderable Item: "_$P(^PS(50.7,PSODRUG("OI"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")
    30         S DIC("B")=$S($G(PSODRUG("OIN"))]"":PSODRUG("OIN"),1:""),DIC="^PS(50.7,",DIC(0)="AEMQZ"
    31         S DIC("S")="I '$P(^PS(50.7,+Y,0),""^"",4)!($P(^(0),""^"",4)'<DT) N PSOF,PSOL S (PSOF,PSOL)=0 F  S PSOL=$O(^PSDRUG(""ASP"",+Y,PSOL)) Q:PSOF!'PSOL  "
    32         S DIC("S")=DIC("S")_"I $P($G(^PSDRUG(PSOL,2)),U,3)[""O"",'$G(^(""I""))!($G(^(""I""))'<DT) S PSOF=1"
    33         ;BHW;PSO*7*269;Modify ^DIC call to call MIX^DIC to use only the B and C Cross-References.
    34         S D="B^C" D MIX^DIC1 K DIC,D I X["^"!($D(DTOUT)) S OUT=1 Q
    35         S PSOY=Y
    36         I +Y'=OI D  I 'Y!($D(DIRUT)) D KV,MP1^PSOOREDX K DIC,Y,PSOY S OUT=1 Q
    37         .D KV S DIR(0)="Y",DIR("B")="NO",DIR("A",1)="",DIR("A")="This edit will create a new order.  Do you want to continue" D ^DIR
    38         G:Y<1 1 S PSODRUG("OI")=+PSOY,PSODRUG("OIN")=$P(PSOY,"^",2),PSONEW("CLERK CODE")=DUZ D KV K DIC,PSOY
    39         N PSOIC S PSOIC=1 D DREN
    40         D 2^PSOORNEW Q
    41 4       S PSONEW("FLD")=1 D ISSDT^PSODIR2(.PSONEW) ; Issue Date
    42         I PSOID>PSONEW("FILL DATE") S PSONEW("FILL DATE")=PSOID,PSORX("FILL DATE")=PSORX("ISSUE DATE")
    43         Q
    44         ;
    45 5       S PSONEW("FLD")=2 D FILLDT^PSODIR2(.PSONEW) ; Fill date
    46         Q
    47         ;
    48 INS     S PSONEW("FLD")=114 D INS^PSODIR(.PSONEW) ; Pat Inst
    49         I $P($G(^PS(55,PSODFN,"LAN")),"^") D SINS^PSODIR(.PSONEW)
    50         Q
    51         ;
    52 3       S PSONEW("FLD")=3 D PTSTAT^PSODIR1(.PSONEW) ; Get Patient Status
    53         I +$G(^PS(55,PSODFN,"PS")) S RXPT=+^("PS") I $G(^PS(53,RXPT,0))]"" D  Q
    54         .S PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:+$P(OR0,"^",11)),PSOMAX=+$P(^PS(53,RXPT,0),"^",4)
    55         .S PSOMAX=$S($G(PSOCS):5,1:11),PSOMAX=$S(PSOMAX>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:PSOMAX)
    56         .S PSONEW("# OF REFILLS")=$S(PSONEW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSONEW("# OF REFILLS"))
    57         I $G(PSOMAX) S PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11))
    58         I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F")!($G(PSODRUG("DEA"))[1)!($G(PSODRUG("DEA"))[2) D
    59         .S PSONEW("# OF REFILLS")=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["A":"this narcotic drug.",1:"this drug.")
    60         Q
    61         ;
    62 12      S PSONEW("FLD")=4 D PROV^PSODIR(.PSONEW) ; Get Provider
    63         Q
    64         ;
    65 11      S PSONEW("FLD")=5 D CLINIC^PSODIR2(.PSONEW) ; Get Clinic
    66         Q
    67         ;
    68 8       S PSONEW("FLD")=7 D QTY^PSODIR1(.PSONEW) ; Get quantity
    69         Q
    70         ;
    71 7       I '$G(PSODRUG("IEN")) W $C(7),!!,"No Dispense Drug!",! K DIR,DUOUT,DIRUT,DTOUT D 2^PSOORNW1
    72         I '$G(PSODRUG("IEN")) W !,$C(7),"No Dispense Drug Selected! A new Orderable Item may need to be selected.",! Q
    73         S PSONEW("FLD")=8 D DAYS^PSODIR1(.PSONEW) ; Get days supply
    74         Q:'$G(PSONEW("PATIENT STATUS"))
    75         K PSDY,PSDY1,PSMAX,PSTMAX S PSDAYS=PSONEW("DAYS SUPPLY"),PSRF=PSONEW("# OF REFILLS"),PTST=$P(^PS(53,PSONEW("PATIENT STATUS"),0),"^"),PTDY=$P(^(0),"^",3),PTRF=$P(^(0),"^",4),PSODEA=PSODRUG("DEA"),CS=0 ;D EDNEW^PSOORNW1
    76         Q
    77 9       ;
    78         I '$G(PSONEW("PATIENT STATUS")) W !!,"Rx Patient Status required!",! D 3 I '$G(PSONEW("PATIENT STATUS")) S VALMSG="Rx Patient Status required!",VALMBCK="R" Q
    79         I +$G(^PS(55,PSODFN,"PS")) S RXPT=+^("PS") I $G(^PS(53,RXPT,0))]"" D  G ASK
    80         .S PSOMAX=$S($G(CLOZPAT)=2:3,$G(CLOZPAT)=1:1,$G(CLOZPAT)=0:0,1:+$P(^PS(53,RXPT,0),"^",4)) K RXPT
    81         .S:'$G(PSONEW("# OF REFILLS")) PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11))
    82         .S (PSONEW("N# REF"),PSONEW("# OF REFILLS"))=$S(PSONEW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSONEW("# OF REFILLS"))
    83         .I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F")!($G(PSODRUG("DEA"))[1)!($G(PSODRUG("DEA"))[2) D  Q
    84         ..S (PSOMAX,PSONEW("N# REF"),PSONEW("# OF REFILLS"))=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["A":"this narcotic drug.",1:"this drug.")
    85         .I $D(PSODRUG("DEA")) F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S PSOMAX=5
    86         I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F")!($G(PSODRUG("DEA"))[1)!($G(PSODRUG("DEA"))[2) D  Q
    87         .S (PSONEW("N# REF"),PSONEW("# OF REFILLS"))=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["A":"this narcotic drug.",1:"this drug.")
    88         S (PSONEW("N# REF"),PSOMAX,PSONEW("# OF REFILLS"))=+$P(OR0,"^",11)
    89 ASK     S PSONEW("FLD")=9 D REFILL^PSODIR1(.PSONEW) ; Get # of refills
    90         K PSOMAX,PSMAX,PSTMAX S PSDAYS=PSONEW("DAYS SUPPLY"),PSRF=PSONEW("# OF REFILLS"),PTST=$P(^PS(53,PSONEW("PATIENT STATUS"),0),"^"),PTDY=$P(^(0),"^",3),PTRF=$P(^(0),"^",4),PSODEA=$G(PSODRUG("DEA")),CS=0 D EDNEW^PSOORNW1
    91         Q
    92         ;
    93 6       Q  K DA S PSONEW("FLD")=10 D SIG^PSODIR1(.PSONEW) ; Get sig
    94         I $G(PSONEW("SIG"))]"" D EN^PSOSIGNO(ORD,PSONEW("SIG")) S SIG(1)=PSONEW("SIG")
    95         I $G(PSOSIGFL) D
    96         .K DIRUT,DUOUT,DTOUT,DIR S DIR(0)="Y",DIR("B")="NO",DIR("A",1)="",DIR("A")="This edit will create a new order.  Do you want to continue" D ^DIR
    97         .I 'Y!($D(DIRUT)) K DIR,DIRUT,DUOUT,DTOUT,DIC,Y,PSOSIGFL,PSONEW("SIG") S SIGOK=1
    98         S PSONEW("CLERK CODE")=DUZ K DIR,DIRUT,DUOUT,DTOUT,DIC,Y
    99         Q
    100         ;
    101 13      S PSONEW("FLD")=11 D COPIES^PSODIR1(.PSONEW) ; Get # of copies
    102         Q
    103         ;
    104 10      S PSONEW("FLD")=12 D MW^PSODIR2(.PSONEW) ; Get Mail/Window Info
    105         Q
    106         ;
    107 14      S PSONEW("FLD")=13 D RMK^PSODIR2(.PSONEW) ; Get Remarks
    108         Q
    109         ;WVEHR ;begin p208
    110         ;
    111 DRGMSG  ;From PSOORNEW
    112         F SG=1:1:$L($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " D
    113         .S:$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10),"",SG)
    114         K SG Q
    115         ;
    116         ;WVEHR ;end p208
    117 DREN    ;
    118         S (PSDC,PSI)=0
    119         F  S PSI=$O(^PSDRUG("ASP",PSODRUG("OI"),PSI)) Q:'PSI  I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($P($G(^PSDRUG(PSI,2)),"^",3)'["O":0,1:1) S PSDC=PSDC+1,PSDC(PSDC)=PSI
    120         I PSDC'=1 D  G DRENX
    121         .I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),2)),"^")=$G(PSODRUG("OI")) Q
    122         .K PSODRUG("NAME"),PSODRUG("IEN")
    123         K PSOY S PSI=PSDC(1),PSOY=^PSDRUG(PSI,0)
    124         I $P($G(^PSDRUG(PSI,"CLOZ1")),"^")="PSOCLO1",'$O(^YSCL(603.01,"C",PSODFN,0)) K PSOY,PSI Q
    125         S PSODRUG("IEN")=+PSI,PSODRUG("VA CLASS")=$P(PSOY,"^",2),PSODRUG("NAME")=$P(PSOY,"^")
    126         S PSODRUG("NDF")=$S($G(^PSDRUG(PSI,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)
    127         S PSODRUG("MAXDOSE")=$P(PSOY,"^",4),PSODRUG("DEA")=$P(PSOY,"^",3),PSODRUG("CLN")=$S($D(^PSDRUG(+PSI,"ND")):+$P(^("ND"),"^",6),1:0)
    128         S PSODRUG("SIG")=$P(PSOY,"^",5),PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSI,$G(PSOSITE)),PSODRUG("STKLVL")=$G(^PSDRUG(+PSI,660.1))
    129         S PSODRUG("DAW")=+$$GET1^DIQ(50,+PSI,81)
    130         G:$G(^PSDRUG(+PSI,660))']"" DRENX
    131         S PSOX1=$G(^PSDRUG(+PSI,660)),PSODRUG("COST")=$P($G(PSOX1),"^",6),PSODRUG("UNIT")=$P($G(PSOX1),"^",8),PSODRUG("EXPIRATION DATE")=$P($G(PSOX1),"^",9)
    132 DRENX   K PSDC,PSI,PSOY,Y,PSOXI,X Q
    133 KV      K DIR,DIRUT,DUOUT,DTOUT Q
     1PSOORNW2 ;ISC-BHAM/SAB - edit orders from oerr ; 12/10/06 9:55pm
     2 ;;7.0;OUTPATIENT PHARMACY;**10,23,37,46,117,131,133,148,222,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 ;Reference to ^YSCL(603.01 supported by DBIA 2697
     20 ;Reference to ^PS(55 supported by DBIA 2228
     21 ;Reference to ^PSDRUG( supported by DBIA 221
     22 ;Reference to ^PS(50.606 supported by DBIA 2174
     23 ;Reference to ^PS(50.7 supported by DBIA 2223
     24 ;Reference to $$GETNDC^PSSNDCUT supported by IA 4707
     25 ;
     261 I $G(PSODRUG("OI")) M:$G(PSOBDRG) PSOBDR=PSODRUG W !!,"Current Orderable Item: "_$P(^PS(50.7,PSODRUG("OI"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")
     27 S DIC("B")=$S($G(PSODRUG("OIN"))]"":PSODRUG("OIN"),1:""),DIC="^PS(50.7,",DIC(0)="AEMQZ"
     28 S DIC("S")="I '$P(^PS(50.7,+Y,0),""^"",4)!($P(^(0),""^"",4)'<DT) N PSOF,PSOL S (PSOF,PSOL)=0 F  S PSOL=$O(^PSDRUG(""ASP"",+Y,PSOL)) Q:PSOF!'PSOL  "
     29 S DIC("S")=DIC("S")_"I $P($G(^PSDRUG(PSOL,2)),U,3)[""O"",'$G(^(""I""))!($G(^(""I""))'<DT) S PSOF=1" D ^DIC K DIC I X["^"!($D(DTOUT)) S OUT=1 Q
     30 S PSOY=Y
     31 I +Y'=OI D  I 'Y!($D(DIRUT)) D KV,MP1^PSOOREDX K DIC,Y,PSOY S OUT=1 Q
     32 .D KV S DIR(0)="Y",DIR("B")="NO",DIR("A",1)="",DIR("A")="This edit will create a new order.  Do you want to continue" D ^DIR
     33 G:Y<1 1 S PSODRUG("OI")=+PSOY,PSODRUG("OIN")=$P(PSOY,"^",2),PSONEW("CLERK CODE")=DUZ D KV K DIC,PSOY
     34 N PSOIC S PSOIC=1 D DREN
     35 D 2^PSOORNEW Q
     364 S PSONEW("FLD")=1 D ISSDT^PSODIR2(.PSONEW) ; Issue Date
     37 I PSOID>PSONEW("FILL DATE") S PSONEW("FILL DATE")=PSOID,PSORX("FILL DATE")=PSORX("ISSUE DATE")
     38 Q
     39 ;
     405 S PSONEW("FLD")=2 D FILLDT^PSODIR2(.PSONEW) ; Fill date
     41 Q
     42 ;
     43INS S PSONEW("FLD")=114 D INS^PSODIR(.PSONEW) ; Pat Inst
     44 I $P($G(^PS(55,PSODFN,"LAN")),"^") D SINS^PSODIR(.PSONEW)
     45 Q
     46 ;
     473 S PSONEW("FLD")=3 D PTSTAT^PSODIR1(.PSONEW) ; Get Patient Status
     48 I +$G(^PS(55,PSODFN,"PS")) S RXPT=+^("PS") I $G(^PS(53,RXPT,0))]"" D  Q
     49 .S PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:+$P(OR0,"^",11)),PSOMAX=+$P(^PS(53,RXPT,0),"^",4)
     50 .S PSOMAX=$S($G(PSOCS):5,1:11),PSOMAX=$S(PSOMAX>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:PSOMAX)
     51 .S PSONEW("# OF REFILLS")=$S(PSONEW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSONEW("# OF REFILLS"))
     52 I $G(PSOMAX) S PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11))
     53 I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F") D
     54 .S PSONEW("# OF REFILLS")=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics ...")
     55 Q
     56 ;
     5712 S PSONEW("FLD")=4 D PROV^PSODIR(.PSONEW) ; Get Provider
     58 Q
     59 ;
     6011 S PSONEW("FLD")=5 D CLINIC^PSODIR2(.PSONEW) ; Get Clinic
     61 Q
     62 ;
     638 S PSONEW("FLD")=7 D QTY^PSODIR1(.PSONEW) ; Get quantity
     64 Q
     65 ;
     667 I '$G(PSODRUG("IEN")) W $C(7),!!,"No Dispense Drug!",! K DIR,DUOUT,DIRUT,DTOUT D 2^PSOORNW1
     67 I '$G(PSODRUG("IEN")) W !,$C(7),"No Dispense Drug Selected! A new Orderable Item may need to be selected.",! Q
     68 S PSONEW("FLD")=8 D DAYS^PSODIR1(.PSONEW) ; Get days supply
     69 Q:'$G(PSONEW("PATIENT STATUS"))
     70 K PSDY,PSDY1,PSMAX,PSTMAX S PSDAYS=PSONEW("DAYS SUPPLY"),PSRF=PSONEW("# OF REFILLS"),PTST=$P(^PS(53,PSONEW("PATIENT STATUS"),0),"^"),PTDY=$P(^(0),"^",3),PTRF=$P(^(0),"^",4),PSODEA=PSODRUG("DEA"),CS=0 ;D EDNEW^PSOORNW1
     71 Q
     729 ;
     73 I '$G(PSONEW("PATIENT STATUS")) W !!,"Rx Patient Status required!",! D 3 I '$G(PSONEW("PATIENT STATUS")) S VALMSG="Rx Patient Status required!",VALMBCK="R" Q
     74 I +$G(^PS(55,PSODFN,"PS")) S RXPT=+^("PS") I $G(^PS(53,RXPT,0))]"" D  G ASK
     75 .S PSOMAX=$S($G(CLOZPAT)=2:3,$G(CLOZPAT)=1:1,$G(CLOZPAT)=0:0,1:+$P(^PS(53,RXPT,0),"^",4)) K RXPT
     76 .S:'$G(PSONEW("# OF REFILLS")) PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11))
     77 .S (PSONEW("N# REF"),PSONEW("# OF REFILLS"))=$S(PSONEW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSONEW("# OF REFILLS"))
     78 .I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F") D  Q
     79 ..S (PSOMAX,PSONEW("N# REF"),PSONEW("# OF REFILLS"))=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics ...")
     80 .I $D(PSODRUG("DEA")) F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S PSOMAX=5
     81 I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F") D  Q
     82 .S (PSONEW("N# REF"),PSONEW("# OF REFILLS"))=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics ...")
     83 S (PSONEW("N# REF"),PSOMAX,PSONEW("# OF REFILLS"))=+$P(OR0,"^",11)
     84ASK S PSONEW("FLD")=9 D REFILL^PSODIR1(.PSONEW) ; Get # of refills
     85 K PSOMAX,PSMAX,PSTMAX S PSDAYS=PSONEW("DAYS SUPPLY"),PSRF=PSONEW("# OF REFILLS"),PTST=$P(^PS(53,PSONEW("PATIENT STATUS"),0),"^"),PTDY=$P(^(0),"^",3),PTRF=$P(^(0),"^",4),PSODEA=$G(PSODRUG("DEA")),CS=0 D EDNEW^PSOORNW1
     86 Q
     87 ;
     886 Q  K DA S PSONEW("FLD")=10 D SIG^PSODIR1(.PSONEW) ; Get sig
     89 I $G(PSONEW("SIG"))]"" D EN^PSOSIGNO(ORD,PSONEW("SIG")) S SIG(1)=PSONEW("SIG")
     90 I $G(PSOSIGFL) D
     91 .K DIRUT,DUOUT,DTOUT,DIR S DIR(0)="Y",DIR("B")="NO",DIR("A",1)="",DIR("A")="This edit will create a new order.  Do you want to continue" D ^DIR
     92 .I 'Y!($D(DIRUT)) K DIR,DIRUT,DUOUT,DTOUT,DIC,Y,PSOSIGFL,PSONEW("SIG") S SIGOK=1
     93 S PSONEW("CLERK CODE")=DUZ K DIR,DIRUT,DUOUT,DTOUT,DIC,Y
     94 Q
     95 ;
     9613 S PSONEW("FLD")=11 D COPIES^PSODIR1(.PSONEW) ; Get # of copies
     97 Q
     98 ;
     9910 S PSONEW("FLD")=12 D MW^PSODIR2(.PSONEW) ; Get Mail/Window Info
     100 Q
     101 ;
     10214 S PSONEW("FLD")=13 D RMK^PSODIR2(.PSONEW) ; Get Remarks
     103 Q
     104 ;
     105DRGMSG ;From PSOORNEW
     106 F SG=1:1:$L($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " D
     107 .S:$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG)
     108 K SG Q
     109 ;
     110DREN ;
     111 S (PSDC,PSI)=0
     112 F  S PSI=$O(^PSDRUG("ASP",PSODRUG("OI"),PSI)) Q:'PSI  I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($P($G(^PSDRUG(PSI,2)),"^",3)'["O":0,1:1) S PSDC=PSDC+1,PSDC(PSDC)=PSI
     113 I PSDC'=1 D  G DRENX
     114 .I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),2)),"^")=$G(PSODRUG("OI")) Q
     115 .K PSODRUG("NAME"),PSODRUG("IEN")
     116 K PSOY S PSI=PSDC(1),PSOY=^PSDRUG(PSI,0)
     117 I $P($G(^PSDRUG(PSI,"CLOZ1")),"^")="PSOCLO1",'$O(^YSCL(603.01,"C",PSODFN,0)) K PSOY,PSI Q
     118 S PSODRUG("IEN")=+PSI,PSODRUG("VA CLASS")=$P(PSOY,"^",2),PSODRUG("NAME")=$P(PSOY,"^")
     119 S PSODRUG("NDF")=$S($G(^PSDRUG(PSI,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)
     120 S PSODRUG("MAXDOSE")=$P(PSOY,"^",4),PSODRUG("DEA")=$P(PSOY,"^",3),PSODRUG("CLN")=$S($D(^PSDRUG(+PSI,"ND")):+$P(^("ND"),"^",6),1:0)
     121 S PSODRUG("SIG")=$P(PSOY,"^",5),PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSI,$G(PSOSITE)),PSODRUG("STKLVL")=$G(^PSDRUG(+PSI,660.1))
     122 S PSODRUG("DAW")=+$$GET1^DIQ(50,+PSI,81)
     123 G:$G(^PSDRUG(+PSI,660))']"" DRENX
     124 S PSOX1=$G(^PSDRUG(+PSI,660)),PSODRUG("COST")=$P($G(PSOX1),"^",6),PSODRUG("UNIT")=$P($G(PSOX1),"^",8),PSODRUG("EXPIRATION DATE")=$P($G(PSOX1),"^",9)
     125DRENX K PSDC,PSI,PSOY,Y,PSOXI,X Q
     126KV K DIR,DIRUT,DUOUT,DTOUT Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORRL.m

    r613 r623  
    1 PSOORRL ;BHAM ISC/SAB - returns patient's outpatient meds ;07/21/96
    2         ;;7.0;OUTPATIENT PHARMACY;**4,20,9,34,54,82,124,132,159,214,225**;DEC 1997;Build 29
    3         ;External reference to ^PS(55 supported by DBIA 2228
    4         ;External reference to ^PSDRUG supported by DBIA 221
    5         ;External reference to ^VA(200 supported by DBIA 10060
    6         ;External reference to ^PS(51.2 supported by DBIA 2226
    7         ;External reference to ^PS(50.7 supported by DBIA 2223
    8         ;External reference to ^PS(50.606 supported by DBIA 2174
    9         ;External reference to OCL^PSJORRE supported by DBIA 2383
    10         ;External reference to OEL^PSJORRE1 supported by DBIA 2384
    11 OCL(DFN,BDT,EDT,VIEW)   ;entry point to return condensed list
    12         ; VIEW=0   -  This returns the list as it was returned prior to GUI 27
    13         ; VIEW=1   -  This returns the list in original view GUI 27
    14         ; VIEW=2   -  This is the new sort with GUI 27
    15         ; VIEW=3   -  New sort by Sort by Drug Name/status with GUI 27
    16         D @$S($G(VIEW)=3:"OCL^PSOORRL3",$G(VIEW)=1:"OCL^PSOORRLO",$G(VIEW)=2:"OCL^PSOORRLN",1:"ST")
    17         Q
    18         ;BHW;PSO*7*159;New SD* Variables
    19 ST      N SD,SDT,SDT1
    20         D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN)
    21         K ^TMP("PS",$J) S TFN=0,PSBDT=$G(BDT),PSEDT=$G(EDT) I +$G(PSBDT)<1 S X1=DT,X2=-120 D C^%DTC S PSBDT=X
    22         S EXDT=PSBDT-1,IFN=0
    23         F  S EXDT=$O(^PS(55,DFN,"P","A",EXDT)) Q:'EXDT  F  S IFN=$O(^PS(55,DFN,"P","A",EXDT,IFN)) Q:'IFN  D:$D(^PSRX(IFN,0))
    24         .Q:$P($G(^PSRX(IFN,"STA")),"^")=13
    25         .S TFN=TFN+1,RX0=^PSRX(IFN,0),RX2=$G(^(2)),RX3=$G(^(3)),STA=+$G(^("STA")),TRM=0,LSTFD=$P(RX2,"^",2),LSTRD=$P(RX2,"^",13),LSTDS=$P(RX0,"^",8)
    26         .F I=0:0 S I=$O(^PSRX(IFN,1,I)) Q:'I  S TRM=TRM+1,LSTFD=$P(^PSRX(IFN,1,I,0),"^"),LSTDS=$P(^(0),"^",10) S:$P(^(0),"^",18)]"" LSTRD=$P(^(0),"^",18)
    27         .S ^TMP("PS",$J,TFN,0)=IFN_"R;O"_"^"_$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^")_"^^"_$P(RX2,"^",6)_"^"_($P(RX0,"^",9)-TRM)_"^^^"_$P($G(^PSRX(IFN,"OR1")),"^",2)
    28         .S ^TMP("PS",$J,TFN,"P",0)=$P(RX0,"^",4)_"^"_$P($G(^VA(200,+$P(RX0,"^",4),0)),"^")
    29         .S ST0=$S(STA<12&($P(RX2,"^",6)<DT):11,1:STA)
    30         .S ST=$P("ERROR^ACTIVE^NON-VERIFIED^REFILL FILL^HOLD^NON-VERIFIED^ACTIVE/SUSP^^^^^DONE^EXPIRED^DISCONTINUED^DISCONTINUED^DISCONTINUED^DISCONTINUED (EDIT)^HOLD^","^",ST0+2)
    31         .S ^TMP("PS",$J,TFN,0)=^TMP("PS",$J,TFN,0)_"^"_ST_"^"_LSTFD_"^"_$P(RX0,"^",8)_"^"_$P(RX0,"^",7)_"^^^"_$P(RX0,"^",13)_"^"_LSTRD_"^"_LSTDS
    32         .S ^TMP("PS",$J,TFN,"SCH",0)=0
    33         .S (SCH,SC)=0 F  S SC=$O(^PSRX(IFN,"SCH",SC)) Q:'SC  S SCH=SCH+1,^TMP("PS",$J,TFN,"SCH",SCH,0)=$P(^PSRX(IFN,"SCH",SC,0),"^"),^TMP("PS",$J,TFN,"SCH",0)=^TMP("PS",$J,TFN,"SCH",0)+1
    34         .S ^TMP("PS",$J,TFN,"MDR",0)=0,(MDR,MR)=0 F  S MR=$O(^PSRX(IFN,"MEDR",MR)) Q:'MR  D
    35         ..Q:'$D(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0))  S MDR=MDR+1
    36         ..I $P($G(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0)),"^",3)]"" S ^TMP("PS",$J,TFN,"MDR",MDR,0)=$P(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0),"^",3)
    37         ..I $D(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0)),$P($G(^(0)),"^",3)']"" S ^TMP("PS",$J,TFN,"MDR",MDR,0)=$P(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0),"^")
    38         ..S ^TMP("PS",$J,TFN,"MDR",0)=^TMP("PS",$J,TFN,"MDR",0)+1
    39         .S PSOELSE=0 I $D(^PSRX(IFN,"SIG")),'$P(^PSRX(IFN,"SIG"),"^",2) S PSOELSE=1 S X=$P(^PSRX(IFN,"SIG"),"^") D SIG1^PSOORRL1
    40         .I '$G(PSOELSE) S ITFN=1 D
    41         ..S ^TMP("PS",$J,TFN,"SIG",ITFN,0)=$G(^PSRX(IFN,"SIG1",1,0)),^TMP("PS",$J,TFN,"SIG",0)=+$G(^TMP("PS",$J,TFN,"SIG",0))+1
    42         ..F I=1:0 S I=$O(^PSRX(IFN,"SIG1",I)) Q:'I  S ITFN=ITFN+1,^TMP("PS",$J,TFN,"SIG",ITFN,0)=^PSRX(IFN,"SIG1",I,0),^TMP("PS",$J,TFN,"SIG",0)=+$G(^TMP("PS",$J,TFN,"SIG",0))+1
    43         K PSOELSE
    44         S IFN=0 F  S IFN=$O(^PS(52.41,"P",DFN,IFN)) Q:'IFN  S PSOR=^PS(52.41,IFN,0) D:$P(PSOR,"^",3)="" WAIT D:$P(PSOR,"^",3)'="DC"&($P(PSOR,"^",3)'="DE")&($P(PSOR,"^",3)'="")
    45         .Q:$P(PSOR,"^",3)="RF"
    46         .I $P(PSOR,"^",8)="",$P(PSOR,"^",9)="" D WAIT
    47         .I $P(PSOR,"^",8)="",$P(PSOR,"^",9)="" Q  ; QUIT IF STILL NULL AFTER WAITING
    48         .S TFN=TFN+1,^TMP("PS",$J,TFN,0)=IFN_"P;O^"_$S($P(PSOR,"^",9):$P($G(^PSDRUG($P(PSOR,"^",9),0)),"^"),1:$P(^PS(50.7,$P(PSOR,"^",8),0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,$P(PSOR,"^",8),0),"^",2),0),"^"))
    49         .S ^TMP("PS",$J,TFN,0)=^TMP("PS",$J,TFN,0)_"^^^^^^"_$P(PSOR,"^")_"^"_"PENDING^^^"_$P(PSOR,"^",10)_"^"
    50         .S ^TMP("PS",$J,TFN,0)=^TMP("PS",$J,TFN,0)_"^"_$S($P(PSOR,"^",3)="RNW":1,1:0)
    51         .S SD=0 F SCH=0:0 S SCH=$O(^PS(52.41,IFN,1,SCH)) Q:'SCH  S SD=SD+1,^TMP("PS",$J,TFN,"SCH",SD,0)=$P(^PS(52.41,IFN,1,SCH,1),"^"),^TMP("PS",$J,TFN,"SCH",0)=SD
    52         .S SD=0 F SCH=0:0 S SCH=$O(^PS(52.41,IFN,"SIG",SCH)) Q:'SCH  S SD=SD+1,^TMP("PS",$J,TFN,"SIG",SD,0)=$P(^PS(52.41,IFN,"SIG",SCH,0),"^"),^TMP("PS",$J,TFN,"SIG",0)=SD
    53         .S (IEN,SD)=1,INST=0 F  S INST=$O(^PS(52.41,IFN,2,INST)) Q:'INST  S (MIG,INST(INST))=^PS(52.41,IFN,2,INST,0),^TMP("PS",$J,TFN,"SIO",0)=SD D
    54         ..F SG=1:1:$L(MIG," ") S:$L($G(^TMP("PS",$J,TFN,"SIO",IEN,0))_" "_$P(MIG," ",SG))>80 IEN=IEN+1,SD=SD+1,^TMP("PS",$J,TFN,"SIO",0)=SD S ^TMP("PS",$J,TFN,"SIO",IEN,0)=$G(^TMP("PS",$J,TFN,"SIO",IEN,0))_" "_$P(MIG," ",SG)
    55         D NVA,OCL^PSJORRE(DFN,BDT,EDT,.TFN,+$G(VIEW)),END^PSOORRL1
    56         K SDT,SDT1,EDT,EDT1,BDT,DBT1,X
    57         Q
    58 OEL(DFN,RXNUM)  ;returns expanded list on specific order
    59         I $P(RXNUM,";",2)="I" D OEL^PSJORRE1(DFN,$P(RXNUM,";")) Q
    60         D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN) Q:RXNUM=""
    61         ;BHW;PSO*7*159;New SD
    62         N SD
    63         K INST,IFN,^TMP("PS",$J) S FL=$P(RXNUM,";"),IFN=+FL,RXNUM=$P(RXNUM,";",2)
    64         I $G(FL)["P"!($G(FL)["S") D PEN^PSOORRL1 Q
    65         I $G(FL)["N" D NVA^PSOORRL1 Q
    66         Q:'$D(^PSRX(IFN,0))
    67         S RX0=^PSRX(IFN,0),RX2=$G(^(2)),RX3=$G(^(3)),STA=+$G(^("STA")),TRM=0,LSTFD=$P(RX2,"^",2)
    68         S ^TMP("PS",$J,"RXN",0)=$P(RX0,"^")_"^"_$E($P(RX2,"^",13),1,7)_"^"_$S($P(RX0,"^",11)="W":"W",1:"M")_"^"_$P(RX3,"^",7)_"^"_$S($P($G(^PSRX(IFN,"OR1")),"^",5):$P(^PSRX(IFN,"OR1"),"^",5),1:"")_"^"_$E($P(RX2,"^",2),1,7)_"^"_$E($P(RX2,"^",13),1,7)
    69         D RSTC(0) ;set return to stock node for original
    70         F I=0:0 S I=$O(^PSRX(IFN,1,I)) Q:'I  S TRM=TRM+1,LSTFD=$P(^PSRX(IFN,1,I,0),"^") D
    71         .S ^TMP("PS",$J,"REF",I,0)=$P(^PSRX(IFN,1,I,0),"^")_"^"_$P(^(0),"^",10)_"^"_$P(^(0),"^",4)_"^"_$E($P(^(0),"^",18),1,7)_"^"_$S($P(^(0),"^",2)="W":"W",1:"M")_"^"_$P(^(0),"^",3)
    72         .I $P(^PSRX(IFN,1,I,0),"^",18) S $P(^TMP("PS",$J,"RXN",0),"^",2)=$E($P(^PSRX(IFN,1,I,0),"^",18),1,7)
    73         .S ^TMP("PS",$J,"REF",0)=$G(^TMP("PS",$J,"REF",0))+1
    74         .D RSTC(I) ;set return to stock node for refills
    75         F I=0:0 S I=$O(^PSRX(IFN,"P",I)) Q:'I  D
    76         .S ^TMP("PS",$J,"PAR",I,0)=$P(^PSRX(IFN,"P",I,0),"^")_"^"_$P(^(0),"^",10)_"^"_$P(^(0),"^",4)_"^"_$E($P(^(0),"^",19),1,7)_"^"_$S($P(^(0),"^",2)="W":"W",1:"M")_"^"_$P(^(0),"^",3)
    77         .S ^TMP("PS",$J,"PAR",0)=$G(^TMP("PS",$J,"PAR",0))+1
    78         S ^TMP("PS",$J,0)=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^")_"^^"_$P(RX2,"^",6)
    79         S ^TMP("PS",$J,"P",0)=$P(RX0,"^",4)_"^"_$P($G(^VA(200,+$P(RX0,"^",4),0)),"^")
    80         S ST0=$S(STA<12&($P(RX2,"^",6)<DT):11,1:STA)
    81         S ST=$P("ERROR^ACTIVE^NON-VERIFIED^REFILL FILL^HOLD^NON-VERIFIED^ACTIVE/SUSP^^^^^DONE^EXPIRED^DISCONTINUE^DISCONTINUED^DISCONTINUED^DISCONTINUED (EDIT)^HOLD^","^",ST0+2)
    82         S ^TMP("PS",$J,0)=^TMP("PS",$J,0)_"^"_($P(RX0,"^",9)-TRM)_"^"_$P(RX0,"^",13)_"^"_ST_"^"_$P(RX0,"^",8)_"^"_$P(RX0,"^",7)_"^^^"_$P($G(^PSRX(IFN,"OR1")),"^",2)_"^"_LSTFD_"^^"
    83         S ^TMP("PS",$J,"DD",0)=1,^TMP("PS",$J,"DD",1,0)=$P(RX0,"^",6)_"^^"
    84         S COD=$S('$G(^PSDRUG(+$P(RX0,"^",6),"I")):1,+$G(^PSDRUG(+$P(RX0,"^",6),"I"))>DT:1,1:0)
    85         S ^TMP("PS",$J,"DD",1,0)=^TMP("PS",$J,"DD",1,0)_$S($P($G(^PSDRUG(+$P(RX0,"^",6),2)),"^",3)["U"&(COD):$P(RX0,"^",6),1:"") K COD
    86         S ^TMP("PS",$J,"SCH",0)=0,(SCH,SC)=0
    87         F  S SC=$O(^PSRX(IFN,"SCH",SC)) Q:'SC  S SCH=SCH+1,^TMP("PS",$J,"SCH",SCH,0)=$P(^PSRX(IFN,"SCH",SC,0),"^") D
    88         .S ^TMP("PS",$J,"SCH",0)=^TMP("PS",$J,"SCH",0)+1
    89         D MDR^PSOORRL1
    90         S PSOELSE=0 I $D(^PSRX(IFN,"SIG")),'$P(^PSRX(IFN,"SIG"),"^",2) S PSOELSE=1 S X=$P(^PSRX(IFN,"SIG"),"^") D SIG^PSOORRL1
    91         I '$G(PSOELSE) S ITFN=1 D
    92         .S ^TMP("PS",$J,"SIG",ITFN,0)=$G(^PSRX(IFN,"SIG1",1,0)),^TMP("PS",$J,"SIG",0)=+$G(^TMP("PS",$J,"SIG",0))+1
    93         .F I=1:0 S I=$O(^PSRX(IFN,"SIG1",I)) Q:'I  S ITFN=ITFN+1,^TMP("PS",$J,"SIG",ITFN,0)=^PSRX(IFN,"SIG1",I,0),^TMP("PS",$J,"SIG",0)=+$G(^TMP("PS",$J,"SIG",0))+1
    94         K PSOELSE
    95         S ^TMP("PS",$J,"PC",0)=0,ITFN=0
    96         F I=0:0 S I=$O(^PSRX(IFN,"PRC",I)) Q:'I  S ITFN=ITFN+1,^TMP("PS",$J,"PC",ITFN,0)=^PSRX(IFN,"PRC",I,0),^TMP("PS",$J,"PC",0)=^TMP("PS",$J,"PC",0)+1
    97         Q
    98         ;
    99 WAIT    ; IF PENDING ENTRY STILL BEING BUILT SEE IF IT COMPLETES WITHIN ANOTHER SECOND
    100         H 1 S PSOR=$G(^PS(52.41,IFN,0))
    101         Q
    102         ;
    103 NVA     ; Set Non-VA Med Orders in the ^TMP Global
    104         ;BHW;PSO*7*159;New SDT,SDT1 Variables
    105         N SDT,SDT1
    106         F I=0:0 S I=$O(^PS(55,DFN,"NVA",I)) Q:'I  S X=$G(^PS(55,DFN,"NVA",I,0)) D
    107         .Q:'$P(X,"^")
    108         .S DRG=$S($P(X,"^",2):$P($G(^PSDRUG($P(X,"^",2),0)),"^"),1:$P(^PS(50.7,$P(X,"^"),0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,$P(X,"^"),0),"^",2),0),"^"))
    109         .S SDT=$P(X,"^",9) I 'SDT D TMPBLD Q
    110         .I $E(SDT,4,5),$E(SDT,6,7) D
    111         ..;I $P(X,"^",9) D  Q
    112         ..I $G(BDT),SDT<BDT Q
    113         ..I $G(EDT),SDT>EDT Q
    114         ..I $G(BDT),$P(X,"^",7),$P(X,"^",7)<BDT Q
    115         ..D TMPBLD
    116         .I $E(SDT,4,5),'$E(SDT,6,7) D
    117         ..S SDT1=$E(SDT,1,5),BDT1=$E(+$G(BDT),1,5),EDT1=$E(+$G(EDT),1,5)
    118         ..I $G(BDT1),SDT1<BDT1 Q
    119         ..I $G(EDT1),SDT1>EDT1 Q
    120         ..I $G(BDT1),$P(X,"^",7),$E($P(X,"^",7),1,5)<BDT1 Q
    121         ..D TMPBLD
    122         .I '$E(SDT,4,5),'$E($P(X,"^",9),6,7) D
    123         ..;I $P(X,"^",9) D  Q
    124         ..S SDT1=$E(SDT,1,3),BDT1=$E(+$G(BDT),1,3),EDT1=$E(+$G(EDT),1,3)
    125         ..I $G(BDT1),SDT1<BDT1 Q
    126         ..I $G(EDT1),SDT1>EDT1 Q
    127         ..I $G(BDT1),$P(X,"^",7),$E($P(X,"^",7),1,3)<BDT1 Q
    128         ..D TMPBLD
    129         Q
    130 TMPBLD  S TFN=$G(TFN)+1,^TMP("PS",$J,TFN,0)=I_"N;O^"_DRG
    131         S $P(^TMP("PS",$J,TFN,0),"^",8)=$P(X,"^",8)_"^"_$S($P(X,"^",7):"DISCONTINUED",1:"ACTIVE")
    132         S ^TMP("PS",$J,TFN,"SCH",0)=1,^TMP("PS",$J,TFN,"SCH",1,0)=$P(X,"^",5)
    133         S ^TMP("PS",$J,TFN,"SIG",0)=1,^TMP("PS",$J,TFN,"SIG",1,0)=$P(X,"^",3)_" "_$P(X,"^",4)_" "_$P(X,"^",5)
    134         Q
    135 RSTC(REF)       ; return to stock
    136         F J=0:0 S J=$O(^PSRX(IFN,"A",J)) Q:'J  S II=$G(^(J,0)) I $P(II,"^",2)="I",$P(II,"^",4)=REF D
    137         .I REF=0,'$$RXRLDT^PSOBPSUT(IFN,0) S ^TMP("PS",$J,"RXN","RSTC")=$P(II,"^")_"^"_$P(II,"^",3)_"^"_$P(II,"^",5) Q
    138         .I REF>0,'$$RXRLDT^PSOBPSUT(IFN,REF) S ^TMP("PS",$J,"REF",REF,"RSTC")=$P(II,"^")_"^"_$P(II,"^",3)_"^"_$P(II,"^",5)
    139         Q
     1PSOORRL ;BHAM ISC/SAB - returns patient's outpatient meds ;07/21/96
     2 ;;7.0;OUTPATIENT PHARMACY;**4,20,9,34,54,82,124,132,159,214**;DEC 1997
     3 ;External reference to ^PS(55 supported by DBIA 2228
     4 ;External reference to ^PSDRUG supported by DBIA 221
     5 ;External reference to ^VA(200 supported by DBIA 10060
     6 ;External reference to ^PS(51.2 supported by DBIA 2226
     7 ;External reference to ^PS(50.7 supported by DBIA 2223
     8 ;External reference to ^PS(50.606 supported by DBIA 2174
     9 ;External reference to OCL^PSJORRE supported by DBIA 2383
     10 ;External reference to OEL^PSJORRE1 supported by DBIA 2384
     11OCL(DFN,BDT,EDT) ;entry point to return condensed list
     12 ;BHW;PSO*7*159;New SD* Variables
     13 N SD,SDT,SDT1
     14 D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN)
     15 K ^TMP("PS",$J) S TFN=0,PSBDT=$G(BDT),PSEDT=$G(EDT) I +$G(PSBDT)<1 S X1=DT,X2=-120 D C^%DTC S PSBDT=X
     16 S EXDT=PSBDT-1,IFN=0
     17 F  S EXDT=$O(^PS(55,DFN,"P","A",EXDT)) Q:'EXDT  F  S IFN=$O(^PS(55,DFN,"P","A",EXDT,IFN)) Q:'IFN  D:$D(^PSRX(IFN,0))
     18 .Q:$P($G(^PSRX(IFN,"STA")),"^")=13
     19 .S TFN=TFN+1,RX0=^PSRX(IFN,0),RX2=$G(^(2)),RX3=$G(^(3)),STA=+$G(^("STA")),TRM=0,LSTFD=$P(RX2,"^",2),LSTRD=$P(RX2,"^",13),LSTDS=$P(RX0,"^",8)
     20 .F I=0:0 S I=$O(^PSRX(IFN,1,I)) Q:'I  S TRM=TRM+1,LSTFD=$P(^PSRX(IFN,1,I,0),"^"),LSTDS=$P(^(0),"^",10) S:$P(^(0),"^",18)]"" LSTRD=$P(^(0),"^",18)
     21 .S ^TMP("PS",$J,TFN,0)=IFN_"R;O"_"^"_$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^")_"^^"_$P(RX2,"^",6)_"^"_($P(RX0,"^",9)-TRM)_"^^^"_$P($G(^PSRX(IFN,"OR1")),"^",2)
     22 .S ^TMP("PS",$J,TFN,"P",0)=$P(RX0,"^",4)_"^"_$P($G(^VA(200,+$P(RX0,"^",4),0)),"^")
     23 .S ST0=$S(STA<12&($P(RX2,"^",6)<DT):11,1:STA)
     24 .S ST=$P("ERROR^ACTIVE^NON-VERIFIED^REFILL FILL^HOLD^NON-VERIFIED^ACTIVE/SUSP^^^^^DONE^EXPIRED^DISCONTINUED^DISCONTINUED^DISCONTINUED^DISCONTINUED (EDIT)^HOLD^","^",ST0+2)
     25 .S ^TMP("PS",$J,TFN,0)=^TMP("PS",$J,TFN,0)_"^"_ST_"^"_LSTFD_"^"_$P(RX0,"^",8)_"^"_$P(RX0,"^",7)_"^^^"_$P(RX0,"^",13)_"^"_LSTRD_"^"_LSTDS
     26 .S ^TMP("PS",$J,TFN,"SCH",0)=0
     27 .S (SCH,SC)=0 F  S SC=$O(^PSRX(IFN,"SCH",SC)) Q:'SC  S SCH=SCH+1,^TMP("PS",$J,TFN,"SCH",SCH,0)=$P(^PSRX(IFN,"SCH",SC,0),"^"),^TMP("PS",$J,TFN,"SCH",0)=^TMP("PS",$J,TFN,"SCH",0)+1
     28 .S ^TMP("PS",$J,TFN,"MDR",0)=0,(MDR,MR)=0 F  S MR=$O(^PSRX(IFN,"MEDR",MR)) Q:'MR  D
     29 ..Q:'$D(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0))  S MDR=MDR+1
     30 ..I $P($G(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0)),"^",3)]"" S ^TMP("PS",$J,TFN,"MDR",MDR,0)=$P(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0),"^",3)
     31 ..I $D(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0)),$P($G(^(0)),"^",3)']"" S ^TMP("PS",$J,TFN,"MDR",MDR,0)=$P(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0),"^")
     32 ..S ^TMP("PS",$J,TFN,"MDR",0)=^TMP("PS",$J,TFN,"MDR",0)+1
     33 .S PSOELSE=0 I $D(^PSRX(IFN,"SIG")),'$P(^PSRX(IFN,"SIG"),"^",2) S PSOELSE=1 S X=$P(^PSRX(IFN,"SIG"),"^") D SIG1^PSOORRL1
     34 .I '$G(PSOELSE) S ITFN=1 D
     35 ..S ^TMP("PS",$J,TFN,"SIG",ITFN,0)=$G(^PSRX(IFN,"SIG1",1,0)),^TMP("PS",$J,TFN,"SIG",0)=+$G(^TMP("PS",$J,TFN,"SIG",0))+1
     36 ..F I=1:0 S I=$O(^PSRX(IFN,"SIG1",I)) Q:'I  S ITFN=ITFN+1,^TMP("PS",$J,TFN,"SIG",ITFN,0)=^PSRX(IFN,"SIG1",I,0),^TMP("PS",$J,TFN,"SIG",0)=+$G(^TMP("PS",$J,TFN,"SIG",0))+1
     37 K PSOELSE
     38 S IFN=0 F  S IFN=$O(^PS(52.41,"P",DFN,IFN)) Q:'IFN  S PSOR=^PS(52.41,IFN,0) D:$P(PSOR,"^",3)="" WAIT D:$P(PSOR,"^",3)'="DC"&($P(PSOR,"^",3)'="DE")&($P(PSOR,"^",3)'="")
     39 .Q:$P(PSOR,"^",3)="RF"
     40 .I $P(PSOR,"^",8)="",$P(PSOR,"^",9)="" D WAIT
     41 .I $P(PSOR,"^",8)="",$P(PSOR,"^",9)="" Q  ; QUIT IF STILL NULL AFTER WAITING
     42 .S TFN=TFN+1,^TMP("PS",$J,TFN,0)=IFN_"P;O^"_$S($P(PSOR,"^",9):$P($G(^PSDRUG($P(PSOR,"^",9),0)),"^"),1:$P(^PS(50.7,$P(PSOR,"^",8),0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,$P(PSOR,"^",8),0),"^",2),0),"^"))
     43 .S ^TMP("PS",$J,TFN,0)=^TMP("PS",$J,TFN,0)_"^^^^^^"_$P(PSOR,"^")_"^"_"PENDING^^^"_$P(PSOR,"^",10)_"^"
     44 .S ^TMP("PS",$J,TFN,0)=^TMP("PS",$J,TFN,0)_"^"_$S($P(PSOR,"^",3)="RNW":1,1:0)
     45 .S SD=0 F SCH=0:0 S SCH=$O(^PS(52.41,IFN,1,SCH)) Q:'SCH  S SD=SD+1,^TMP("PS",$J,TFN,"SCH",SD,0)=$P(^PS(52.41,IFN,1,SCH,1),"^"),^TMP("PS",$J,TFN,"SCH",0)=SD
     46 .S SD=0 F SCH=0:0 S SCH=$O(^PS(52.41,IFN,"SIG",SCH)) Q:'SCH  S SD=SD+1,^TMP("PS",$J,TFN,"SIG",SD,0)=$P(^PS(52.41,IFN,"SIG",SCH,0),"^"),^TMP("PS",$J,TFN,"SIG",0)=SD
     47 .S (IEN,SD)=1,INST=0 F  S INST=$O(^PS(52.41,IFN,2,INST)) Q:'INST  S (MIG,INST(INST))=^PS(52.41,IFN,2,INST,0),^TMP("PS",$J,TFN,"SIO",0)=SD D
     48 ..F SG=1:1:$L(MIG," ") S:$L($G(^TMP("PS",$J,TFN,"SIO",IEN,0))_" "_$P(MIG," ",SG))>80 IEN=IEN+1,SD=SD+1,^TMP("PS",$J,TFN,"SIO",0)=SD S ^TMP("PS",$J,TFN,"SIO",IEN,0)=$G(^TMP("PS",$J,TFN,"SIO",IEN,0))_" "_$P(MIG," ",SG)
     49 D NVA,OCL^PSJORRE(DFN,BDT,EDT,.TFN),END^PSOORRL1
     50 K SDT,SDT1,EDT,EDT1,BDT,DBT1,X
     51 Q
     52OEL(DFN,RXNUM) ;returns expanded list on specific order
     53 I $P(RXNUM,";",2)="I" D OEL^PSJORRE1(DFN,$P(RXNUM,";")) Q
     54 D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN) Q:RXNUM=""
     55 ;BHW;PSO*7*159;New SD
     56 N SD
     57 K INST,IFN,^TMP("PS",$J) S FL=$P(RXNUM,";"),IFN=+FL,RXNUM=$P(RXNUM,";",2)
     58 I $G(FL)["P"!($G(FL)["S") D PEN^PSOORRL1 Q
     59 I $G(FL)["N" D NVA^PSOORRL1 Q
     60 Q:'$D(^PSRX(IFN,0))
     61 S RX0=^PSRX(IFN,0),RX2=$G(^(2)),RX3=$G(^(3)),STA=+$G(^("STA")),TRM=0,LSTFD=$P(RX2,"^",2)
     62 S ^TMP("PS",$J,"RXN",0)=$P(RX0,"^")_"^"_$E($P(RX2,"^",13),1,7)_"^"_$S($P(RX0,"^",11)="W":"W",1:"M")_"^"_$P(RX3,"^",7)_"^"_$S($P($G(^PSRX(IFN,"OR1")),"^",5):$P(^PSRX(IFN,"OR1"),"^",5),1:"")_"^"_$E($P(RX2,"^",2),1,7)_"^"_$E($P(RX2,"^",13),1,7)
     63 F I=0:0 S I=$O(^PSRX(IFN,1,I)) Q:'I  S TRM=TRM+1,LSTFD=$P(^PSRX(IFN,1,I,0),"^") D
     64 .S ^TMP("PS",$J,"REF",I,0)=$P(^PSRX(IFN,1,I,0),"^")_"^"_$P(^(0),"^",10)_"^"_$P(^(0),"^",4)_"^"_$E($P(^(0),"^",18),1,7)_"^"_$S($P(^(0),"^",2)="W":"W",1:"M")_"^"_$P(^(0),"^",3)
     65 .I $P(^PSRX(IFN,1,I,0),"^",18) S $P(^TMP("PS",$J,"RXN",0),"^",2)=$E($P(^PSRX(IFN,1,I,0),"^",18),1,7)
     66 .S ^TMP("PS",$J,"REF",0)=$G(^TMP("PS",$J,"REF",0))+1
     67 F I=0:0 S I=$O(^PSRX(IFN,"P",I)) Q:'I  D
     68 .S ^TMP("PS",$J,"PAR",I,0)=$P(^PSRX(IFN,"P",I,0),"^")_"^"_$P(^(0),"^",10)_"^"_$P(^(0),"^",4)_"^"_$E($P(^(0),"^",19),1,7)_"^"_$S($P(^(0),"^",2)="W":"W",1:"M")_"^"_$P(^(0),"^",3)
     69 .S ^TMP("PS",$J,"PAR",0)=$G(^TMP("PS",$J,"PAR",0))+1
     70 S ^TMP("PS",$J,0)=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^")_"^^"_$P(RX2,"^",6)
     71 S ^TMP("PS",$J,"P",0)=$P(RX0,"^",4)_"^"_$P($G(^VA(200,+$P(RX0,"^",4),0)),"^")
     72 S ST0=$S(STA<12&($P(RX2,"^",6)<DT):11,1:STA)
     73 S ST=$P("ERROR^ACTIVE^NON-VERIFIED^REFILL FILL^HOLD^NON-VERIFIED^ACTIVE/SUSP^^^^^DONE^EXPIRED^DISCONTINUE^DISCONTINUED^DISCONTINUED^DISCONTINUED (EDIT)^HOLD^","^",ST0+2)
     74 S ^TMP("PS",$J,0)=^TMP("PS",$J,0)_"^"_($P(RX0,"^",9)-TRM)_"^"_$P(RX0,"^",13)_"^"_ST_"^"_$P(RX0,"^",8)_"^"_$P(RX0,"^",7)_"^^^"_$P($G(^PSRX(IFN,"OR1")),"^",2)_"^"_LSTFD_"^^"
     75 S ^TMP("PS",$J,"DD",0)=1,^TMP("PS",$J,"DD",1,0)=$P(RX0,"^",6)_"^^"
     76 S COD=$S('$G(^PSDRUG(+$P(RX0,"^",6),"I")):1,+$G(^PSDRUG(+$P(RX0,"^",6),"I"))>DT:1,1:0)
     77 S ^TMP("PS",$J,"DD",1,0)=^TMP("PS",$J,"DD",1,0)_$S($P($G(^PSDRUG(+$P(RX0,"^",6),2)),"^",3)["U"&(COD):$P(RX0,"^",6),1:"") K COD
     78 S ^TMP("PS",$J,"SCH",0)=0,(SCH,SC)=0
     79 F  S SC=$O(^PSRX(IFN,"SCH",SC)) Q:'SC  S SCH=SCH+1,^TMP("PS",$J,"SCH",SCH,0)=$P(^PSRX(IFN,"SCH",SC,0),"^") D
     80 .S ^TMP("PS",$J,"SCH",0)=^TMP("PS",$J,"SCH",0)+1
     81 D MDR^PSOORRL1
     82 S PSOELSE=0 I $D(^PSRX(IFN,"SIG")),'$P(^PSRX(IFN,"SIG"),"^",2) S PSOELSE=1 S X=$P(^PSRX(IFN,"SIG"),"^") D SIG^PSOORRL1
     83 I '$G(PSOELSE) S ITFN=1 D
     84 .S ^TMP("PS",$J,"SIG",ITFN,0)=$G(^PSRX(IFN,"SIG1",1,0)),^TMP("PS",$J,"SIG",0)=+$G(^TMP("PS",$J,"SIG",0))+1
     85 .F I=1:0 S I=$O(^PSRX(IFN,"SIG1",I)) Q:'I  S ITFN=ITFN+1,^TMP("PS",$J,"SIG",ITFN,0)=^PSRX(IFN,"SIG1",I,0),^TMP("PS",$J,"SIG",0)=+$G(^TMP("PS",$J,"SIG",0))+1
     86 K PSOELSE
     87 S ^TMP("PS",$J,"PC",0)=0,ITFN=0
     88 F I=0:0 S I=$O(^PSRX(IFN,"PRC",I)) Q:'I  S ITFN=ITFN+1,^TMP("PS",$J,"PC",ITFN,0)=^PSRX(IFN,"PRC",I,0),^TMP("PS",$J,"PC",0)=^TMP("PS",$J,"PC",0)+1
     89 Q
     90 ;
     91WAIT ; IF PENDING ENTRY STILL BEING BUILT SEE IF IT COMPLETES WITHIN ANOTHER SECOND
     92 H 1 S PSOR=$G(^PS(52.41,IFN,0))
     93 Q
     94 ;
     95NVA ; Set Non-VA Med Orders in the ^TMP Global
     96 ;BHW;PSO*7*159;New SDT,SDT1 Variables
     97 N SDT,SDT1
     98 F I=0:0 S I=$O(^PS(55,DFN,"NVA",I)) Q:'I  S X=$G(^PS(55,DFN,"NVA",I,0)) D
     99 .Q:'$P(X,"^")
     100 .S DRG=$S($P(X,"^",2):$P($G(^PSDRUG($P(X,"^",2),0)),"^"),1:$P(^PS(50.7,$P(X,"^"),0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,$P(X,"^"),0),"^",2),0),"^"))
     101 .S SDT=$P(X,"^",9) I 'SDT D TMPBLD Q
     102 .I $E(SDT,4,5),$E(SDT,6,7) D
     103 ..;I $P(X,"^",9) D  Q
     104 ..I $G(BDT),SDT<BDT Q
     105 ..I $G(EDT),SDT>EDT Q
     106 ..I $G(BDT),$P(X,"^",7),$P(X,"^",7)<BDT Q
     107 ..D TMPBLD
     108 .I $E(SDT,4,5),'$E(SDT,6,7) D
     109 ..S SDT1=$E(SDT,1,5),BDT1=$E(+$G(BDT),1,5),EDT1=$E(+$G(EDT),1,5)
     110 ..I $G(BDT1),SDT1<BDT1 Q
     111 ..I $G(EDT1),SDT1>EDT1 Q
     112 ..I $G(BDT1),$P(X,"^",7),$E($P(X,"^",7),1,5)<BDT1 Q
     113 ..D TMPBLD
     114 .I '$E(SDT,4,5),'$E($P(X,"^",9),6,7) D
     115 ..;I $P(X,"^",9) D  Q
     116 ..S SDT1=$E(SDT,1,3),BDT1=$E(+$G(BDT),1,3),EDT1=$E(+$G(EDT),1,3)
     117 ..I $G(BDT1),SDT1<BDT1 Q
     118 ..I $G(EDT1),SDT1>EDT1 Q
     119 ..I $G(BDT1),$P(X,"^",7),$E($P(X,"^",7),1,3)<BDT1 Q
     120 ..D TMPBLD
     121 Q
     122TMPBLD S TFN=$G(TFN)+1,^TMP("PS",$J,TFN,0)=I_"N;O^"_DRG
     123 S $P(^TMP("PS",$J,TFN,0),"^",8)=$P(X,"^",8)_"^"_$S($P(X,"^",7):"DISCONTINUED",1:"ACTIVE")
     124 S ^TMP("PS",$J,TFN,"SCH",0)=1,^TMP("PS",$J,TFN,"SCH",1,0)=$P(X,"^",5)
     125 S ^TMP("PS",$J,TFN,"SIG",0)=1,^TMP("PS",$J,TFN,"SIG",1,0)=$P(X,"^",3)_" "_$P(X,"^",4)_" "_$P(X,"^",5)
     126 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORRNW.m

    r613 r623  
    1 PSOORRNW        ;BIR/SAB-finish OP renew orders from OE/RR ;4/25/07 8:46am
    2         ;;7.0;OUTPATIENT PHARMACY;**11,27,51,46,71,94,130,131,146,206,225**;DEC 1997;Build 29
    3         ;External reference to ^PSDRUG supported by DBIA 221
    4         ;External reference to ^PS(50.607 supported by DBIA 2221
    5         ;External reference to ^PS(51.2 supported by DBIA 2226
    6         ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
    7         S PSORENXX=$P($G(OR0),"^",21),PSOFROM="NEW" K PRC,PHI
    8         I $G(PSORENXX) D PSOL^PSSLOCK(PSORENXX) I '$G(PSOMSG) D  K DIR,PSOMSG W ! S DIR("A")="Press Return to continue",DIR(0)="E" D ^DIR K DIR W ! Q
    9         .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P(PSOMSG,"^",2) Q
    10         .W $C(7),!!,"Another person is editing Rx "_$P($G(^PSRX(PSORENXX,0)),"^")
    11         K PSOMSG N OI,VALMCNT K POERR("DFLG") D FULL^VALM1 S (PSORX("DFLG"),PSORENW("DFLG"))=0,(PSORNW("FILL DATE"),PSORENW("FILL DATE"))=DT
    12         S Y=DT X ^DD("DD") S PSORX("FILL DATE")=Y K Y
    13         ;
    14         I $G(ORD),+$P($G(^PS(52.41,+ORD,0)),"^",23)=1 D  Q:$D(DIRUT)!'Y  D EN1^ORCFLAG(+$P($G(^PS(52.41,ORD,0)),"^")) H 1
    15         . K DIRUT,DUOUT,DTOUT,DIR
    16         . S DIR("A",1)="This Renewal Request is flagged. In order to process it"
    17         . S DIR("A",2)="you must unflag it first."
    18         . S DIR("A",3)=""
    19         . S DIR(0)="Y",DIR("A")="Unflag Renewal Request",DIR("B")="NO"
    20         . W ! D ^DIR I $D(DIRUT)!'Y S VALMBCK="Q"
    21         I $G(ORD),+$P($G(^PS(52.41,+ORD,0)),"^",23)=1 Q
    22         ;
    23         W !!,"Now Renewing Rx # "_$P(^PSRX($P(OR0,"^",21),0),"^")_"   Drug: "_$P($G(^PSDRUG($P(^PSRX($P(OR0,"^",21),0),"^",6),0)),"^"),! H 2
    24         I $P($G(^PSRX($P(OR0,"^",21),"OR1")),"^",4) D  D PROCESSX^PSORENW0 D UL Q
    25         .W !!,"Cannot Renew Rx # "_$P(^PSRX($P(OR0,"^",21),0),"^"),!," Drug: "_$P($G(^PSDRUG($P(^PSRX($P(OR0,"^",21),0),"^",6),0)),"^")_"."
    26         .W !,"This Rx has already been RENEWED ("_$P(^PSRX($P(^PSRX($P(OR0,"^",21),"OR1"),"^",4),0),"^")_").",!
    27         .S ACOM="Duplicate Renewal Request. Order rejected by Pharmacy.",PSONOOR="D" D DE^PSOORFI2 K ACOM,POERR("COMM"),POERR("PLACER"),POERR("STAT")
    28         I '$G(PSOTPBFG) D DSPL^PSOTPCAN(ORD)
    29         S (PSORX("PROVIDER NAME"),PSORENW("PROVIDER NAME"))=$P(^VA(200,$P(OR0,"^",5),0),"^"),PSORENW("NOO")=$P(OR0,"^",7)
    30         S PSORENW("PROVIDER")=$P(OR0,"^",5),PSORENW("MAIL/WINDOW")=$S($P(OR0,"^",17)="M":"M",1:"W")
    31         ;I $O(^PSRX($P(OR0,"^",21),"PRC",0)) F I=0:0 S I=$O(^PSRX($P(OR0,"^",21),"PRC",I)) Q:'I  S PRC(I)=^PSRX($P(OR0,"^",21),"PRC",I,0)
    32         K II F I=0:0 S I=$O(^PS(52.41,ORD,1,I)) Q:'I  S DOSE=$G(^PS(52.41,ORD,1,I,1)),DOSE1=$G(^(2)) D
    33         .S II=$G(II)+1
    34         .S PSORENW("DOSE",II)=$P(DOSE1,"^"),PSORENW("DOSE ORDERED",II)=$P(DOSE1,"^",2),PSORENW("UNITS",II)=$P(DOSE,"^",9),PSORENW("NOUN",II)=$P(DOSE,"^",5)
    35         .S:$P(DOSE,"^",9) UNITS=$P(^PS(50.607,$P(DOSE,"^",9),0),"^")
    36         .S PSORENW("VERB",II)=$P(DOSE,"^",10),PSORENW("ROUTE",II)=$P(DOSE,"^",8)
    37         .S:$P(DOSE,"^",8) ROUTE=$P(^PS(51.2,$P(DOSE,"^",8),0),"^")
    38         .S PSORENW("SCHEDULE",II)=$P(DOSE,"^"),PSORENW("DURATION",II)=$P(DOSE,"^",2)
    39         .I $P(DOSE,"^",6)]"" S PSORENW("CONJUNCTION",II)=$S($P(DOSE,"^",6)="S":"T",$P(DOSE,"^",6)="X":"X",1:"A")
    40         S PSORENW("ENT")=+$G(II) K II,I
    41         F DR=1:1:PSORENW("ENT") I $G(PSORENW("DURATION",DR))]"" D
    42         .S DUR1=PSORENW("DURATION",DR)
    43         .S PSORENW("DURATION",DR)=$S($E(DUR1,1)'?.N:$E(DUR1,2,99)_$E(DUR1,1),1:DUR1)
    44         D ^PSORENW1,CHECK^PSORENW0 I PSORENW("DFLG") D KLIB^PSORENW1 D PROCESSX^PSORENW0 D UL Q
    45         D FILDATE^PSORENW0,DRUG^PSORENW0 I PSORENW("DFLG")!$G(PSORX("DFLG")) D KLIB^PSORENW1 D PROCESSX^PSORENW0 D UL Q
    46         D RXN^PSORENW0 I PSORENW("DFLG") D KLIB^PSORENW1 D PROCESSX^PSORENW0 D UL Q
    47         D STOP^PSORENW1,INIT^PSORENW3
    48         I $G(PSOORRNW) D
    49         .S PSORENW("ISSUE DATE")=$S(PSORENW("FILL DATE")>DT:DT,PSORENW("FILL DATE")<$E($P(OR0,"^",6),1,7):PSORENW("FILL DATE"),1:$E($P(OR0,"^",6),1,7))
    50         .S PSORENW("# OF REFILLS")=+$P(OR0,"^",11),PSOFDR=1
    51         .S PSORENW("CLERK CODE")=$P(OR0,"^",4),PSORX("CLERK CODE")=$P(^VA(200,$P(OR0,"^",4),0),"^")
    52         ;D CHK
    53         S PSOFXRN=0,PSOFXRNX=1
    54         S PSORENW("POE")=$S($G(^PS(52.41,ORD,"POE"))=1:1,'$O(^PSRX($P(OR0,"^",21),6,0)):1,1:"")
    55         S PSORENW("PENDING ORDER")=ORD
    56         D EN^PSOORNE4(.PSORENW) K PSORENW,PSORX("FILL DATE")
    57         I '$G(PSOFXRN) D UL
    58         D KLIB^PSORENW1
    59         K PSOFXRN,PSOFXRNX
    60         Q
    61 CHK     ;check for valid # of refills
    62         I $G(PSODRUG("DEA"))]"" D
    63         .S PSOCS=0 K DIR,DIC,PSOX
    64         .F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSOCS,"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSOCS,"^",2)=1
    65         .;PSO*7*206
    66         .S PSOMAX=$S(PSOCS:5,1:11) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) S PSOMAX=0
    67         E  S PSOMAX=$P(OR0,"^",11)
    68         S RXPT=+$P(PSORENW("RX0"),"^",3) I $G(^PS(53,RXPT,0))]"" D
    69         .S PSORENW("# OF REFILLS")=$S(+$P(OR0,"^",11)>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:+$P(OR0,"^",11)),PSOX=+$P(^PS(53,RXPT,0),"^",4)
    70         .S PSORENW("# OF REFILLS")=$S(PSORENW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSORENW("# OF REFILLS"))
    71         .S PSOMAX=$S(PSOMAX>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:PSOMAX) K RXPT
    72         E  D
    73         . I $G(PSOMAX) S PSORENW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11))
    74         Q
    75         ;
    76 EDTPEN  ;edit front door renews
    77         N VALMCNT S Y=$P(XQORNOD(0),"=",2) D EDTSEL^PSOORNE4
    78         Q
    79 UL      I $G(PSORENXX) D PSOUL^PSSLOCK(PSORENXX)
    80         K PSORENXX
    81         Q
     1PSOORRNW ;BIR/SAB-finish OP renew orders from OE/RR ; 11/3/06 10:02pm
     2 ;;7.0;OUTPATIENT PHARMACY;**11,27,51,46,71,94,130,131,146,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 ;External reference to ^PSDRUG supported by DBIA 221
     20 ;External reference to ^PS(50.607 supported by DBIA 2221
     21 ;External reference to ^PS(51.2 supported by DBIA 2226
     22 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
     23 S PSORENXX=$P($G(OR0),"^",21),PSOFROM="NEW" K PRC,PHI
     24 I $G(PSOAFYN)'="Y" I $G(PSORENXX) D PSOL^PSSLOCK(PSORENXX) I '$G(PSOMSG) D  K DIR,PSOMSG W ! S DIR("A")="Press Return to continue",DIR(0)="E" D ^DIR K DIR W ! Q  ;vfah
     25 .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P(PSOMSG,"^",2) Q
     26 .W $C(7),!!,"Another person is editing Rx "_$P($G(^PSRX(PSORENXX,0)),"^")
     27 I $G(PSOAFYN)="Y" I $G(PSORENXX) D PSOL^PSSLOCK(PSORENXX) ;vfah
     28 I $G(PSOAFYN)'="Y" K PSOMSG N OI,VALMCNT K POERR("DFLG") D FULL^VALM1 S (PSORX("DFLG"),PSORENW("DFLG"))=0,(PSORNW("FILL DATE"),PSORENW("FILL DATE"))=DT ;vfah
     29 I $G(PSOAFYN)="Y" K PSOMSG N OI,VALMCNT K POERR("DFLG") S (PSORX("DFLG"),PSORENW("DFLG"))=0,(PSORNW("FILL DATE"),PSORENW("FILL DATE"))=DT ;vfah
     30 S Y=DT X ^DD("DD") S PSORX("FILL DATE")=Y K Y
     31 I $G(PSOAFYN)'="Y" W !!,"Now Renewing Rx # "_$P(^PSRX($P(OR0,"^",21),0),"^")_"   Drug: "_$P($G(^PSDRUG($P(^PSRX($P(OR0,"^",21),0),"^",6),0)),"^"),! H 2 ;vfah
     32 I $P($G(^PSRX($P(OR0,"^",21),"OR1")),"^",4) D  D PROCESSX^PSORENW0 D UL Q
     33 .W !!,"Cannot Renew Rx # "_$P(^PSRX($P(OR0,"^",21),0),"^"),!," Drug: "_$P($G(^PSDRUG($P(^PSRX($P(OR0,"^",21),0),"^",6),0)),"^")_"."
     34 .W !,"This Rx has already been RENEWED ("_$P(^PSRX($P(^PSRX($P(OR0,"^",21),"OR1"),"^",4),0),"^")_").",!
     35 .S ACOM="Duplicate Renewal Request. Order rejected by Pharmacy.",PSONOOR="D" D DE^PSOORFI2 K ACOM,POERR("COMM"),POERR("PLACER"),POERR("STAT")
     36 I '$G(PSOTPBFG) D DSPL^PSOTPCAN(ORD)
     37 S (PSORX("PROVIDER NAME"),PSORENW("PROVIDER NAME"))=$P(^VA(200,$P(OR0,"^",5),0),"^"),PSORENW("NOO")=$P(OR0,"^",7)
     38 S PSORENW("PROVIDER")=$P(OR0,"^",5),PSORENW("MAIL/WINDOW")=$S($P(OR0,"^",17)="M":"M",1:"W")
     39 I $O(^PSRX($P(OR0,"^",21),"PRC",0)) F I=0:0 S I=$O(^PSRX($P(OR0,"^",21),"PRC",I)) Q:'I  S PRC(I)=^PSRX($P(OR0,"^",21),"PRC",I,0)
     40 K II F I=0:0 S I=$O(^PS(52.41,ORD,1,I)) Q:'I  S DOSE=$G(^PS(52.41,ORD,1,I,1)),DOSE1=$G(^(2)) D
     41 .S II=$G(II)+1
     42 .S PSORENW("DOSE",II)=$P(DOSE1,"^"),PSORENW("DOSE ORDERED",II)=$P(DOSE1,"^",2),PSORENW("UNITS",II)=$P(DOSE,"^",9),PSORENW("NOUN",II)=$P(DOSE,"^",5)
     43 .S:$P(DOSE,"^",9) UNITS=$P(^PS(50.607,$P(DOSE,"^",9),0),"^")
     44 .S PSORENW("VERB",II)=$P(DOSE,"^",10),PSORENW("ROUTE",II)=$P(DOSE,"^",8)
     45 .S:$P(DOSE,"^",8) ROUTE=$P(^PS(51.2,$P(DOSE,"^",8),0),"^")
     46 .S PSORENW("SCHEDULE",II)=$P(DOSE,"^"),PSORENW("DURATION",II)=$P(DOSE,"^",2)
     47 .I $P(DOSE,"^",6)]"" S PSORENW("CONJUNCTION",II)=$S($P(DOSE,"^",6)="S":"T",$P(DOSE,"^",6)="X":"X",1:"A")
     48 S PSORENW("ENT")=+$G(II) K II,I
     49 F DR=1:1:PSORENW("ENT") I $G(PSORENW("DURATION",DR))]"" D
     50 .S DUR1=PSORENW("DURATION",DR)
     51 .S PSORENW("DURATION",DR)=$S($E(DUR1,1)'?.N:$E(DUR1,2,99)_$E(DUR1,1),1:DUR1)
     52 D ^PSORENW1,CHECK^PSORENW0 I PSORENW("DFLG") D KLIB^PSORENW1 D PROCESSX^PSORENW0 D UL Q
     53 D FILDATE^PSORENW0,DRUG^PSORENW0 I PSORENW("DFLG")!$G(PSORX("DFLG")) D KLIB^PSORENW1 D PROCESSX^PSORENW0 D UL Q
     54 D RXN^PSORENW0 I PSORENW("DFLG") D KLIB^PSORENW1 D PROCESSX^PSORENW0 D UL Q
     55 D STOP^PSORENW1,INIT^PSORENW3
     56 I $G(PSOORRNW) D
     57 .S PSORENW("ISSUE DATE")=$S(PSORENW("FILL DATE")>DT:DT,PSORENW("FILL DATE")<$E($P(OR0,"^",6),1,7):PSORENW("FILL DATE"),1:$E($P(OR0,"^",6),1,7))
     58 .S PSORENW("# OF REFILLS")=+$P(OR0,"^",11),PSOFDR=1
     59 .S PSORENW("CLERK CODE")=$P(OR0,"^",4),PSORX("CLERK CODE")=$P(^VA(200,$P(OR0,"^",4),0),"^")
     60 ;D CHK
     61 S PSOFXRN=0,PSOFXRNX=1
     62 S PSORENW("POE")=$S($G(^PS(52.41,ORD,"POE"))=1:1,'$O(^PSRX($P(OR0,"^",21),6,0)):1,1:"")
     63 D EN^PSOORNE4(.PSORENW) K PSORENW,PSORX("FILL DATE")
     64 I '$G(PSOFXRN) D UL
     65 D KLIB^PSORENW1
     66 K PSOFXRN,PSOFXRNX
     67 Q
     68CHK ;check for valid # of refills
     69 I $G(PSODRUG("DEA"))]"" D
     70 .S PSOCS=0 K DIR,DIC,PSOX
     71 .F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSOCS,"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSOCS,"^",2)=1
     72 .S PSOMAX=$S(PSOCS:5,1:11) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") S PSOMAX=0
     73 E  S PSOMAX=$P(OR0,"^",11)
     74 S RXPT=+$P(PSORENW("RX0"),"^",3) I $G(^PS(53,RXPT,0))]"" D
     75 .S PSORENW("# OF REFILLS")=$S(+$P(OR0,"^",11)>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:+$P(OR0,"^",11)),PSOX=+$P(^PS(53,RXPT,0),"^",4)
     76 .S PSORENW("# OF REFILLS")=$S(PSORENW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSORENW("# OF REFILLS"))
     77 .S PSOMAX=$S(PSOMAX>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:PSOMAX) K RXPT
     78 E  D
     79 . I $G(PSOMAX) S PSORENW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11))
     80 Q
     81 ;
     82EDTPEN ;edit front door renews
     83 N VALMCNT S Y=$P(XQORNOD(0),"=",2) D EDTSEL^PSOORNE4
     84 Q
     85UL I $G(PSORENXX) D PSOUL^PSSLOCK(PSORENXX)
     86 K PSORENXX
     87 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORUT1.m

    r613 r623  
    1 PSOORUT1        ;BIR/SAB - Utility routine for oerr interface ;6/28/07 7:36am
    2         ;;7.0;OUTPATIENT PHARMACY;**1,14,30,46,132,148,233,274,225**;DEC 1997;Build 29
    3         ;External reference to ^PSDRUG supported by DBIA 221
    4         ;External reference to ^PSXOPUTL supported by DBIA 2203
    5         ;called from HD^PSOORUTL
    6 REL     ;removed order from hold
    7         S ACT=1,ORS=0
    8         I POERR("PSOFILNM")["S" S DA=+POERR("PSOFILNM") D  G EXIT^PSOORUTL
    9         .Q:'$D(^PS(52.41,DA,0))  Q:$P(^PS(52.41,DA,0),"^",3)="RF"
    10         .S $P(^PS(52.41,DA,0),"^",3)="NW",POERR("STAT")="OR",POERR("FILLER")=DA_"^P"
    11         .S:$G(POERR("COMM"))']"" POERR("COMM")="Order RELEASED from HOLD by OE/RR before finished." S $P(^PS(52.41,DA,4),"^")=POERR("COMM"),ORS=1
    12         S DA=POERR("PSOFILNM") I $D(^PSRX(DA,0)) S ORS=1,PSDA=DA D  G EXIT^PSOORUTL
    13         .S POERR("FILLER")=DA_"^R",POERR("STAT")="OR"
    14         .S:'$D(POERR("COMM")) POERR("COMM")="Prescription Released from HOLD by OE/RR"
    15         .I DT>$P(^PSRX(DA,2),"^",6) D
    16         ..S EXP=$P(^PSRX(DA,2),"^",6) S:$P(^PSRX(DA,"STA"),"^")<12 $P(^PSRX(DA,"STA"),"^")=11,PSOEXFLG=1 S POERR("STAT")="UR",POERR("COMM")="Medication Expired on "_$E(EXP,4,5)_"/"_$E(EXP,6,7)_"/"_$E(EXP,2,3)_".",POERR("PHARMST")="" D ECAN^PSOUTL(DA) Q
    17         .I $P(^PSRX(DA,"STA"),"^")'=16 S POERR("STAT")="UR",POERR("COMM")="Unable to Release from Hold" Q
    18         .S RXFL(DA)=0,FDT=$P(^PSRX(DA,2),"^",2)
    19         .I $O(^PSRX(DA,1,0)) F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S FDT=$P(^PSRX(DA,1,I,0),"^"),RXFL(DA)=I
    20         .I FDT>DT N PSOSITEZ,ZPSOPAR6 S PSOSITEZ=$S($P($G(^PSRX(DA,2)),"^",9):$P(^(2),"^",9),1:$O(^PS(59,0))),ZPSOPAR6=$P($G(^PS(59,PSOSITEZ,1)),"^",6) I ZPSOPAR6 D  Q
    21         ..S RXXDA=DA,DA=$O(^PS(52.5,"B",RXXDA,0)) I DA S DIK="^PS(52.5," D ^DIK K DIK
    22         ..S DA=RXXDA
    23         ..S DIC="^PS(52.5,",DIC(0)="L",DLAYGO=52.5,X=RXXDA,DIC("DR")=".02///"_FDT_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04///M;.05///0;.06////"_PSOSITEZ_";2///0;9///"_RXFL(DA) K DD,DO D FILE^DICN K RXFL,DD,DO
    24         ..S DA=RXXDA K RXXDA S $P(^PSRX(DA,"STA"),"^")=5,LFD=$E(FDT,4,5)_"-"_$E(FDT,6,7)_"-"_$E(FDT,2,3) D ACT1
    25         ..S PSOSUSZ=1
    26         .E  S $P(^PSRX(DA,"STA"),"^")=0
    27         .S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S RXF=I S:I>5 RXF=I+1
    28         .D ACT^PSOORUTL
    29         .I $$SUBMIT^PSOBPSUT(DA) D ECMESND^PSOBPSU1(DA,,$$RXFLDT^PSOBPSUT(DA),$S('$O(^PSRX(DA,1,0)):"OF",1:"RF"))
    30         G EXIT^PSOORUTL
    31 ACT1    S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S RXF=I S:I>5 RXF=I+1
    32         S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA  S IR=FDA
    33         S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
    34         D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^S^"_POERR("USER")_"^"_RXF_"^"_"RX Placed on Suspense until "_LFD
    35         Q
    36 SUS     ;
    37         I $P($G(^PSRX(+$G(FILLER),"STA")),"^")=5 N PSOMSORR,PLACERXX D EN^PSOHLSN1(+$G(FILLER),"SC","ZS","")
    38         Q
    39 BLD     ;builds med profile for Listman
    40         K ^TMP("PSOPF",$J),PSOLST S:$G(PSOOPT)'=3 PSOOPT=0 I '$G(PSOSD) S ^TMP("PSOPF",$J,1,0)="This patient has no prescriptions" S PSOCNT=0,PSOPF=1 Q
    41         D EOJ,SHOW
    42 EOJ     ;
    43         K PSOQFLG,PSODRG,PSODATA,PSOLF
    44         Q
    45         ;-----------------------------------------------------------------
    46 SHOW    ;
    47         ; - ePharmacy modification to create a section for Rx with REJECTs
    48         N PSOTMP,PSOSTS,PSODRNM,I,PSORX
    49         S (PSOSTS,PSODRNM)=""
    50         F  S PSOSTS=$O(PSOSD(PSOSTS)) Q:PSOSTS=""  D
    51         . F  S PSODRNM=$O(PSOSD(PSOSTS,PSODRNM)) Q:PSODRNM=""  D
    52         . . S PSORX=+$G(PSOSD(PSOSTS,PSODRNM))
    53         . . I PSOSTS="ACTIVE",$$FIND^PSOREJUT(PSORX) D  Q
    54         . . . S PSOTMP(" REJECT",PSODRNM)=PSOSTS
    55         . . S PSOTMP(PSOSTS,PSODRNM)=PSOSTS
    56         ;
    57         S (PSOSTS,PSODRG)="",(PSOCNT,PSOQFLG,IEN)=0
    58         K RN,DL S $P(RN," ",12)=" ",$P(DL," ",40)=" "
    59         F PSCNT=0:0 S PSOSTS=$O(PSOTMP(PSOSTS)) Q:PSOSTS=""  D
    60         . D STA
    61         . F PSOCT=0:0 S PSODRG=$O(PSOTMP(PSOSTS,PSODRG)) Q:PSODRG=""  Q:PSOCNT>1000!PSOQFLG  D
    62         . . S PSOSTA=PSOTMP(PSOSTS,PSODRG)
    63         . . S PSODATA=PSOSD(PSOSTA,PSODRG) I PSOSTA="ZNONVA" D NVA Q
    64         . . S PSOCNT=PSOCNT+1 I PSOSTA="PENDING" D PEN Q
    65         . . S:'$D(^PSRX(+PSODATA,0)) PSOCNT=PSOCNT-1 D:$D(^(0)) DISPL
    66         S (VALMCNT,PSOPF)=IEN
    67 SHOWX   K DIRUT,DTOUT,DUOUT,DIROUT,PSODRG
    68         Q
    69         ;
    70 DISPL   S IEN=IEN+1 N PSOID,PSOCMOP,STATLTH,ECME
    71         K PSOLNT,PSOQTL,PSOLSP S PSOLRX=$S($G(^PSRX(+PSODATA,"IB")):13,1:14)-$L($P(^PSRX(+PSODATA,0),"^")),$P(PSOLNT," ",PSOLRX)=" ",PSODQL=$L($P(PSODRG,"^"))+$L($P(^PSRX(+PSODATA,0),"^",7))
    72         I PSODQL<39 S $P(PSOQTL," ",(40-PSODQL))=" "
    73         E  S $P(PSOQTL," ",(52-$L($P(^PSRX(+PSODATA,0),"^",7))))=" ",$P(PSOLSP," ",(41-$L($P(PSODRG,"^"))))=" "
    74         S ECME=$$ECME^PSOBPSUT(+PSODATA) I ECME'="" S PSOLNT=$E(PSOLNT,1,$L(PSOLNT)-1)
    75         S ^TMP("PSOPF",$J,IEN,0)=$J(PSOCNT,2)_$S($L(PSOCNT)<3:" ",1:"")_$P(^PSRX(+PSODATA,0),"^")_$S($G(^PSRX(+PSODATA,"IB")):"$",1:"")_ECME_PSOLNT_$P(PSODRG,"^")_$S(PSODQL<39:PSOQTL_$P(^PSRX(+PSODATA,0),"^",7)_" ",1:$G(PSOLSP))
    76         S STA="A^N^R^H^N^S^^^^^^E^DC^^DC^DE^H^P^"
    77         S PSOCMOP=""
    78         I $D(^PSDRUG("AQ",$P(^PSRX(+PSODATA,0),"^",6))) S PSOCMOP=">"
    79         N X S X="PSXOPUTL" X ^%ZOSF("TEST") K X I $T D
    80         .N DA S DA=+PSODATA D ^PSXOPUTL K DA
    81         .I $G(PSXZ(PSXZ("L")))=0!($G(PSXZ(PSXZ("L")))=2) S PSOCMOP="T"
    82         .K PSXZ
    83         N PSOBADR
    84         S PSOBADR=$O(^PSRX(+PSODATA,"L",9999),-1)
    85         I PSOBADR'="" S PSOBADR=$G(^PSRX(+PSODATA,"L",PSOBADR,0)) I PSOBADR["(BAD ADDRESS)" S PSOBADR="B"
    86         I PSOBADR'="B" S PSOBADR=""
    87         S STAPRT=$P(STA,"^",$P(PSODATA,"^",2)+1)_PSOCMOP_PSOBADR
    88         S STATLTH=$L(STAPRT)
    89         S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_STAPRT_$S(STATLTH=0:"   ",STATLTH=1:"  ",STATLTH=2:" ",1:"")
    90         S PSOID=$P(^PSRX(+PSODATA,0),"^",13),PSOLF=+$G(^(3)),^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$E(PSOID,4,5)_"-"_$E(PSOID,6,7)_" "
    91         F PSOX=0:0 S PSOX=$O(^PSRX(+PSODATA,1,PSOX)) Q:'PSOX  D
    92         . I +$G(^PSRX(+PSODATA,1,PSOX,0))=PSOLF,$P($G(^PSRX(+PSODATA,1,PSOX,0)),"^",16) S PSOLF=PSOLF_"^R"
    93         K PSOX
    94         I '$O(^PSRX(+PSODATA,1,0)),$P(^PSRX(+PSODATA,2),"^",15) S PSOLF=PSOLF_"^R"
    95         S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$S($G(PSOLF):$E(PSOLF,4,5),1:"  ")_"-"_$S($G(PSOLF):$E(PSOLF,6,7),1:"  ")_$S($P(PSOLF,"^",2)="R":"R ",1:"  ")
    96         S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$J($P(PSODATA,"^",6),2)_" "_$J($P(PSODATA,"^",8),3)
    97         I PSODQL>38 S IEN=IEN+1 S ^TMP("PSOPF",$J,IEN,0)=PSOQTL_"Qty: "_$P(^PSRX(+PSODATA,0),"^",7)
    98         K PSOLNT,PSOQTL,PSOLSP,PSOLRX,PSODQL
    99         S PSOLST(PSOCNT)="52^"_+PSODATA_"^"_PSOSTA
    100         K PSODATA,PSOLF S PSOPF=IEN
    101         Q
    102         ;
    103 STA     N LABEL,LINE,POS
    104         S LABEL=PSOSTS,IEN=IEN+1
    105         I PSOSTS="ZNONVA" S LABEL="Non-VA MEDS (Not dispensed by VA)"
    106         I PSOSTS=" REJECT" S LABEL="REFILL TOO SOON/DUR REJECTS (Third Party)"
    107         S POS=80-$L(LABEL)/2,$P(LINE,"-",81)="",$E(LINE,POS+1,POS+$L(LABEL))=LABEL
    108         S ^TMP("PSOPF",$J,IEN,0)=LINE
    109         Q
    110 PENX    S PSOLST(PSOCNT)="52.41^"_$P(PSODATA,"^",10)_"^"_PSOSTA
    111         K PSODATA,PSOLF,RN,PSOLSP,PSOQTL,PSOLNT
    112         Q
    113 PEN     ;
    114         N PSOQTL,PSOLNT,PSOLNTZ,PSOQTLX,PSCMOPF,SPACEZ
    115         Q:'$D(^PS(52.41,$P(PSODATA,"^",10),0))
    116         S PSCMOPF=0 I $P($G(PSODATA),"^",11),$D(^PSDRUG("AQ",$P(PSODATA,"^",11))) S PSCMOPF=1
    117         S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=$J(PSOCNT,2)_$S($L(PSOCNT)<3:" ",1:"")_$P(PSODRG,"^")
    118         I $P($G(^PS(52.41,+$P(PSODATA,"^",10),0)),"^",23)=1 S ^TMP("PSOPF",$J,IEN,"RV")=""
    119         S PSOLNT=$L($P(PSODRG,"^")),PSOLNTZ=$L($P(PSODATA,"^",8))
    120         S $P(PSOQTLX," ",(11-PSOLNTZ))=" "
    121         S:PSOLNT<37 $P(PSOQTL," ",(37-PSOLNT))=" "
    122         I PSOLNT<38 D  G PENX
    123         .I PSOLNT=37 S PSOQTL=""
    124         .I $P(^PS(52.41,$P(PSODATA,"^",10),0),"^",3)="RF" S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$G(PSOQTL)_"  Refill Request   Rx #: "_$P(^PSRX($P(^PS(52.41,$P(PSODATA,"^",10),0),"^",19),0),"^") Q
    125         .S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$G(PSOQTL)_"  "_"QTY: "_$P(PSODATA,"^",8)_$G(PSOQTLX)_" ISDT: "_$S('$P(PSODATA,"^",9):"     ",1:$E($P(PSODATA,"^",9),4,5)_"-"_$E($P(PSODATA,"^",9),6,7))_$S($G(PSCMOPF):"> ",1:"  ")
    126         .S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_"REF: "_$S($L($P(PSODATA,"^",6))>1:"",1:" ")_$P(PSODATA,"^",6)
    127         S IEN=IEN+1,$P(SPACEZ," ",42)=" "
    128         I $P(^PS(52.41,$P(PSODATA,"^",10),0),"^",3)="RF" S ^TMP("PSOPF",$J,IEN,0)=SPACEZ_"Refill Request   Rx #: "_$P(^PSRX($P(^PS(52.41,$P(PSODATA,"^",10),0),"^",19),0),"^") G PENX
    129         S ^TMP("PSOPF",$J,IEN,0)=SPACEZ_"QTY: "_$P(PSODATA,"^",8)_$G(PSOQTLX)_" ISDT: "_$S('$P(PSODATA,"^",9):"     ",1:$E($P(PSODATA,"^",9),4,5)_"-"_$E($P(PSODATA,"^",9),6,7))_$S($G(PSCMOPF):"> ",1:"  ")_"REF: "_$S($L($P(PSODATA,"^",6))>1:"",1:" ")
    130         S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$P(PSODATA,"^",6)
    131         G PENX
    132         ;
    133 NVA     ; Setting the Non-VA Meds on the Medication Profile Screen (ListMan)
    134         S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)="  "_$P(PSODRG,"^")_" "
    135         I ($L(^TMP("PSOPF",$J,IEN,0))+$L($P(PSODATA,"^",6))>70) S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)="    "
    136         S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$P(PSODATA,"^",6)_" "
    137         I ($L(^TMP("PSOPF",$J,IEN,0))+$L($P(PSODATA,"^",8))>70) S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)="    "
    138         S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$P(PSODATA,"^",8)
    139         I ($L(^TMP("PSOPF",$J,IEN,0))+20)>70 D  Q
    140         . S IEN=IEN+1,$P(^TMP("PSOPF",$J,IEN,0)," ",51)="Date Documented: "_$E($P(PSODATA,"^",9),4,5)_"/"_$E($P(PSODATA,"^",9),6,7)_"/"_$E($P(PSODATA,"^",9),2,3)
    141         F I=0:0 S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_" " Q:$L(^TMP("PSOPF",$J,IEN,0))>49
    142         S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_"Date Documented: "_$E($P(PSODATA,"^",9),4,5)_"/"_$E($P(PSODATA,"^",9),6,7)_"/"_$E($P(PSODATA,"^",9),2,3)
    143         Q
     1PSOORUT1 ;BIR/SAB - Utility routine for oerr interface ;02/22/95
     2 ;;7.0;OUTPATIENT PHARMACY;**1,14,30,46,132,148,233**;DEC 1997;Build 8
     3 ;External reference to ^PSDRUG supported by DBIA 221
     4 ;External reference to ^PSXOPUTL supported by DBIA 2203
     5 ;called from HD^PSOORUTL
     6REL ;removed order from hold
     7 S ACT=1,ORS=0
     8 I POERR("PSOFILNM")["S" S DA=+POERR("PSOFILNM") D  G EXIT^PSOORUTL
     9 .Q:'$D(^PS(52.41,DA,0))  Q:$P(^PS(52.41,DA,0),"^",3)="RF"
     10 .S $P(^PS(52.41,DA,0),"^",3)="NW",POERR("STAT")="OR",POERR("FILLER")=DA_"^P"
     11 .S:$G(POERR("COMM"))']"" POERR("COMM")="Order RELEASED from HOLD by OE/RR before finished." S $P(^PS(52.41,DA,4),"^")=POERR("COMM"),ORS=1
     12 S DA=POERR("PSOFILNM") I $D(^PSRX(DA,0)) S ORS=1,PSDA=DA D  G EXIT^PSOORUTL
     13 .S POERR("FILLER")=DA_"^R",POERR("STAT")="OR"
     14 .S:'$D(POERR("COMM")) POERR("COMM")="Prescription Released from HOLD by OE/RR"
     15 .I DT>$P(^PSRX(DA,2),"^",6) D
     16 ..S EXP=$P(^PSRX(DA,2),"^",6) S:$P(^PSRX(DA,"STA"),"^")<12 $P(^PSRX(DA,"STA"),"^")=11,PSOEXFLG=1 S POERR("STAT")="UR",POERR("COMM")="Medication Expired on "_$E(EXP,4,5)_"/"_$E(EXP,6,7)_"/"_$E(EXP,2,3)_".",POERR("PHARMST")="" D ECAN^PSOUTL(DA) Q
     17 .I $P(^PSRX(DA,"STA"),"^")'=16 S POERR("STAT")="UR",POERR("COMM")="Unable to Release from Hold" Q
     18 .S RXFL(DA)=0,FDT=$P(^PSRX(DA,2),"^",2)
     19 .I $O(^PSRX(DA,1,0)) F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S FDT=$P(^PSRX(DA,1,I,0),"^"),RXFL(DA)=I
     20 .I FDT>DT N PSOSITEZ,ZPSOPAR6 S PSOSITEZ=$S($P($G(^PSRX(DA,2)),"^",9):$P(^(2),"^",9),1:$O(^PS(59,0))),ZPSOPAR6=$P($G(^PS(59,PSOSITEZ,1)),"^",6) I ZPSOPAR6 D  Q
     21 ..S RXXDA=DA,DA=$O(^PS(52.5,"B",RXXDA,0)) I DA S DIK="^PS(52.5," D ^DIK K DIK
     22 ..S DA=RXXDA
     23 ..S DIC="^PS(52.5,",DIC(0)="L",DLAYGO=52.5,X=RXXDA,DIC("DR")=".02///"_FDT_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04///M;.05///0;.06////"_PSOSITEZ_";2///0;9///"_RXFL(DA) K DD,DO D FILE^DICN K RXFL,DD,DO
     24 ..S DA=RXXDA K RXXDA S $P(^PSRX(DA,"STA"),"^")=5,LFD=$E(FDT,4,5)_"-"_$E(FDT,6,7)_"-"_$E(FDT,2,3) D ACT1
     25 ..S PSOSUSZ=1
     26 .E  S $P(^PSRX(DA,"STA"),"^")=0
     27 .S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S RXF=I S:I>5 RXF=I+1
     28 .D ACT^PSOORUTL
     29 .I $$SUBMIT^PSOBPSUT(DA) D ECMESND^PSOBPSU1(DA,,$$RXFLDT^PSOBPSUT(DA),$S('$O(^PSRX(DA,1,0)):"OF",1:"RF"))
     30 G EXIT^PSOORUTL
     31ACT1 I '$D(RXF) S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S RXF=I S:I>5 RXF=I+1
     32 S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA  S IR=FDA
     33 S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
     34 D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^S^"_POERR("USER")_"^"_RXF_"^"_"RX Placed on Suspense until "_LFD
     35 Q
     36SUS ;
     37 I $P($G(^PSRX(+$G(FILLER),"STA")),"^")=5 N PSOMSORR,PLACERXX D EN^PSOHLSN1(+$G(FILLER),"SC","ZS","")
     38 Q
     39BLD ;builds med profile for Listman
     40 K ^TMP("PSOPF",$J),PSOLST S:$G(PSOOPT)'=3 PSOOPT=0 I '$G(PSOSD) S ^TMP("PSOPF",$J,1,0)="This patient has no prescriptions" S PSOCNT=0,PSOPF=1 Q
     41 D EOJ,SHOW
     42EOJ ;
     43 K PSOQFLG,PSODRG,PSODATA,PSOLF
     44 Q
     45 ;-----------------------------------------------------------------
     46SHOW ;
     47 ; - ePharmacy modification to create a section for Rx with REJECTs
     48 N PSOTMP,PSOSTS,PSODRNM,I,PSORX
     49 S (PSOSTS,PSODRNM)=""
     50 F  S PSOSTS=$O(PSOSD(PSOSTS)) Q:PSOSTS=""  D
     51 . F  S PSODRNM=$O(PSOSD(PSOSTS,PSODRNM)) Q:PSODRNM=""  D
     52 . . S PSORX=+$G(PSOSD(PSOSTS,PSODRNM))
     53 . . I PSOSTS="ACTIVE",$$FIND^PSOREJUT(PSORX) D  Q
     54 . . . S PSOTMP(" REJECT",PSODRNM)=PSOSTS
     55 . . S PSOTMP(PSOSTS,PSODRNM)=PSOSTS
     56 ;
     57 S (PSOSTS,PSODRG)="",(PSOCNT,PSOQFLG,IEN)=0
     58 K RN,DL S $P(RN," ",12)=" ",$P(DL," ",40)=" "
     59 F PSCNT=0:0 S PSOSTS=$O(PSOTMP(PSOSTS)) Q:PSOSTS=""  D
     60 . D STA
     61 . F PSOCT=0:0 S PSODRG=$O(PSOTMP(PSOSTS,PSODRG)) Q:PSODRG=""  Q:PSOCNT>1000!PSOQFLG  D
     62 . . S PSOSTA=PSOTMP(PSOSTS,PSODRG)
     63 . . S PSODATA=PSOSD(PSOSTA,PSODRG) I PSOSTA="ZNONVA" D NVA Q
     64 . . S PSOCNT=PSOCNT+1 I PSOSTA="PENDING" D PEN Q
     65 . . S:'$D(^PSRX(+PSODATA,0)) PSOCNT=PSOCNT-1 D:$D(^(0)) DISPL
     66 S (VALMCNT,PSOPF)=IEN
     67SHOWX K DIRUT,DTOUT,DUOUT,DIROUT,PSODRG
     68 Q
     69 ;
     70DISPL S IEN=IEN+1 N PSOID,PSOCMOP,STATLTH,ECME
     71 K PSOLNT,PSOQTL,PSOLSP S PSOLRX=$S($G(^PSRX(+PSODATA,"IB")):13,1:14)-$L($P(^PSRX(+PSODATA,0),"^")),$P(PSOLNT," ",PSOLRX)=" ",PSODQL=$L($P(PSODRG,"^"))+$L($P(^PSRX(+PSODATA,0),"^",7))
     72 I PSODQL<39 S $P(PSOQTL," ",(40-PSODQL))=" "
     73 E  S $P(PSOQTL," ",(52-$L($P(^PSRX(+PSODATA,0),"^",7))))=" ",$P(PSOLSP," ",(41-$L($P(PSODRG,"^"))))=" "
     74 S ECME=$$ECME^PSOBPSUT(+PSODATA) I ECME'="" S PSOLNT=$E(PSOLNT,1,$L(PSOLNT)-1)
     75 S ^TMP("PSOPF",$J,IEN,0)=$J(PSOCNT,2)_$S($L(PSOCNT)<3:" ",1:"")_$P(^PSRX(+PSODATA,0),"^")_$S($G(^PSRX(+PSODATA,"IB")):"$",1:"")_ECME_PSOLNT_$P(PSODRG,"^")_$S(PSODQL<39:PSOQTL_$P(^PSRX(+PSODATA,0),"^",7)_" ",1:$G(PSOLSP))
     76 S STA="A^N^R^H^N^S^^^^^^E^DC^^DC^DE^H^P^"
     77 S PSOCMOP=""
     78 I $D(^PSDRUG("AQ",$P(^PSRX(+PSODATA,0),"^",6))) S PSOCMOP=">"
     79 N X S X="PSXOPUTL" X ^%ZOSF("TEST") K X I $T D
     80 .N DA S DA=+PSODATA D ^PSXOPUTL K DA
     81 .I $G(PSXZ(PSXZ("L")))=0!($G(PSXZ(PSXZ("L")))=2) S PSOCMOP="T"
     82 .K PSXZ
     83 N PSOBADR
     84 S PSOBADR=$O(^PSRX(+PSODATA,"L",9999),-1)
     85 I PSOBADR'="" S PSOBADR=$G(^PSRX(+PSODATA,"L",PSOBADR,0)) I PSOBADR["(BAD ADDRESS)" S PSOBADR="B"
     86 I PSOBADR'="B" S PSOBADR=""
     87 S STAPRT=$P(STA,"^",$P(PSODATA,"^",2)+1)_PSOCMOP_PSOBADR
     88 S STATLTH=$L(STAPRT)
     89 S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_STAPRT_$S(STATLTH=0:"   ",STATLTH=1:"  ",STATLTH=2:" ",1:"")
     90 S PSOID=$P(^PSRX(+PSODATA,0),"^",13),PSOLF=+$G(^(3)),^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$E(PSOID,4,5)_"-"_$E(PSOID,6,7)_" "
     91 F PSOX=0:0 S PSOX=$O(^PSRX(+PSODATA,1,PSOX)) Q:'PSOX  D
     92 . I +$G(^PSRX(+PSODATA,1,PSOX,0))=PSOLF,$P($G(^PSRX(+PSODATA,1,PSOX,0)),"^",16) S PSOLF=PSOLF_"^R"
     93 K PSOX
     94 I '$O(^PSRX(+PSODATA,1,0)),$P(^PSRX(+PSODATA,2),"^",15) S PSOLF=PSOLF_"^R"
     95 S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$S($G(PSOLF):$E(PSOLF,4,5),1:"  ")_"-"_$S($G(PSOLF):$E(PSOLF,6,7),1:"  ")_$S($P(PSOLF,"^",2)="R":"R ",1:"  ")
     96 S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$J($P(PSODATA,"^",6),2)_" "_$J($P(PSODATA,"^",8),3)
     97 I PSODQL>38 S IEN=IEN+1 S ^TMP("PSOPF",$J,IEN,0)=PSOQTL_"Qty: "_$P(^PSRX(+PSODATA,0),"^",7)
     98 K PSOLNT,PSOQTL,PSOLSP,PSOLRX,PSODQL
     99 S PSOLST(PSOCNT)="52^"_+PSODATA_"^"_PSOSTA
     100 K PSODATA,PSOLF S PSOPF=IEN
     101 Q
     102 ;
     103STA N LABEL,LINE,POS
     104 S LABEL=PSOSTS,IEN=IEN+1
     105 I PSOSTS="ZNONVA" S LABEL="Non-VA MEDS (Not dispensed by VA)"
     106 I PSOSTS=" REJECT" S LABEL="REFILL TOO SOON/DUR REJECTS (Third Party)"
     107 S POS=80-$L(LABEL)/2,$P(LINE,"-",81)="",$E(LINE,POS+1,POS+$L(LABEL))=LABEL
     108 S ^TMP("PSOPF",$J,IEN,0)=LINE
     109 Q
     110PENX S PSOLST(PSOCNT)="52.41^"_$P(PSODATA,"^",10)_"^"_PSOSTA
     111 K PSODATA,PSOLF,RN,PSOLSP,PSOQTL,PSOLNT
     112 Q
     113PEN ;
     114 N PSOQTL,PSOLNT,PSOLNTZ,PSOQTLX,PSCMOPF,SPACEZ
     115 Q:'$D(^PS(52.41,$P(PSODATA,"^",10),0))
     116 S PSCMOPF=0 I $P($G(PSODATA),"^",11),$D(^PSDRUG("AQ",$P(PSODATA,"^",11))) S PSCMOPF=1
     117 S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=$J(PSOCNT,2)_$S($L(PSOCNT)<3:" ",1:"")_$P(PSODRG,"^")
     118 S PSOLNT=$L($P(PSODRG,"^")),PSOLNTZ=$L($P(PSODATA,"^",8))
     119 S $P(PSOQTLX," ",(11-PSOLNTZ))=" "
     120 S:PSOLNT<37 $P(PSOQTL," ",(37-PSOLNT))=" "
     121 I PSOLNT<38 D  G PENX
     122 .I PSOLNT=37 S PSOQTL=""
     123 .I $P(^PS(52.41,$P(PSODATA,"^",10),0),"^",3)="RF" S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$G(PSOQTL)_"  Refill Request   Rx #: "_$P(^PSRX($P(^PS(52.41,$P(PSODATA,"^",10),0),"^",19),0),"^") Q
     124 .S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$G(PSOQTL)_"  "_"QTY: "_$P(PSODATA,"^",8)_$G(PSOQTLX)_" ISDT: "_$S('$P(PSODATA,"^",9):"     ",1:$E($P(PSODATA,"^",9),4,5)_"-"_$E($P(PSODATA,"^",9),6,7))_$S($G(PSCMOPF):"> ",1:"  ")
     125 .S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_"REF: "_$S($L($P(PSODATA,"^",6))>1:"",1:" ")_$P(PSODATA,"^",6)
     126 S IEN=IEN+1,$P(SPACEZ," ",42)=" "
     127 I $P(^PS(52.41,$P(PSODATA,"^",10),0),"^",3)="RF" S ^TMP("PSOPF",$J,IEN,0)=SPACEZ_"Refill Request   Rx #: "_$P(^PSRX($P(^PS(52.41,$P(PSODATA,"^",10),0),"^",19),0),"^") G PENX
     128 S ^TMP("PSOPF",$J,IEN,0)=SPACEZ_"QTY: "_$P(PSODATA,"^",8)_$G(PSOQTLX)_" ISDT: "_$S('$P(PSODATA,"^",9):"     ",1:$E($P(PSODATA,"^",9),4,5)_"-"_$E($P(PSODATA,"^",9),6,7))_$S($G(PSCMOPF):"> ",1:"  ")_"REF: "_$S($L($P(PSODATA,"^",6))>1:"",1:" ")
     129 S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$P(PSODATA,"^",6)
     130 G PENX
     131 ;
     132NVA ; Setting the Non-VA Meds on the Medication Profile Screen (ListMan)
     133 S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)="  "_$P(PSODRG,"^")_" "
     134 I ($L(^TMP("PSOPF",$J,IEN,0))+$L($P(PSODATA,"^",6))>70) S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)="    "
     135 S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$P(PSODATA,"^",6)_" "
     136 I ($L(^TMP("PSOPF",$J,IEN,0))+$L($P(PSODATA,"^",8))>70) S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)="    "
     137 S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$P(PSODATA,"^",8)
     138 I ($L(^TMP("PSOPF",$J,IEN,0))+20)>70 D  Q
     139 . S IEN=IEN+1,$P(^TMP("PSOPF",$J,IEN,0)," ",51)="Date Documented: "_$E($P(PSODATA,"^",9),4,5)_"/"_$E($P(PSODATA,"^",9),6,7)_"/"_$E($P(PSODATA,"^",9),2,3)
     140 F I=0:0 S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_" " Q:$L(^TMP("PSOPF",$J,IEN,0))>49
     141 S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_"Date Documented: "_$E($P(PSODATA,"^",9),4,5)_"/"_$E($P(PSODATA,"^",9),6,7)_"/"_$E($P(PSODATA,"^",9),2,3)
     142 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORUTL.m

    r613 r623  
    1 PSOORUTL        ;ISC BHAM/SAB  - updates order status from oerr ;6/28/07 7:36am
    2         ;;7.0;OUTPATIENT PHARMACY;**14,46,146,132,118,199,223,148,249,274,225**;DEC 1997;Build 29
    3         ;External reference to EN^ORERR - 2187
    4         ;External reference to ^PS(55 - 2228
    5         ;Input variables, poerr("psofilnm")=pharmacy pointer # from OE/RR, poerr("stat")=Order Control status
    6         ;poerr("pharmst")=will contain 'ZE'if rx has expired, poerr("comm")=Comments, poerr("user")=Person placing request
    7 EN(POERR)       ;
    8         N PSZORS,III
    9         F OO=0:0 S OO=$O(MSG(OO)) Q:'OO  I $P(MSG(OO),"|")="ZRN" S NVA=1
    10         I $G(NVA) G NVA
    11         G:POERR("PSOFILNM")'["S" RXO S III=+POERR("PSOFILNM")
    12         S ORS=0 I $D(^PS(52.41,III,0)) D  G PEXIT
    13         .Q:$P($G(^PS(52.41,III,0)),"^",3)="RF"
    14         .I $G(PDFN),$P($G(^PS(52.41,III,0)),"^",2),PDFN'=$P(^PS(52.41,III,0),"^",2) S ORS=1
    15 RXO     S III=POERR("PSOFILNM") I $D(^PSRX(III,0)) D  G PEXIT
    16         .I $G(PDFN),$P($G(^PSRX(III,0)),"^",2),PDFN'=$P(^PSRX(III,0),"^",2) S ORS=1
    17         S (ORS,PSZORS)=1
    18 PEXIT   I $G(ORS) S POERR("STAT")=$S(POERR("STAT")="CA":"UC",POERR("STAT")="DC":"UD",POERR("STAT")="HD":"UH",1:"UR"),POERR("FILLER")="",POERR("COMM")=$S($G(PSZORS):"Invalid Pharmacy order number",1:"Patient does not match.") K ORS,PSZORS,III Q
    19         S POERR("PHARMST")="" G:POERR("STAT")="HD"!(POERR("STAT")="RL") HD
    20         S ORS=0 I POERR("PSOFILNM")["S" S DA=+POERR("PSOFILNM") I $D(^PS(52.41,DA,0)) D  G EXIT
    21         .Q:$P($G(^PS(52.41,DA,0)),"^",3)="RF"
    22         .S $P(^PS(52.41,DA,0),"^",3)="DC",POERR("PLACE")=$P(^(0),"^"),POERR("STAT")="CR",POERR("FILLER")=DA_"^P"
    23         .K ^PS(52.41,"AOR",+$P($G(^PS(52.41,DA,0)),"^",2),+$P($G(^PS(52.41,DA,"INI")),"^"),DA)
    24         .S:$G(POERR("COMM"))']"" POERR("COMM")="Order Canceled by OE/RR before finishing." S ORS=1,$P(^PS(52.41,DA,4),"^")=$G(POERR("COMM"))
    25         S DA=POERR("PSOFILNM") D:$D(^PSRX(DA,0)) REVERSE^PSOBPSU1(DA,,"DC",7)
    26         I $D(^PSRX(DA,0)) D  S $P(^PSRX(DA,"STA"),"^")=14,$P(^PSRX(DA,3),"^",5)=DT,$P(^PSRX(DA,3),"^",10)=$P(^PSRX(DA,3),"^") D CAN^PSOTPCAN(DA) G EXIT
    27         .;cancel/discontinue action
    28         .S POERR("PLACE")=+$P($G(^PSRX(DA,"OR1")),"^",2),POERR("STAT")=$S(POERR("STAT")="CA":"CR",1:"DR"),POERR("FILLER")=DA_"^R"
    29         .S:'$D(POERR("COMM")) POERR("COMM")="Prescription DISCONTINUED by OERR"
    30         .S ORS=1 D CAN
    31 EXIT    I '$G(ORS) D
    32         .S POERR("STAT")=$S(POERR("STAT")="CA":"UC",POERR("STAT")="DC":"UD",POERR("STAT")="HD":"UH",1:"UR"),POERR("FILLER")="",POERR("COMM")="Order was not located by Pharmacy"
    33         K EXP,ORS,DA,ACOM,RXDA,SUSD,PSUS,RXF,I,FDA,DIC,DIE,DR,Y,X,%,%I,%H,RSDT,ACNT,ACT,DIK,FDT,IR,LFD,NOW,ORD,PSDA,PSCDA,PSODFN,PSUS,RF,RFCNT,RXN,RXP,RXREF,SD,SUB
    34         Q
    35 CAN     S ACOM="Discontinued by OE/RR." I $P(^PSRX(DA,"STA"),"^")=3!($P(^("STA"),"^")=16) D
    36         .S ACOM="Discontinued by OE/RR while on hold. " K:$P(^PSRX(DA,"H"),"^") ^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA) S ^PSRX(DA,"H")=""
    37         .I $P(^PSRX(DA,0),"^",13),'$O(^PSRX(DA,1,0)) S DIE=52,DR="22///"_$E($P(^PSRX(DA,0),"^",13),1,7) D ^DIE K DIE,DR Q
    38         .S (IFN,SUSD)=0 F  S IFN=$O(^PSRX(DA,1,IFN)) Q:'IFN  S SUSD=IFN,RFDT=$P(^PSRX(DA,1,IFN,0),"^")
    39         .Q:'$G(SUSD)  I '$P(^PSRX(DA,1,SUSD,0),"^",18) S PSDTEST=0 D  I 'PSDTEST K ^PSRX(DA,1,SUSD),^PSRX("AD",RFDT,DA,SUSD),^PSRX(DA,1,"B",RFDT,SUSD),IFN,SUSD,RFDT
    40         ..F PDA=0:0 S PDA=$O(^PSRX(DA,"L",PDA)) Q:'PDA  I $P($G(^PSRX(DA,"L",PDA,0)),"^",2)=SUSD S PSDTEST=1
    41         ..K CMOP D ^PSOCMOPA I $G(CMOP(CMOP("L")))="",$G(CMOP("S"))'="L" Q
    42         ..S PSDTEST=1
    43         S RXDA=DA,(DA,SUSDA)=$O(^PS(52.5,"B",DA,0)) D:DA
    44         .S SUSD=$P($G(^PS(52.5,DA,0)),"^",2)
    45         .S:+$G(^PS(52.5,DA,"P"))'=1 ACOM="Discontinued by OE/RR while suspended."
    46         .I $O(^PSRX(RXDA,1,0)) S DA=RXDA D:'$G(^PS(52.5,+SUSDA,"P")) REF^PSOCAN2
    47         .S DA=SUSDA,DIK="^PS(52.5," D ^DIK K DIK
    48         K SUSD,SUSDA S DA=RXDA,RXREF=0,PSODFN=+$P(^PSRX(DA,0),"^",2) D
    49         .S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(DA,"A",SUB)) Q:'SUB  S ACNT=SUB
    50         .S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF  S RFCNT=RF S:RF>5 RFCNT=RF+1
    51         .D NOW^%DTC S ^PSRX(DA,"A",0)="^52.3DA^"_(ACNT+1)_"^"_(ACNT+1),^PSRX(DA,"A",ACNT+1,0)=%_"^C^"_POERR("USER")_"^"_RFCNT_"^"_$G(ACOM)
    52         .S REA="C" D EXP^PSOHELP1
    53         I $G(^PS(52.4,DA,0))]"" S PSCDA=DA,DIK="^PS(52.4," D ^DIK S DA=PSCDA K DIK,PSCDA
    54         Q
    55 HD      ;place order on hold
    56         G:POERR("STAT")="RL" REL^PSOORUT1 S (ACT,ORS)=0 I POERR("PSOFILNM")["S" D  G EXIT
    57         .S DA=+POERR("PSOFILNM")
    58         .Q:'$D(^PS(52.41,DA,0))  Q:$P(^PS(52.41,DA,0),"^",3)="RF"
    59         .S $P(^PS(52.41,DA,0),"^",3)="HD",POERR("STAT")="HR",POERR("FILLER")=DA_"^P"
    60         .S:$G(POERR("COMM"))']"" POERR("COMM")="Order PLACED on HOLD by OERR before finished." S $P(^PS(52.41,DA,4),"^")=POERR("COMM"),ORS=1
    61         S DA=POERR("PSOFILNM") I $D(^PSRX(DA,0)) S ORS=1,PSDA=DA D  G EXIT
    62         .S POERR("FILLER")=DA_"^R"
    63         .S:'$D(POERR("COMM")) POERR("COMM")="Prescription Placed on HOLD by OERR"
    64         .I DT>$P(^PSRX(DA,2),"^",6) S EXP=$P(^(2),"^",6) S:$P(^PSRX(DA,"STA"),"^")<12 $P(^PSRX(DA,"STA"),"^")=11,PSOEXFLG=1 S POERR("STAT")="UH",POERR("COMM")="Prescription EXPIRED on "_$E(EXP,4,5)_"/"_$E(EXP,6,7)_"/"_$E(EXP,2,3)_"." D  Q
    65         ..D ECAN^PSOUTL(DA)
    66         .I $P(^PSRX(DA,"STA"),"^")=3!($P(^("STA"),"^")>11) S POERR("STAT")="UH",POERR("COMM")="Unable to place on HOLD" Q
    67         .S $P(^PSRX(DA,"STA"),"^")=16,POERR("STAT")="HR",^PSRX(DA,"H")=99_"^"_POERR("COMM")_"^"_DT
    68         .S (PSUS,RXF)=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S RXF=I S:RXF>1 RSDT=$P(^(RXF-1,0),"^")
    69         .S DA=PSDA D ACT D REVERSE^PSOBPSU1(DA,,"HLD",2)
    70         .S DA=$O(^PS(52.5,"B",PSDA,0)) I DA S DIK="^PS(52.5,",PSUS=1 D ^DIK K DA,DIK
    71         I 'ORS S POERR("COMM")="Unable to place order on HOLD" G EXIT
    72         Q
    73 NVA     ;non-va med action
    74         N DIE,DR,DA K NVA
    75         I POERR("PSOFILNM")'["N"!('$D(^PS(55,PDFN,"NVA",+POERR("PSOFILNM"),0))) D EN^ORERR("Order was not located by Pharmacy",.MSG) Q
    76         I $G(OR("STAT"))'="CA",$G(OR("STAT"))'="DC" D EN^ORERR("Invalid Order Control Code",.MSG) Q
    77 XO      S ORD=+POERR("PSOFILNM")
    78         N TMP
    79         D NOW^%DTC
    80         K TMP S TMP(55.05,ORD_","_PDFN_",",5)=$S($G(PSODEATH):2,1:1)
    81         S TMP(55.05,ORD_","_PDFN_",",6)=%
    82         D FILE^DIE("","TMP")
    83         S PLACER=$P(^PS(55,PDFN,"NVA",ORD,0),"^",8)
    84         K MSG S NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)="""""
    85         K ^UTILITY("DIQ1",$J),DIQ S DA=$P($$SITE^VASITE(),"^")
    86         I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOHINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIQ,DIC
    87         S MSG(1)="MSH|^~\&|PHARMACY|"_$G(PSOHINST)_"|||||ORR"
    88         ;
    89         S DFN=PDFN,COUNT=1,LIMIT=5 X NULLFLDS D DEM^VADPT S NAME=$G(VADM(1)) K VADM
    90         S FIELD(0)="PID",FIELD(3)=DFN,FIELD(5)=NAME
    91         D SEG^PSOHLSN1
    92         ;
    93         S LIMIT=15 X NULLFLDS
    94         S FIELD(0)="ORC",FIELD(2)=PLACER_"^OR",FIELD(3)=+POERR("PSOFILNM")_"N^PS"
    95         S FIELD(1)="SC",FIELD(5)="DC"
    96         D SEG^PSOHLSN1
    97         I $G(PSODEATH) S MSG(COUNT)=MSG(COUNT)_"|^^^^DATE OF DEATH ENTERED BY MAS.^"
    98         ;
    99         D SEND^PSOHLSN1 K FIELDS,LIMIT,PSODSC,PSONVA,OI
    100         Q
    101         ;
    102 ACT     ;activity log
    103         D NOW^%DTC S NOW=%
    104         S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA  S IR=FDA
    105         S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
    106         S RXF=$S(RXF>5:RXF+1,1:RXF)
    107         S ^PSRX(DA,"A",IR,0)=NOW_"^"_$S(ACT:"U",1:"H")_"^"_POERR("USER")_"^"_RXF_"^"_"RX "_$S('ACT:"placed in a",1:"removed from")_" HOLD status "_$S(+$G(PSUS):"and removed from SUSPENSE ",1:"")_"("_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)_") by OERR."
    108         Q
     1PSOORUTL ;ISC BHAM/SAB  - updates order status from oerr ;02/22/95
     2 ;;7.0;OUTPATIENT PHARMACY;**14,46,146,132,118,199,223,148,249**;DEC 1997;Build 9
     3 ;External reference to EN^ORERR - 2187
     4 ;External reference to ^PS(55 - 2228
     5 ;Input variables, poerr("psofilnm")=pharmacy pointer # from OE/RR, poerr("stat")=Order Control status
     6 ;poerr("pharmst")=will contain 'ZE'if rx has expired, poerr("comm")=Comments, poerr("user")=Person placing request
     7EN(POERR) ;
     8 N PSZORS,III
     9 F OO=0:0 S OO=$O(MSG(OO)) Q:'OO  I $P(MSG(OO),"|")="ZRN" S NVA=1
     10 I $G(NVA) G NVA
     11 G:POERR("PSOFILNM")'["S" RXO S III=+POERR("PSOFILNM")
     12 S ORS=0 I $D(^PS(52.41,III,0)) D  G PEXIT
     13 .Q:$P($G(^PS(52.41,III,0)),"^",3)="RF"
     14 .I $G(PDFN),$P($G(^PS(52.41,III,0)),"^",2),PDFN'=$P(^PS(52.41,III,0),"^",2) S ORS=1
     15RXO S III=POERR("PSOFILNM") I $D(^PSRX(III,0)) D  G PEXIT
     16 .I $G(PDFN),$P($G(^PSRX(III,0)),"^",2),PDFN'=$P(^PSRX(III,0),"^",2) S ORS=1
     17 S (ORS,PSZORS)=1
     18PEXIT I $G(ORS) S POERR("STAT")=$S(POERR("STAT")="CA":"UC",POERR("STAT")="DC":"UD",POERR("STAT")="HD":"UH",1:"UR"),POERR("FILLER")="",POERR("COMM")=$S($G(PSZORS):"Unable to locate order.",1:"Patient does not match.") K ORS,PSZORS,III Q
     19 S POERR("PHARMST")="" G:POERR("STAT")="HD"!(POERR("STAT")="RL") HD
     20 S ORS=0 I POERR("PSOFILNM")["S" S DA=+POERR("PSOFILNM") I $D(^PS(52.41,DA,0)) D  G EXIT
     21 .Q:$P($G(^PS(52.41,DA,0)),"^",3)="RF"
     22 .S $P(^PS(52.41,DA,0),"^",3)="DC",POERR("PLACE")=$P(^(0),"^"),POERR("STAT")="CR",POERR("FILLER")=DA_"^P"
     23 .K ^PS(52.41,"AOR",+$P($G(^PS(52.41,DA,0)),"^",2),+$P($G(^PS(52.41,DA,"INI")),"^"),DA)
     24 .S:$G(POERR("COMM"))']"" POERR("COMM")="Order Canceled by OE/RR before finishing." S ORS=1,$P(^PS(52.41,DA,4),"^")=$G(POERR("COMM"))
     25 S DA=POERR("PSOFILNM") D:$D(^PSRX(DA,0)) REVERSE^PSOBPSU1(DA,,"DC",7)
     26 I $D(^PSRX(DA,0)) D  S $P(^PSRX(DA,"STA"),"^")=14,$P(^PSRX(DA,3),"^",5)=DT,$P(^PSRX(DA,3),"^",10)=$P(^PSRX(DA,3),"^") D CAN^PSOTPCAN(DA) G EXIT
     27 .;cancel/discontinue action
     28 .S POERR("PLACE")=+$P($G(^PSRX(DA,"OR1")),"^",2),POERR("STAT")=$S(POERR("STAT")="CA":"CR",1:"DR"),POERR("FILLER")=DA_"^R"
     29 .S:'$D(POERR("COMM")) POERR("COMM")="Prescription DISCONTINUED by OERR"
     30 .S ORS=1 D CAN
     31EXIT I '$G(ORS) D
     32 .S POERR("STAT")=$S(POERR("STAT")="CA":"UC",POERR("STAT")="DC":"UD",POERR("STAT")="HD":"UH",1:"UR"),POERR("FILLER")="",POERR("COMM")="Order was not located by Pharmacy"
     33 K EXP,ORS,DA,ACOM,RXDA,SUSD,PSUS,RXF,I,FDA,DIC,DIE,DR,Y,X,%,%I,%H,RSDT,ACNT,ACT,DIK,FDT,IR,LFD,NOW,ORD,PSDA,PSCDA,PSODFN,PSUS,RF,RFCNT,RXN,RXP,RXREF,SD,SUB
     34 Q
     35CAN S ACOM="Discontinued by OE/RR." I $P(^PSRX(DA,"STA"),"^")=3!($P(^("STA"),"^")=16) D
     36 .S ACOM="Discontinued by OE/RR while on hold. " K:$P(^PSRX(DA,"H"),"^") ^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA) S ^PSRX(DA,"H")=""
     37 .I $P(^PSRX(DA,0),"^",13),'$O(^PSRX(DA,1,0)) S DIE=52,DR="22///"_$E($P(^PSRX(DA,0),"^",13),1,7) D ^DIE K DIE,DR Q
     38 .S (IFN,SUSD)=0 F  S IFN=$O(^PSRX(DA,1,IFN)) Q:'IFN  S SUSD=IFN,RFDT=$P(^PSRX(DA,1,IFN,0),"^")
     39 .Q:'$G(SUSD)  I '$P(^PSRX(DA,1,SUSD,0),"^",18) S PSDTEST=0 D  I 'PSDTEST K ^PSRX(DA,1,SUSD),^PSRX("AD",RFDT,DA,SUSD),^PSRX(DA,1,"B",RFDT,SUSD),IFN,SUSD,RFDT
     40 ..F PDA=0:0 S PDA=$O(^PSRX(DA,"L",PDA)) Q:'PDA  I $P($G(^PSRX(DA,"L",PDA,0)),"^",2)=SUSD S PSDTEST=1
     41 ..K CMOP D ^PSOCMOPA I $G(CMOP(CMOP("L")))="",$G(CMOP("S"))'="L" Q
     42 ..S PSDTEST=1
     43 S RXDA=DA,(DA,SUSDA)=$O(^PS(52.5,"B",DA,0)) D:DA
     44 .S SUSD=$P($G(^PS(52.5,DA,0)),"^",2)
     45 .S:+$G(^PS(52.5,DA,"P"))'=1 ACOM="Discontinued by OE/RR while suspended."
     46 .I $O(^PSRX(RXDA,1,0)) S DA=RXDA D:'$G(^PS(52.5,+SUSDA,"P")) REF^PSOCAN2
     47 .S DA=SUSDA,DIK="^PS(52.5," D ^DIK K DIK
     48 K SUSD,SUSDA S DA=RXDA,RXREF=0,PSODFN=+$P(^PSRX(DA,0),"^",2) D
     49 .S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(DA,"A",SUB)) Q:'SUB  S ACNT=SUB
     50 .S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF  S RFCNT=RF S:RF>5 RFCNT=RF+1
     51 .D NOW^%DTC S ^PSRX(DA,"A",0)="^52.3DA^"_(ACNT+1)_"^"_(ACNT+1),^PSRX(DA,"A",ACNT+1,0)=%_"^C^"_POERR("USER")_"^"_RFCNT_"^"_$G(ACOM)
     52 .S REA="C" D EXP^PSOHELP1
     53 I $G(^PS(52.4,DA,0))]"" S PSCDA=DA,DIK="^PS(52.4," D ^DIK S DA=PSCDA K DIK,PSCDA
     54 Q
     55HD ;place order on hold
     56 G:POERR("STAT")="RL" REL^PSOORUT1 S (ACT,ORS)=0 I POERR("PSOFILNM")["S" D  G EXIT
     57 .S DA=+POERR("PSOFILNM")
     58 .Q:'$D(^PS(52.41,DA,0))  Q:$P(^PS(52.41,DA,0),"^",3)="RF"
     59 .S $P(^PS(52.41,DA,0),"^",3)="HD",POERR("STAT")="HR",POERR("FILLER")=DA_"^P"
     60 .S:$G(POERR("COMM"))']"" POERR("COMM")="Order PLACED on HOLD by OERR before finished." S $P(^PS(52.41,DA,4),"^")=POERR("COMM"),ORS=1
     61 S DA=POERR("PSOFILNM") I $D(^PSRX(DA,0)) S ORS=1,PSDA=DA D  G EXIT
     62 .S POERR("FILLER")=DA_"^R"
     63 .S:'$D(POERR("COMM")) POERR("COMM")="Prescription Placed on HOLD by OERR"
     64 .I DT>$P(^PSRX(DA,2),"^",6) S EXP=$P(^(2),"^",6) S:$P(^PSRX(DA,"STA"),"^")<12 $P(^PSRX(DA,"STA"),"^")=11,PSOEXFLG=1 S POERR("STAT")="UH",POERR("COMM")="Prescription EXPIRED on "_$E(EXP,4,5)_"/"_$E(EXP,6,7)_"/"_$E(EXP,2,3)_"." D  Q
     65 ..D ECAN^PSOUTL(DA)
     66 .I $P(^PSRX(DA,"STA"),"^")=3!($P(^("STA"),"^")>11) S POERR("STAT")="UH",POERR("COMM")="Unable to place on HOLD" Q
     67 .S $P(^PSRX(DA,"STA"),"^")=16,POERR("STAT")="HR",^PSRX(DA,"H")=99_"^"_POERR("COMM")_"^"_DT
     68 .S (PSUS,RXF)=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S RXF=I S:RXF>1 RSDT=$P(^(RXF-1,0),"^")
     69 .S DA=PSDA D ACT D REVERSE^PSOBPSU1(DA,,"HLD",2)
     70 .S DA=$O(^PS(52.5,"B",PSDA,0)) I DA S DIK="^PS(52.5,",PSUS=1 D ^DIK K DA,DIK
     71 I 'ORS S POERR("COMM")="Unable to place order on HOLD" G EXIT
     72 Q
     73NVA ;non-va med action
     74 N DIE,DR,DA K NVA
     75 I POERR("PSOFILNM")'["N"!('$D(^PS(55,PDFN,"NVA",+POERR("PSOFILNM"),0))) D EN^ORERR("Order was not located by Pharmacy",.MSG) Q
     76 I $G(OR("STAT"))'="CA",$G(OR("STAT"))'="DC" D EN^ORERR("Invalid Order Control Code",.MSG) Q
     77XO S ORD=+POERR("PSOFILNM")
     78 N TMP
     79 D NOW^%DTC
     80 K TMP S TMP(55.05,ORD_","_PDFN_",",5)=$S($G(PSODEATH):2,1:1)
     81 S TMP(55.05,ORD_","_PDFN_",",6)=%
     82 D FILE^DIE("","TMP")
     83 S PLACER=$P(^PS(55,PDFN,"NVA",ORD,0),"^",8)
     84 K MSG S NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)="""""
     85 K ^UTILITY("DIQ1",$J),DIQ S DA=$P($$SITE^VASITE(),"^")
     86 I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOHINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIQ,DIC
     87 S MSG(1)="MSH|^~\&|PHARMACY|"_$G(PSOHINST)_"|||||ORR"
     88 ;
     89 S DFN=PDFN,COUNT=1,LIMIT=5 X NULLFLDS D DEM^VADPT S NAME=$G(VADM(1)) K VADM
     90 S FIELD(0)="PID",FIELD(3)=DFN,FIELD(5)=NAME
     91 D SEG^PSOHLSN1
     92 ;
     93 S LIMIT=15 X NULLFLDS
     94 S FIELD(0)="ORC",FIELD(2)=PLACER_"^OR",FIELD(3)=+POERR("PSOFILNM")_"N^PS"
     95 S FIELD(1)="SC",FIELD(5)="DC"
     96 D SEG^PSOHLSN1
     97 I $G(PSODEATH) S MSG(COUNT)=MSG(COUNT)_"|^^^^DATE OF DEATH ENTERED BY MAS.^"
     98 ;
     99 D SEND^PSOHLSN1 K FIELDS,LIMIT,PSODSC,PSONVA,OI
     100 Q
     101 ;
     102ACT ;activity log
     103 D NOW^%DTC S NOW=%
     104 S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA  S IR=FDA
     105 S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
     106 S ^PSRX(DA,"A",IR,0)=NOW_"^"_$S(ACT:"U",1:"H")_"^"_POERR("USER")_"^"_RXF_"^"_"RX "_$S('ACT:"placed in a",1:"removed from")_" HOLD status "_$S(+$G(PSUS):"and removed from SUSPENSE ",1:"")_"("_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)_") by OERR."
     107 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPFSU0.m

    r613 r623  
    1 PSOPFSU0        ;BIR/LE,AM - PFSS Get Account & Utilities ;08/09/93
    2         ;;7.0;OUTPATIENT PHARMACY;**201,225**;DEC 1997;Build 29
    3         ;External reference SWSTAT^IBBAPI supported by DBIA 4663
    4         ;External reference GETACCT^IBBAPI supported by DBIA 4664
    5         ;External reference ^DG(40.8,"AD" supported by DBIA 2817
    6         Q
    7         ;
    8 GACT(PSORXN,PSOREF)     ;ENTRY POINT: Called from PSON52; PSOR52, PSORN52.  Get a PFSS acct ref
    9         ; This routine is only called when the PFSS Switch is on.   
    10         ;
    11         N I,J,PSOPFSAC,PSOPV1,PSODG,PSOZCL,PSODFN,PSORX,PSOPV2,PSODIV
    12         ;for sending to an external billing system, get data from file 52, build arrays for IBB API call
    13         I PSOREF=0 D GACTOF
    14         I PSOREF>0 D GACTRF
    15         ;Get general Rx data fields
    16         S PSODIV=$$MCDIV(PSORXN,PSOREF)
    17         S PSODFN=$$GET1^DIQ(52,PSORXN,"2","I")
    18         S PSOPV1(2)="O",PSOPV1(50)=PSORXN
    19         S PSOPV1(3)=$$CHLOC()
    20         Q:PSOPV1(3)="" 0  ;can't do GETACCT if CHARGE LOCATION is null; this is to be address in subsequent PFSS project phase
    21         ;request the PFSS Acct Rev
    22         S PSOPFSAC=$$GETACCT^IBBAPI(PSODFN,"","A04","GACT;PSOPFSU0",.PSOPV1,"","",.PSODG,.PSOZCL,PSODIV,"")
    23         ;Store the PFS Acct Ref with speed in mind
    24         Q:PSOPFSAC<1 ""
    25         I PSOREF=0 S $P(^PSRX(PSORXN,"PFS"),"^")=PSOPFSAC
    26         I PSOREF>0 S $P(^PSRX(PSORXN,1,PSOREF,"PFS"),"^")=PSOPFSAC
    27         Q PSOPFSAC
    28         ;
    29 GACTOF  ;Get orig fill data
    30         D GETS^DIQ(52,PSORXN,"4;22","I","PSORX")
    31         S PSOPV1(7)=$G(PSORX(52,PSORXN_",",4,"I")),PSOPV1(44)=$G(PSORX(52,PSORXN_",",22,"I"))
    32         D GOC
    33         Q
    34         ;
    35 GACTRF  ;Called from GACT. Get refill data
    36         D GETS^DIQ(52.1,PSOREF_","_PSORXN,".01;15","I","PSORX")
    37         S PSOPV1(7)=$G(PSORX(52.1,PSOREF_","_PSORXN_",","15","I"))
    38         S PSOPV1(44)=$G(PSORX(52.1,PSOREF_","_PSORXN_",",".01","I"))
    39         D GOC
    40         Q
    41         ;
    42 CHLOC() ;FIND CHARGE LOCATION
    43         N CHLOC,CL,PDIV
    44         I PSOREF=0 S PDIV=$$GET1^DIQ(52,PSORXN,"20","I")   ;DIVISION
    45         I PSOREF>0 S PDIV=$$GET1^DIQ(52.1,PSOREF_","_PSORXN_",","8","I")
    46         S CHLOC=$$GET1^DIQ(59,PDIV,1007,"I") ;Charge location pointer
    47         I CHLOC="" S CL="" D CLOK S:CL>0 CHLOC=CL
    48         Q CHLOC
    49         ;
    50 GOC     ;Called from GACTOF and GACTRF.  Parse OP classifications and ICD's.  Don't send null values.
    51         D GETS^DIQ(52,PSORXN,"52311*","I","PSORX")
    52         F I=1:1 Q:'$D(PSORX(52.052311,I_","_PSORXN_","))  D
    53         . S:PSORX(52.052311,I_","_PSORXN_",",".01","I")'="" PSODG(I,3)=PSORX(52.052311,I_","_PSORXN_",",".01","I"),PSODG(I,6)="W"
    54         . I I=1 F J=1:1:8 Q:'$D(PSORX(52.052311,I_","_PSORXN_",",J,"I"))  D
    55         . . S:PSORX(52.052311,I_","_PSORXN_",",J,"I")'="" PSOZCL(J,2)=J,PSOZCL(J,3)=PSORX(52.052311,I_","_PSORXN_",",J,"I")
    56         S:'$D(PSOZCL) PSOZCL="" S:'$D(PSODG) PSODG=""
    57         Q
    58         ;
    59 RPH(PSORXN,PSOREF)      ;API entry point
    60         ;       Inputs:  PSORXN = prescription IEN, PSOREF = fill number
    61         ;       Outputs: PSORPH = rel pharm IEN ^ user IEN who performed last activity or rel pharm iF no activity entries^
    62         ;                   IB Service Section pointer from file 59
    63         ;       Returns null values when the Rx is not released or the input values are invalid (i.e. "^^").
    64         N I,II,IBSS,DIV,PSORPH,PSOEDPH,PSOA,PSORDT,PSOOK,PSOA,DATA
    65         S PSOOK=$$CHKRX(PSORXN,PSOREF) Q:PSOOK'=1 "^^"
    66         I 'PSOREF D GETS^DIQ(52,PSORXN,"20;23;31","I","DATA")
    67         E  D GETS^DIQ(52.1,PSOREF_","_PSORXN,"4;8;17","I","DATA")
    68         I PSOREF=0 D
    69         . S PSORPH=+$G(DATA(52,PSORXN_",",23,"I")) S:PSORPH=0 PSORPH=""
    70         . S DIV=+$G(DATA(52,PSORXN_",",20,"I"))
    71         . S PSORDT=+$G(DATA(52,PSORXN_",",31,"I"))
    72         I PSOREF>0 D
    73         . S PSORPH=+$G(DATA(52.1,PSOREF_","_PSORXN_",",4,"I")) S:PSORPH=0 PSORPH=""
    74         . S DIV=+$G(DATA(52.1,PSOREF_","_PSORXN_",",8,"I"))
    75         . S PSORDT=+$G(DATA(52.1,PSOREF_","_PSORXN_",",17,"I"))
    76         Q:PSORDT=0 "^^"
    77         ;last activity - get last one with a user
    78         I $D(^PSRX(PSORXN,"A",0)) S PSOA=$P(^PSRX(PSORXN,"A",0),"^",3) D
    79         . F II=PSOA:-1:1 S PSOEDPH=$$GET1^DIQ(52.3,II_","_PSORXN_",",".03","I") Q:PSOEDPH'=""
    80         ;get IB Service Section (requested by Ed Z. on 6/29/05)
    81         S IBSS=$P($G(^PS(59,DIV,"IB")),"^")
    82         S:'$G(PSOEDPH) PSOEDPH=PSORPH
    83         S PSORPH=$G(PSORPH)_"^"_$G(PSOEDPH)_"^"_$G(IBSS)
    84         Q PSORPH
    85         ;
    86 CHKRX(PSORX,PSOF)       ;validates Rx & fill. 0=not valid, 1=valid, 2=refill not valid
    87         Q:PSORX=""!(PSOF="") 0
    88         Q:'$D(^PSRX(PSORX)) 0
    89         Q:PSOF>0&('$D(^PSRX(PSORX,1,PSOF))) 2
    90         Q 1
    91         ;
    92 MCDIV(RX,FILL)  ;Get MC DIVISION from the Rx/Fill
    93         N DIV,INST
    94         ; outpatient division
    95         I 'FILL S DIV=$$GET1^DIQ(52,RX,20,"I")
    96         E  S DIV=$$GET1^DIQ(52.1,FILL_","_RX,8,"I")
    97         Q:'DIV ""
    98         ; related institution
    99         S INST=$$GET1^DIQ(59,DIV,100,"I") Q:'INST ""
    100         S DIV=$O(^DG(40.8,"AD",INST,0)) ; pointer to medical center division
    101         Q DIV
    102         ;
    103 CLOK    ;
    104         N I S I=0 F  S I=$O(^PS(59,I)) Q:'I!(CL>0)  D
    105         . I $S('$D(^PS(59,I,"I")):1,'+$P(^("I"),"^"):1,DT'>+$P(^("I"),"^"):1,1:0) S CL=$P($G(^PS(59,I,"PFS")),"^")
    106         Q
    107         ;
     1PSOPFSU0 ;BIR/LE,AM - PFSS Get Account & Utilities ;08/09/93
     2 ;;7.0;OUTPATIENT PHARMACY;**201**;DEC 1997
     3 ;External reference SWSTAT^IBBAPI supported by DBIA 4663
     4 ;External reference GETACCT^IBBAPI supported by DBIA 4664
     5 ;External reference ^DG(40.8,"AD" supported by DBIA 2817
     6 Q
     7 ;
     8GACT(PSORXN,PSOREF) ;ENTRY POINT: Called from PSON52; PSOR52, PSORN52.  Get a PFSS acct ref
     9 ; This routine is only called when the PFSS Switch is on.   
     10 ;
     11 N I,J,PSOPFSAC,PSOPV1,PSODG,PSOZCL,PSODFN,PSORX,PSOPV2,PSODIV
     12 ;for sending to an external billing system, get data from file 52, build arrays for IBB API call
     13 I PSOREF=0 D GACTOF
     14 I PSOREF>0 D GACTRF
     15 ;Get general Rx data fields
     16 S PSODIV=$$MCDIV(PSORXN,PSOREF)
     17 S PSODFN=$$GET1^DIQ(52,PSORXN,"2","I")
     18 S PSOPV1(2)="O",PSOPV1(50)=PSORXN
     19 S PSOPV1(3)=$$CHLOC()
     20 Q:PSOPV1(3)="" 0  ;can't do GETACCT if CHARGE LOCATION is null; this is to be address in subsequent PFSS project phase
     21 ;request the PFSS Acct Rev
     22 S PSOPFSAC=$$GETACCT^IBBAPI(PSODFN,"","A04","GACT;PSOPFSU0",.PSOPV1,"","",.PSODG,.PSOZCL,PSODIV,"")
     23 ;Store the PFS Acct Ref with speed in mind
     24 Q:PSOPFSAC<1 ""
     25 I PSOREF=0 S $P(^PSRX(PSORXN,"PFS"),"^")=PSOPFSAC
     26 I PSOREF>0 S $P(^PSRX(PSORXN,1,PSOREF,"PFS"),"^")=PSOPFSAC
     27 Q PSOPFSAC
     28 ;
     29GACTOF ;Get orig fill data
     30 D GETS^DIQ(52,PSORXN,"4;22","I","PSORX")
     31 S PSOPV1(7)=$G(PSORX(52,PSORXN_",",4,"I")),PSOPV1(44)=$G(PSORX(52,PSORXN_",",22,"I"))
     32 D GOC
     33 Q
     34 ;
     35GACTRF ;Called from GACT. Get refill data
     36 D GETS^DIQ(52.1,PSOREF_","_PSORXN,".01;15","I","PSORX")
     37 S PSOPV1(7)=$G(PSORX(52.1,PSOREF_","_PSORXN_",","15","I"))
     38 S PSOPV1(44)=$G(PSORX(52.1,PSOREF_","_PSORXN_",",".01","I"))
     39 D GOC
     40 Q
     41 ;
     42CHLOC() ;FIND CHARGE LOCATION
     43 N CHLOC,CL,PDIV
     44 I PSOREF=0 S PDIV=$$GET1^DIQ(52,PSORXN,"20","I")   ;DIVISION
     45 I PSOREF>0 S PDIV=$$GET1^DIQ(52.1,PSOREF_","_PSORXN_",","8","I")
     46 S CHLOC=$$GET1^DIQ(59,PDIV,1007,"I") ;Charge location pointer
     47 I CHLOC="" S CL="" D CLOK S:CL>0 CHLOC=CL
     48 Q CHLOC
     49 ;
     50GOC ;Called from GACTOF and GACTRF.  Parse OP classifications and ICD's.  Don't send null values.
     51 D GETS^DIQ(52,PSORXN,"52311*","I","PSORX")
     52 F I=1:1 Q:'$D(PSORX(52.052311,I_","_PSORXN_","))  D
     53 . S:PSORX(52.052311,I_","_PSORXN_",",".01","I")'="" PSODG(I,3)=PSORX(52.052311,I_","_PSORXN_",",".01","I"),PSODG(I,6)="W"
     54 . I I=1 F J=1:1:7 Q:'$D(PSORX(52.052311,I_","_PSORXN_",",J,"I"))  D
     55 . . S:PSORX(52.052311,I_","_PSORXN_",",J,"I")'="" PSOZCL(J,2)=J,PSOZCL(J,3)=PSORX(52.052311,I_","_PSORXN_",",J,"I")
     56 S:'$D(PSOZCL) PSOZCL="" S:'$D(PSODG) PSODG=""
     57 Q
     58 ;
     59RPH(PSORXN,PSOREF) ;API entry point
     60 ;       Inputs:  PSORXN = prescription IEN, PSOREF = fill number
     61 ;       Outputs: PSORPH = rel pharm IEN ^ user IEN who performed last activity or rel pharm iF no activity entries^
     62 ;                   IB Service Section pointer from file 59
     63 ;       Returns null values when the Rx is not released or the input values are invalid (i.e. "^^").
     64 N I,II,IBSS,DIV,PSORPH,PSOEDPH,PSOA,PSORDT,PSOOK,PSOA,DATA
     65 S PSOOK=$$CHKRX(PSORXN,PSOREF) Q:PSOOK'=1 "^^"
     66 I 'PSOREF D GETS^DIQ(52,PSORXN,"20;23;31","I","DATA")
     67 E  D GETS^DIQ(52.1,PSOREF_","_PSORXN,"4;8;17","I","DATA")
     68 I PSOREF=0 D
     69 . S PSORPH=+$G(DATA(52,PSORXN_",",23,"I")) S:PSORPH=0 PSORPH=""
     70 . S DIV=+$G(DATA(52,PSORXN_",",20,"I"))
     71 . S PSORDT=+$G(DATA(52,PSORXN_",",31,"I"))
     72 I PSOREF>0 D
     73 . S PSORPH=+$G(DATA(52.1,PSOREF_","_PSORXN_",",4,"I")) S:PSORPH=0 PSORPH=""
     74 . S DIV=+$G(DATA(52.1,PSOREF_","_PSORXN_",",8,"I"))
     75 . S PSORDT=+$G(DATA(52.1,PSOREF_","_PSORXN_",",17,"I"))
     76 Q:PSORDT=0 "^^"
     77 ;last activity - get last one with a user
     78 I $D(^PSRX(PSORXN,"A",0)) S PSOA=$P(^PSRX(PSORXN,"A",0),"^",3) D
     79 . F II=PSOA:-1:1 S PSOEDPH=$$GET1^DIQ(52.3,II_","_PSORXN_",",".03","I") Q:PSOEDPH'=""
     80 ;get IB Service Section (requested by Ed Z. on 6/29/05)
     81 S IBSS=$P($G(^PS(59,DIV,"IB")),"^")
     82 S:'$G(PSOEDPH) PSOEDPH=PSORPH
     83 S PSORPH=$G(PSORPH)_"^"_$G(PSOEDPH)_"^"_$G(IBSS)
     84 Q PSORPH
     85 ;
     86CHKRX(PSORX,PSOF) ;validates Rx & fill. 0=not valid, 1=valid, 2=refill not valid
     87 Q:PSORX=""!(PSOF="") 0
     88 Q:'$D(^PSRX(PSORX)) 0
     89 Q:PSOF>0&('$D(^PSRX(PSORX,1,PSOF))) 2
     90 Q 1
     91 ;
     92MCDIV(RX,FILL) ;Get MC DIVISION from the Rx/Fill
     93 N DIV,INST
     94 ; outpatient division
     95 I 'FILL S DIV=$$GET1^DIQ(52,RX,20,"I")
     96 E  S DIV=$$GET1^DIQ(52.1,FILL_","_RX,8,"I")
     97 Q:'DIV ""
     98 ; related institution
     99 S INST=$$GET1^DIQ(59,DIV,100,"I") Q:'INST ""
     100 S DIV=$O(^DG(40.8,"AD",INST,0)) ; pointer to medical center division
     101 Q DIV
     102 ;
     103CLOK ;
     104 N I S I=0 F  S I=$O(^PS(59,I)) Q:'I!(CL>0)  D
     105 . I $S('$D(^PS(59,I,"I")):1,'+$P(^("I"),"^"):1,DT'>+$P(^("I"),"^"):1,1:0) S CL=$P($G(^PS(59,I,"PFS")),"^")
     106 Q
     107 ;

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPFSU1.m

    r613 r623  
    1 PSOPFSU1        ;BIR/LE,AM - PFSS Charge Message & Utilities ;08/09/93
    2         ;;7.0;OUTPATIENT PHARMACY;**201,225**;DEC 1997;Build 29
    3         ;External reference CHARGE^IBBAPI and GETCHGID^IBBAPI supported by DBIA 4665
    4         Q
    5         ;
    6 CHRG(PSORXN,PSOREF,PSOCHTYP,PSOPFS)     ;ENTRY POINT: 
    7         ;Used to pass charge msg info to an external billing system via IBB API's   
    8         ;       Inputs:  PSORXN = RX IEN, PSOREF = fill number, PSOCHTYP = "CG" for Charge or "CD" for Credit transaction,
    9         ;                PSOPFS = switch status (0 or 1) ^ PFSS Account Reference for the fill ^ PFSS Charge ID for the fill
    10         ;       Outputs:  none
    11         ;       
    12         N I,CLDIV,IFN,J,PSODG,PSOZCL,PSOCHID,PSOPFSA,PSODFN,PSORX,PSOFT1,PSODRG,PSODRUG,PSORXE,PSOCHG,PSOFD,PSOFT,PSOFLD
    13         ; quit if PFSS switch is off or not defined
    14         Q:'+$G(PSOPFS)
    15         ;
    16         ; check for CHARGE LOCATION before processing charge message.
    17         S CLDIV=$$CHLOC^PSOPFSU0()
    18         Q:CLDIV<1  ;if no CHARGE LOCATION, don't send charge message to either IB or external billing system.
    19         ;
    20         ; check for PFSS Acct Reference; if not one define, request one
    21         S PSOPFSA=$P(PSOPFS,"^",2)
    22         I PSOPFSA<1 D PFSI(PSORXN,PSOREF) S PSOPFSA=$P(PSOPFS,"^",2) I PSOPFSA<1 D  ;because PSOCP is too large, need to check for/get them here
    23         .S PSOPFSA=$$GACT^PSOPFSU0(PSORXN,PSOREF)
    24         Q:PSOPFSA<1  ;Normally IB returns an acct ref or zero for unsuccessful if a problem is encountered. 
    25         ; If IBB didn't return a value, don't send charge message because IBB will produce a hard error.  Subsequent phase of PFSS will provide further error handling.
    26         ;
    27         ; check for PFSS Charge ID. If no charge ID, means Rx never sent to external bill sys or there was a problem retrieve one.
    28         S PSOCHID=$P(PSOPFS,"^",3)
    29         ;If no Charge ID is  defined, request a Unique Charge ID and store it in file 52
    30         I PSOCHID<1 S PSOCHID=$$GETCHGID^IBBAPI() I PSOCHID>0 D
    31         . I PSOREF=0 S $P(^PSRX(PSORXN,"PFS"),"^",2)=PSOCHID  ;set directly for speed (CMOPs, etc.)
    32         . I PSOREF>0 S $P(^PSRX(PSORXN,1,PSOREF,"PFS"),"^",2)=PSOCHID
    33         Q:PSOCHID<1  ;no charge message will be sent if can't get a PFSS CHARGE ID from IB.  Subsequent phase of PFSS will provide error handling for this type problem.
    34         ;Retrieve all fields to pass for the charge message
    35         S PSOFT="4,10,21" I PSOREF=0 D CHRGOF
    36         I PSOREF>0 D CHRGRF
    37         ;Get general Rx data fields
    38         D GETS^DIQ(52,PSORXN,"2;3;6;105","I","PSORX")
    39         S PSOFT1(29)=$$NDC^PSOHDR(PSORXN,PSOREF,$S(PSOREF>0:"R",1:""))
    40         S PSODFN=$G(PSORX(52,PSORXN_",",2,"I")),PSODRG=$G(PSORX(52,PSORXN_",",6,"I")),PSOFT1(31)=$G(PSORX(52,PSORXN_",",105,"I"))
    41         D DATA^PSS50(PSODRG,,,,,"PSOSC")
    42         ;S PSOFT1(2)="PSO"_PSORXN_"F"_PSOREF  ;12/6/05; DECISION MADE TO NOT SEND clinicial event indicator FOR OP
    43         S PSOFT1(7)=$G(^TMP($J,"PSOSC",PSODRG,400)),PSOFT1(6)=PSOCHTYP,PSOFT1(13)=160
    44         S PSOFT1(18)=$G(PSORX(52,PSORXN_",",3,"I")),PSOFT1(18)=$$GET1^DIQ(53,PSOFT1(18)_",",15,"I")
    45         S PSOFT1(22)=$FN($G(^TMP($J,"PSOSC",PSODRG,16)),"",2),PSOFT1(29)=PSOFT1(29)_";"_$G(^TMP($J,"PSOSC",PSODRG,.01))
    46         S PSORXE(31)=$G(^TMP($J,"PSOSC",PSODRG,3)),PSORXE(17)=PSOREF
    47         S:(PSORXE(18)="") PSORXE(18)=$G(RELDT)  ;CMOP
    48         S PSORXE(15)=PSORXN
    49         S PSOCHG=$$CHARGE^IBBAPI(PSODFN,PSOPFSA,PSOCHTYP,PSOCHID,.PSOFT1,"",.PSODG,.PSOZCL,.PSORXE,"","")
    50         ;errors to be handled in subsequent phase
    51         K ^TMP($J,"PSOSC")
    52         Q
    53         ;
    54 CHRGOF  ;Retrieve charge fields for orig fills
    55         D GETS^DIQ(52,PSORXN,"4;7;8;22;31;125","I","PSORX")
    56         S PSOFD="22,7,4"
    57         F I=1:1 S PSOFLD=$P(PSOFD,",",I) Q:PSOFLD=""  S PSOFT1($P(PSOFT,",",I))=$G(PSORX(52,PSORXN_",",$P(PSOFD,",",I),"I"))
    58         S PSOPFSA=$G(PSORX(52,PSORXN_",",125,"I")),PSORXE(18)=$G(PSORX(52,PSORXN_",",31,"I"))
    59         S PSORXE(1)=PSOFT1(10)_";;"_$G(PSORX(52,PSORXN_",",8,"I"))
    60         D GOC
    61         Q
    62         ;
    63 CHRGRF  ;Retrieve charge fields for refills
    64         D GETS^DIQ(52.1,PSOREF_","_PSORXN,".01;1;1.1;15;17;21","I","PSORX")
    65         S PSOFD=".01,1,15"
    66         F I=1:1 S PSOFLD=$P(PSOFD,",",I) Q:PSOFLD=""  S PSOFT1($P(PSOFT,",",I))=$G(PSORX(52.1,PSOREF_","_PSORXN_",",$P(PSOFD,",",I),"I"))
    67         S PSOPFSA=$G(PSORX(52.1,PSOREF_","_PSORXN_",",21,"I")),PSORXE(18)=$G(PSORX(52.1,PSOREF_","_PSORXN_",",17,"I"))
    68         S PSORXE(1)=PSOFT1(10)_";;"_$G(PSORX(52.1,PSOREF_","_PSORXN_",",1.1,"I"))
    69         D GOC
    70         Q
    71         ;
    72 GOC     ;Called from CHRGOF, CHRGRF.  Parse OP classifications and ICD's.  Don't send null values.
    73         D GETS^DIQ(52,PSORXN,"52311*","I","PSORX")
    74         F I=1:1 Q:'$D(PSORX(52.052311,I_","_PSORXN_","))  D
    75         . S:PSORX(52.052311,I_","_PSORXN_",",".01","I")'="" PSODG(I,3)=PSORX(52.052311,I_","_PSORXN_",",".01","I"),PSODG(I,6)="F"
    76         . I I=1 F J=1:1:8 Q:'$D(PSORX(52.052311,I_","_PSORXN_",",J,"I"))  D
    77         . . S:PSORX(52.052311,I_","_PSORXN_",",J,"I")'="" PSOZCL(J,2)=J,PSOZCL(J,3)=PSORX(52.052311,I_","_PSORXN_",",J,"I")
    78         S:'$D(PSOZCL) PSOZCL="" S:'$D(PSODG) PSODG=""
    79         Q
    80         ;
    81 CG      ;Called from PSOCPB; for the last fill, send chrg message if released; PSOCPB too large for more code.
    82         ; this is used for SC/EI changes when no charges are cancelled.  Expects to have PSODA = RXIEN and PSOLFIL= fill#
    83         ;N REL,PFS
    84         ;I 'PSOLFIL S REL=$$GET1^DIQ(52,PSODA_",","31","I")
    85         ;I PSOLFIL>0 S REL=$$GET1^DIQ(52.1,PSOLFIL_","_PSODA_",","17","I")  ;REFILL
    86         ;I REL'=""&(PSOPFS)&(+$G(PSOPFSA)) D CHRG(PSODA,PSOLFIL,"CG",PSOPFS)
    87         Q
    88         ;
    89 LF(PSODA)       ;return last fill number;CALLED from PSOCPB
    90         N LF
    91         I $D(^PSRX(PSODA,1,0)) S LF="A",LF=$O(^PSRX(PSODA,1,LF),-1) Q LF
    92         Q 0  ;ORIG FILL
    93         ;
    94 PFSI(PSODA,PSOREF)      ;get PFSS Acct Ref and Charge ID and store in PSOPFS; Called from multiple places in this routine
    95         I PSOREF=0&($D(^PSRX(PSODA,"PFS"))) S PSOPFS=PSOPFS_"^"_$P(^PSRX(PSODA,"PFS"),"^",1,2) Q
    96         I PSOREF>0&($D(^PSRX(PSODA,1,PSOREF,"PFS"))) S PSOPFS=PSOPFS_"^"_$P(^PSRX(PSODA,1,PSOREF,"PFS"),"^",1,2)
    97         Q
    98         ;
    99 PFSA(PSODA,PSOREF,WR)   ;called from PSOCP (WR=2) and PSOCPB (WR=3)
    100         ;get switch status, acct ref, and charge ID, then validate switch vs availability of PFSS acct ref
    101         Q:'$G(WR)
    102         S PSOPFS=+$$SWSTAT^IBBAPI()
    103         D PFSI(PSODA,PSOREF)
    104         ; if switch is off, but have an PFSS Acct Ref for new orders, send charge to IDX
    105         ; if switch is off, but have a Charge ID, send cancel charge to IDX
    106         I '+PSOPFS,$P(PSOPFS,"^",WR)>0 S $P(PSOPFS,"^")=1
    107         Q
    108         ;
    109 PFS     ;;Called from PSOCPB; PSOCPB is too large to hold more code.  Processes copay cancels for PFS only.
    110         ;find any fills being cancelled for PFSS, cancel them, and remove them from PSOCAN, then return to PSOCP to process any IB cancels
    111         ;
    112         N X,I,PSOREF,PSOOLD,PREA,PSONW
    113         ;If it's a PFS fill, if released, and not previously cancelled, set the X array, then kill it out of PSOCAN array.
    114         ;Killed out of PSOCAN because don't want the IB processing to look at PFSS billed fills.
    115         ;Note that in PSOCPD, PFS entries are not stored in PSOCAN array if a charge ID is not defined.  So, don't have to check for release date.
    116         ;If prev cancelled and PFS, kill it from PSOCAN array
    117         S I="" F  S I=$O(PSOCAN(I)) Q:I=""  S PSOREF=+PSOCAN(I) D
    118         . I PSOREF=PSODA&($P(PSOCAN(I),"^",10)="PFS") D  Q
    119         . . I $P(PSOCAN(I),"^",5)["CANCEL" K PSOCAN(I) Q
    120         . . S X(0)=$P(PSOCAN(I),"^",2)_"^"_PSORSN K PSOCAN(I)
    121         . I PSOREF'=PSODA&($P(PSOCAN(I),"^",10)="PFS") D
    122         . . I $P(PSOCAN(I),"^",5)["CANCEL" K PSOCAN(I) Q
    123         . . S X(PSOREF)=$P(PSOCAN(I),"^",2)_"^"_PSORSN K PSOCAN(I)
    124         I $G(CANTYPE)&('$D(X)) D MSGNOCAN^PSOCPB Q  ;CANTYPE=1 means trying cancelling all fills;can't cancel twice
    125         ;
    126         ;send charge messages, set activity log, display message
    127         S PREA="C",PSOREF=""
    128         F  S PSOREF=$O(X(PSOREF)) Q:PSOREF=""  S PSOPFS=1 D PFSI(PSODA,PSOREF) D CHRG(PSODA,PSOREF,"CD",PSOPFS) D ACTLOG^PSOCPA D:'$G(CANTYPE) MSG^PSOCPB
    129         I $G(CANTYPE)&('$D(PSOCAN)) D MSG^PSOCPB  ;if cancelling all and no legacy IB bills to cancel, write msg
    130         S PSOPFSA=0  ;reset variable so charge isn't sent twice if SC/EI's were also changed.
    131         Q
    132         ;
     1PSOPFSU1 ;BIR/LE,AM - PFSS Charge Message & Utilities ;08/09/93
     2 ;;7.0;OUTPATIENT PHARMACY;**201**;DEC 1997
     3 ;External reference CHARGE^IBBAPI and GETCHGID^IBBAPI supported by DBIA 4665
     4 Q
     5 ;
     6CHRG(PSORXN,PSOREF,PSOCHTYP,PSOPFS) ;ENTRY POINT: 
     7 ;Used to pass charge msg info to an external billing system via IBB API's   
     8 ;       Inputs:  PSORXN = RX IEN, PSOREF = fill number, PSOCHTYP = "CG" for Charge or "CD" for Credit transaction,
     9 ;                PSOPFS = switch status (0 or 1) ^ PFSS Account Reference for the fill ^ PFSS Charge ID for the fill
     10 ;       Outputs:  none
     11 ;       
     12 N I,CLDIV,IFN,J,PSODG,PSOZCL,PSOCHID,PSOPFSA,PSODFN,PSORX,PSOFT1,PSODRG,PSODRUG,PSORXE,PSOCHG,PSOFD,PSOFT,PSOFLD
     13 ; quit if PFSS switch is off or not defined
     14 Q:'+$G(PSOPFS)
     15 ;
     16 ; check for CHARGE LOCATION before processing charge message.
     17 S CLDIV=$$CHLOC^PSOPFSU0()
     18 Q:CLDIV<1  ;if no CHARGE LOCATION, don't send charge message to either IB or external billing system.
     19 ;
     20 ; check for PFSS Acct Reference; if not one define, request one
     21 S PSOPFSA=$P(PSOPFS,"^",2)
     22 I PSOPFSA<1 D PFSI(PSORXN,PSOREF) S PSOPFSA=$P(PSOPFS,"^",2) I PSOPFSA<1 D  ;because PSOCP is too large, need to check for/get them here
     23 .S PSOPFSA=$$GACT^PSOPFSU0(PSORXN,PSOREF)
     24 Q:PSOPFSA<1  ;Normally IB returns an acct ref or zero for unsuccessful if a problem is encountered. 
     25 ; If IBB didn't return a value, don't send charge message because IBB will produce a hard error.  Subsequent phase of PFSS will provide further error handling.
     26 ;
     27 ; check for PFSS Charge ID. If no charge ID, means Rx never sent to external bill sys or there was a problem retrieve one.
     28 S PSOCHID=$P(PSOPFS,"^",3)
     29 ;If no Charge ID is  defined, request a Unique Charge ID and store it in file 52
     30 I PSOCHID<1 S PSOCHID=$$GETCHGID^IBBAPI() I PSOCHID>0 D
     31 . I PSOREF=0 S $P(^PSRX(PSORXN,"PFS"),"^",2)=PSOCHID  ;set directly for speed (CMOPs, etc.)
     32 . I PSOREF>0 S $P(^PSRX(PSORXN,1,PSOREF,"PFS"),"^",2)=PSOCHID
     33 Q:PSOCHID<1  ;no charge message will be sent if can't get a PFSS CHARGE ID from IB.  Subsequent phase of PFSS will provide error handling for this type problem.
     34 ;Retrieve all fields to pass for the charge message
     35 S PSOFT="4,10,21" I PSOREF=0 D CHRGOF
     36 I PSOREF>0 D CHRGRF
     37 ;Get general Rx data fields
     38 D GETS^DIQ(52,PSORXN,"2;3;6;105","I","PSORX")
     39 S PSOFT1(29)=$$NDC^PSOHDR(PSORXN,PSOREF,$S(PSOREF>0:"R",1:""))
     40 S PSODFN=$G(PSORX(52,PSORXN_",",2,"I")),PSODRG=$G(PSORX(52,PSORXN_",",6,"I")),PSOFT1(31)=$G(PSORX(52,PSORXN_",",105,"I"))
     41 D DATA^PSS50(PSODRG,,,,,"PSOSC")
     42 ;S PSOFT1(2)="PSO"_PSORXN_"F"_PSOREF  ;12/6/05; DECISION MADE TO NOT SEND clinicial event indicator FOR OP
     43 S PSOFT1(7)=$G(^TMP($J,"PSOSC",PSODRG,400)),PSOFT1(6)=PSOCHTYP,PSOFT1(13)=160
     44 S PSOFT1(18)=$G(PSORX(52,PSORXN_",",3,"I")),PSOFT1(18)=$$GET1^DIQ(53,PSOFT1(18)_",",15,"I")
     45 S PSOFT1(22)=$FN($G(^TMP($J,"PSOSC",PSODRG,16)),"",2),PSOFT1(29)=PSOFT1(29)_";"_$G(^TMP($J,"PSOSC",PSODRG,.01))
     46 S PSORXE(31)=$G(^TMP($J,"PSOSC",PSODRG,3)),PSORXE(17)=PSOREF
     47 S:(PSORXE(18)="") PSORXE(18)=$G(RELDT)  ;CMOP
     48 S PSORXE(15)=PSORXN
     49 S PSOCHG=$$CHARGE^IBBAPI(PSODFN,PSOPFSA,PSOCHTYP,PSOCHID,.PSOFT1,"",.PSODG,.PSOZCL,.PSORXE,"","")
     50 ;errors to be handled in subsequent phase
     51 K ^TMP($J,"PSOSC")
     52 Q
     53 ;
     54CHRGOF ;Retrieve charge fields for orig fills
     55 D GETS^DIQ(52,PSORXN,"4;7;8;22;31;125","I","PSORX")
     56 S PSOFD="22,7,4"
     57 F I=1:1 S PSOFLD=$P(PSOFD,",",I) Q:PSOFLD=""  S PSOFT1($P(PSOFT,",",I))=$G(PSORX(52,PSORXN_",",$P(PSOFD,",",I),"I"))
     58 S PSOPFSA=$G(PSORX(52,PSORXN_",",125,"I")),PSORXE(18)=$G(PSORX(52,PSORXN_",",31,"I"))
     59 S PSORXE(1)=PSOFT1(10)_";;"_$G(PSORX(52,PSORXN_",",8,"I"))
     60 D GOC
     61 Q
     62 ;
     63CHRGRF ;Retrieve charge fields for refills
     64 D GETS^DIQ(52.1,PSOREF_","_PSORXN,".01;1;1.1;15;17;21","I","PSORX")
     65 S PSOFD=".01,1,15"
     66 F I=1:1 S PSOFLD=$P(PSOFD,",",I) Q:PSOFLD=""  S PSOFT1($P(PSOFT,",",I))=$G(PSORX(52.1,PSOREF_","_PSORXN_",",$P(PSOFD,",",I),"I"))
     67 S PSOPFSA=$G(PSORX(52.1,PSOREF_","_PSORXN_",",21,"I")),PSORXE(18)=$G(PSORX(52.1,PSOREF_","_PSORXN_",",17,"I"))
     68 S PSORXE(1)=PSOFT1(10)_";;"_$G(PSORX(52.1,PSOREF_","_PSORXN_",",1.1,"I"))
     69 D GOC
     70 Q
     71 ;
     72GOC ;Called from CHRGOF, CHRGRF.  Parse OP classifications and ICD's.  Don't send null values.
     73 D GETS^DIQ(52,PSORXN,"52311*","I","PSORX")
     74 F I=1:1 Q:'$D(PSORX(52.052311,I_","_PSORXN_","))  D
     75 . S:PSORX(52.052311,I_","_PSORXN_",",".01","I")'="" PSODG(I,3)=PSORX(52.052311,I_","_PSORXN_",",".01","I"),PSODG(I,6)="F"
     76 . I I=1 F J=1:1:7 Q:'$D(PSORX(52.052311,I_","_PSORXN_",",J,"I"))  D
     77 . . S:PSORX(52.052311,I_","_PSORXN_",",J,"I")'="" PSOZCL(J,2)=J,PSOZCL(J,3)=PSORX(52.052311,I_","_PSORXN_",",J,"I")
     78 S:'$D(PSOZCL) PSOZCL="" S:'$D(PSODG) PSODG=""
     79 Q
     80 ;
     81CG ;Called from PSOCPB; for the last fill, send chrg message if released; PSOCPB too large for more code.
     82 ; this is used for SC/EI changes when no charges are cancelled.  Expects to have PSODA = RXIEN and PSOLFIL= fill#
     83 ;N REL,PFS
     84 ;I 'PSOLFIL S REL=$$GET1^DIQ(52,PSODA_",","31","I")
     85 ;I PSOLFIL>0 S REL=$$GET1^DIQ(52.1,PSOLFIL_","_PSODA_",","17","I")  ;REFILL
     86 ;I REL'=""&(PSOPFS)&(+$G(PSOPFSA)) D CHRG(PSODA,PSOLFIL,"CG",PSOPFS)
     87 Q
     88 ;
     89LF(PSODA) ;return last fill number;CALLED from PSOCPB
     90 N LF
     91 I $D(^PSRX(PSODA,1,0)) S LF="A",LF=$O(^PSRX(PSODA,1,LF),-1) Q LF
     92 Q 0  ;ORIG FILL
     93 ;
     94PFSI(PSODA,PSOREF) ;get PFSS Acct Ref and Charge ID and store in PSOPFS; Called from multiple places in this routine
     95 I PSOREF=0&($D(^PSRX(PSODA,"PFS"))) S PSOPFS=PSOPFS_"^"_$P(^PSRX(PSODA,"PFS"),"^",1,2) Q
     96 I PSOREF>0&($D(^PSRX(PSODA,1,PSOREF,"PFS"))) S PSOPFS=PSOPFS_"^"_$P(^PSRX(PSODA,1,PSOREF,"PFS"),"^",1,2)
     97 Q
     98 ;
     99PFSA(PSODA,PSOREF,WR) ;called from PSOCP (WR=2) and PSOCPB (WR=3)
     100 ;get switch status, acct ref, and charge ID, then validate switch vs availability of PFSS acct ref
     101 Q:'$G(WR)
     102 S PSOPFS=+$$SWSTAT^IBBAPI()
     103 D PFSI(PSODA,PSOREF)
     104 ; if switch is off, but have an PFSS Acct Ref for new orders, send charge to IDX
     105 ; if switch is off, but have a Charge ID, send cancel charge to IDX
     106 I '+PSOPFS,$P(PSOPFS,"^",WR)>0 S $P(PSOPFS,"^")=1
     107 Q
     108 ;
     109PFS ;;Called from PSOCPB; PSOCPB is too large to hold more code.  Processes copay cancels for PFS only.
     110 ;find any fills being cancelled for PFSS, cancel them, and remove them from PSOCAN, then return to PSOCP to process any IB cancels
     111 ;
     112 N X,I,PSOREF,PSOOLD,PREA,PSONW
     113 ;If it's a PFS fill, if released, and not previously cancelled, set the X array, then kill it out of PSOCAN array.
     114 ;Killed out of PSOCAN because don't want the IB processing to look at PFSS billed fills.
     115 ;Note that in PSOCPD, PFS entries are not stored in PSOCAN array if a charge ID is not defined.  So, don't have to check for release date.
     116 ;If prev cancelled and PFS, kill it from PSOCAN array
     117 S I="" F  S I=$O(PSOCAN(I)) Q:I=""  S PSOREF=+PSOCAN(I) D
     118 . I PSOREF=PSODA&($P(PSOCAN(I),"^",10)="PFS") D  Q
     119 . . I $P(PSOCAN(I),"^",5)["CANCEL" K PSOCAN(I) Q
     120 . . S X(0)=$P(PSOCAN(I),"^",2)_"^"_PSORSN K PSOCAN(I)
     121 . I PSOREF'=PSODA&($P(PSOCAN(I),"^",10)="PFS") D
     122 . . I $P(PSOCAN(I),"^",5)["CANCEL" K PSOCAN(I) Q
     123 . . S X(PSOREF)=$P(PSOCAN(I),"^",2)_"^"_PSORSN K PSOCAN(I)
     124 I $G(CANTYPE)&('$D(X)) D MSGNOCAN^PSOCPB Q  ;CANTYPE=1 means trying cancelling all fills;can't cancel twice
     125 ;
     126 ;send charge messages, set activity log, display message
     127 S PREA="C",PSOREF=""
     128 F  S PSOREF=$O(X(PSOREF)) Q:PSOREF=""  S PSOPFS=1 D PFSI(PSODA,PSOREF) D CHRG(PSODA,PSOREF,"CD",PSOPFS) D ACTLOG^PSOCPA D:'$G(CANTYPE) MSG^PSOCPB
     129 I $G(CANTYPE)&('$D(PSOCAN)) D MSG^PSOCPB  ;if cancelling all and no legacy IB bills to cancel, write msg
     130 S PSOPFSA=0  ;reset variable so charge isn't sent twice if SC/EI's were also changed.
     131 Q
     132 ;

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPMP0.m

    r613 r623  
    1 PSOPMP0 ;BIRM/MFR - Patient Medication Profile - Listmanager ;10/28/06
    2         ;;7.0;OUTPATIENT PHARMACY;**260,281**;DEC 1997;Build 41
    3         ;Reference to EN1^GMRADPT supported by IA #10099
    4         ;Reference to EN6^GMRVUTL supported by IA #1120
    5         ;Reference to ^PS(55 supported by DBIA 2228
    6         ;
    7 EN      ; - Menu option entry point
    8         N PSOEXPDC,PSOEXDCE,PSOSRTBY,PSORDER,PSOSIGDP,PSOSTSGP,PSOSTORD,PSORDCNT,PSOSTSEQ,PSORDSEQ,PSOCHNG
    9         N GRPLN,DIC,Y,DFN,GRPLN,HIGHLN,LASTLINE,VALMCNT
    10         ;
    11         ; - Division selection
    12         I '$G(PSOSITE) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"Pharmacy Division Must be Selected!",! G EXIT
    13         ;
    14         ; - Patient selection
    15         W !! S DIC=2,DIC(0)="QEAM" D ^DIC G EXIT:Y<0  S DFN=+Y
    16         ;
    17         S PSODFN=DFN D CHKADDR^PSOBAI(DFN,1,1)  ;bad address flag/update
    18         ;
    19         D LST(PSOSITE,DFN)
    20         Q
    21         ;
    22 LST(SITE,PSODFN)        ; - ListManager entry point
    23         ; Loading Division/User preferences
    24         D LOAD^PSOPMPPF(SITE,DUZ)
    25         ;
    26         W !,"Please wait..."
    27         D EN^VALM("PSO PMP MAIN")
    28         D FULL^VALM1
    29         G EXIT
    30         ;
    31 HDR          ; - Header
    32         N LINE,POS,LINE1,LINE2,LINE3,LINE4,WT,WTDT,HT,HTDT,VADM,DFN,PNAME,DOB,SEX,X,GMRAL,ADVREA
    33         ;
    34         K VADM S DFN=PSODFN D DEM^VADPT
    35         S PNAME=VADM(1)
    36         S DOB=$S(+VADM(3):$P(VADM(3),"^",2)_" ("_$G(VADM(4))_")",1:"UNKNOWN")
    37         S SEX=$P(VADM(5),"^",2)
    38         S (WT,X)="",GMRVSTR="WT" D EN6^GMRVUTL I X'="" S WT=$J($P(X,"^",8)/2.2,6,2),WTDT=$$DAT^PSOPMP1($P(X,"^")\1,"/",1)
    39         S (HT,X)="",GMRVSTR="HT" D EN6^GMRVUTL I X'="" S HT=$J($P(X,"^",8)*2.54,6,2),HTDT=$$DAT^PSOPMP1($P(X,"^")\1,"/",1)
    40         S LINE1=PNAME
    41         S LINE1=$$ALLERGY^PSOPMP1(LINE1,DFN)
    42         S LINE2="  PID: "_$P(VADM(2),"^",2),$E(LINE2,50)="HEIGHT(cm): "_$S(HT'="":HT_" ("_HTDT_")",1:"NOT AVAILABLE")
    43         S LINE3="  DOB: "_DOB,$E(LINE3,50)="WEIGHT(kg): "_$S(WT'="":WT_" ("_WTDT_")",1:"NOT AVAILABLE")
    44         S LINE4="  SEX: "_SEX,$E(LINE4,43)="EXP/CANCEL CUTOFF: "_PSOEXDCE_" DAYS"
    45         ;
    46         K VALMHDR S VALMHDR(1)=LINE1,VALMHDR(2)=LINE2,VALMHDR(3)=LINE3,VALMHDR(4)=LINE4
    47         ;
    48         D SETHDR^PSOPMP1()
    49         Q
    50         ;
    51 INIT    ; - Populates the Body section for ListMan
    52         K ^TMP("PSOPMP0",$J)
    53         ;
    54         D SETSORT(PSOSRTBY),SETLINE
    55         S VALMSG="Select the entry # to view or ?? for more actions"
    56         Q
    57         ;
    58 SETLINE ; - Sets the line to be displayed in ListMan
    59         N TYPE,STS,SUB,SEQ,LINE,Z,TOTAL,I,X,X1,ORDCNT,LBL,LN,IENSUB,GROUP,GRP,QTYL
    60         I '$D(^TMP("PSOPMPSR",$J)) D  Q
    61         . F I=1:1:6 S ^TMP("PSOPMP0",$J,I,0)=""
    62         . S ^TMP("PSOPMP0",$J,7,0)="                    No prescriptions found for this patient."
    63         . S VALMCNT=1
    64         ;
    65         ; - Resetting list to NORMAL video attributes
    66         F I=1:1:$G(LASTLINE) D RESTORE^VALM10(I)
    67         K GRPLN,HIGHLN
    68         ;
    69         ; - Building the list (line by line)
    70         S (GROUP,STS,SUB)="",LINE=0 K ^TMP("PSOPMP0",$J)
    71         F  S GROUP=$O(^TMP("PSOPMPSR",$J,GROUP)) Q:GROUP=""  D
    72         . S GRP=$P(GROUP,"^")
    73         . I GRP'["R"!('PSOSTSGP&($O(^TMP("PSOPMPSR",$J,GROUP),-1)'="")) D
    74         . . D GROUP^PSOPMP1($P(GROUP,"^",2),+$G(^TMP("PSOPMPSR",$J,GROUP)),.LINE)
    75         . F  S STS=$O(^TMP("PSOPMPSR",$J,GROUP,STS)) Q:STS=""  D
    76         . . I STS'="<NULL>" D
    77         . . . D GROUP^PSOPMP1($P(STS,"^",2),+$G(^TMP("PSOPMPSR",$J,GROUP,STS)),.LINE)
    78         . . F  S SUB=$O(^TMP("PSOPMPSR",$J,GROUP,STS,SUB),$S(PSORDER="A":1,1:-1)) Q:SUB=""  D
    79         . . . S Z=$G(^TMP("PSOPMPSR",$J,GROUP,STS,SUB))
    80         . . . S X1="",SEQ=$G(SEQ)+1,X1=$J(SEQ,3)
    81         . . . S QTYL=$L($P(Z,"^",4)) S:QTYL<5 QTYL=5
    82         . . . I GRP["R"!(GRP["T") S $E(X1,5)=$P(Z,"^",2),$E(X1,19)=$E($P(Z,"^",3),1,(32-QTYL))
    83         . . . I GRP["P"!(GRP["N") S $E(X1,5)=$P(Z,"^",3)
    84         . . . I GRP["N" S $E(X1,49)="Date Documented:"
    85         . . . I GRP'["N" S $E(X1,52-QTYL)=$J($P(Z,"^",4),QTYL),$E(X1,53)=$P(Z,"^",5),$E(X1,57)=$P(Z,"^",6)
    86         . . . S $E(X1,66)=$P(Z,"^",7)
    87         . . . S $E(X1,74)=$J($P(Z,"^",8),3),$E(X1,78)=$J($P(Z,"^",9),3)
    88         . . . S LINE=LINE+1,^TMP("PSOPMP0",$J,LINE,0)=X1,HIGHLN(LINE)=""
    89         . . . S IENSUB=$S(GRP["R"!(GRP["T"):"RX",GRP["P":"PEN",1:"NVA")
    90         . . . S ^TMP("PSOPMP0",$J,SEQ,IENSUB)=$P(Z,"^")
    91         . . . I $G(PSOSIGDP) D SETSIG^PSOPMP1($S(GRP["R"!(GRP["T"):"R",GRP["P":"P",1:"N"),+Z,.LINE,PSODFN)
    92         ;
    93         ; - Saving NORMAL video attributes to be reset later
    94         I LINE>$G(LASTLINE) D
    95         . F I=($G(LASTLINE)+1):1:LINE D SAVE^VALM10(I)
    96         . S LASTLINE=LINE
    97         ;
    98         D VIDEO^PSOPMP1()
    99         ;
    100         S VALMCNT=+$G(LINE)
    101         Q
    102         ;
    103 SETSORT(FIELD)  ; - Sets the data sorted by the FIELD specified
    104         N SEQ,RX,RXNUM,DRUG,DRNAME,QTY,STATUS,STS,ISSDT,DOCDAT,LSTFD,REFREM,DAYSUP,SIG,Z,ORD,GRPCNT,GROUP,RFRX,OI,PSOBADR
    105         ;
    106         K ^TMP("PSOPMPSR",$J)
    107         ;
    108         ; - Loading prescription (file #55)
    109         S SEQ=0
    110         F  S SEQ=$O(^PS(55,PSODFN,"P",SEQ)) Q:'SEQ  D
    111         . S RX=+$G(^PS(55,PSODFN,"P",SEQ,0)) I 'RX!($G(^PSRX(RX,0))="") Q
    112         . I $$FILTER^PSOPMP1(RX) Q
    113         . S RXNUM=$$GET1^DIQ(52,RX,.01)
    114         . S DRUG=$$GET1^DIQ(52,RX,6,"I")
    115         . S DRNAME=$$GET1^DIQ(50,DRUG,.01)
    116         . S QTY=$$GET1^DIQ(52,RX,7)
    117         . S STATUS=$$STSINFO^PSOPMP1(RX)
    118         . S ISSDT=$$ISSDT^PSOPMP1(RX,"R")
    119         . S LSTFD=$$LSTFD^PSOPMP1(RX)
    120         . S REFREM=$$REFREM^PSOPMP1(RX)
    121         . S DAYSUP=$$GET1^DIQ(52,RX,8)
    122         . S PSOBADR=$O(^PSRX(RX,"L",9999),-1)
    123         . I PSOBADR'="" S PSOBADR=$G(^PSRX(RX,"L",PSOBADR,0)) I PSOBADR["(BAD ADDRESS)" S PSOBADR="B"
    124         . I PSOBADR'="B" S PSOBADR=""
    125         . S Z="",$P(Z,"^")=RX,$P(Z,"^",2)=RXNUM_$$COPAY^PSOPMP1(RX)_$$ECME^PSOBPSUT(RX),$P(Z,"^",3)=$E(DRNAME,1,30)
    126         . S $P(Z,"^",4)=QTY,$P(Z,"^",5)=$P(STATUS,"^",3)_$$CMOP^PSOPMP1(DRUG,RX)_PSOBADR,$P(Z,"^",6)=$P(ISSDT,"^",2)
    127         . S $P(Z,"^",7)=$P(LSTFD,"^",2),$P(Z,"^",8)=REFREM,$P(Z,"^",9)=DAYSUP
    128         . S SORT=$S(FIELD="RX":RXNUM_" ",FIELD="DR":DRNAME_RXNUM,FIELD="ID":+ISSDT_RXNUM_" ",FIELD="LF":+LSTFD_RXNUM_" ")
    129         . S STS="<NULL>" I $G(PSOSTSGP) S STS=$P(STATUS,"^")_"^"_$P(STATUS,"^",2)
    130         . S GROUP=$P(PSORDSEQ("R"),"^")_"R^"_$P(PSORDSEQ("R"),"^",2)
    131         . I $$FIND^PSOREJUT(RX) S GROUP=$P(PSORDSEQ("T"),"^")_"T^"_$P(PSORDSEQ("T"),"^",2),STS="<NULL>"
    132         . S ^TMP("PSOPMPSR",$J,GROUP,STS,SORT)=Z
    133         . S GRPCNT(GROUP)=$G(GRPCNT(GROUP))+1,GRPCNT(GROUP,STS)=$G(GRPCNT(GROUP,STS))+1
    134         ;
    135         S GROUP=""
    136         F  S GROUP=$O(GRPCNT(GROUP)) Q:GROUP=""  D
    137         . S ^TMP("PSOPMPSR",$J,GROUP)=$G(GRPCNT(GROUP))
    138         . S STS="" F  S STS=$O(GRPCNT(GROUP,STS)) Q:STS=""  D
    139         . . S ^TMP("PSOPMPSR",$J,GROUP,STS)=GRPCNT(GROUP,STS)
    140         ;
    141         ; - Loading pending orders (file #52.41)
    142         S ORD=0,GROUP=$P(PSORDSEQ("P"),"^")_"P^"_$P(PSORDSEQ("P"),"^",2)
    143         F  S ORD=$O(^PS(52.41,"P",PSODFN,ORD)) Q:'ORD  D
    144         . S TYPE=$$GET1^DIQ(52.41,ORD,2,"I")
    145         . I TYPE="DC"!(TYPE="DE")!(TYPE="HD") Q
    146         . S DRNAME="",DRUG=+$$GET1^DIQ(52.41,ORD,11,"I") I DRUG S DRNAME=$$GET1^DIQ(50,DRUG,.01)
    147         . I DRNAME="" D  Q:DRNAME=""
    148         . . S OI=$$GET1^DIQ(52.41,ORD,8,"I") I 'OI Q
    149         . . S DRNAME=$$GET1^DIQ(50.7,OI,.01)_" "_$$GET1^DIQ(50.7,OI,.02)
    150         . S QTY=$$GET1^DIQ(52.41,ORD,12)
    151         . S STATUS=$$GET1^DIQ(52.41,ORD,2,"I")
    152         . S ISSDT=$$ISSDT^PSOPMP1(ORD,"P")
    153         . S REFREM=$$GET1^DIQ(52.41,ORD,13)
    154         . S DAYSUP=$$GET1^DIQ(52.41,ORD,101)
    155         . S RFRX="" I STATUS="RF" S RFRX=$$GET1^DIQ(52.41,ORD,21,"I") I RFRX S RFRX=$$GET1^DIQ(52,RFRX,.01)
    156         . S Z="",$P(Z,"^")=ORD,$P(Z,"^",3)=$E(DRNAME,1,45),$P(Z,"^",4)=QTY,$P(Z,"^",5)=$E(STATUS,1,2)_$$CMOP^PSOPMP1(DRUG)
    157         . S $P(Z,"^",6)=$S(RFRX'="":"Rx#: "_RFRX,1:$P(ISSDT,"^",2)),$P(Z,"^",8)=REFREM,$P(Z,"^",9)=DAYSUP
    158         . S SORT=$S(FIELD="RX":DRNAME_ORD,FIELD="DR":DRNAME_ORD,FIELD="ID":+ISSDT_ORD,FIELD="LF":+ISSDT_ORD)
    159         . S ^TMP("PSOPMPSR",$J,GROUP,"<NULL>",SORT)=Z
    160         . S GRPCNT(GROUP)=$G(GRPCNT(GROUP))+1
    161         ;
    162         S:$G(GRPCNT(GROUP)) ^TMP("PSOPMPSR",$J,GROUP)=$G(GRPCNT(GROUP))
    163         ;
    164         ; - Loading Non-VA Med orders (file #55, sub-file #55.05)
    165         S ORD=0,GROUP=$P(PSORDSEQ("N"),"^")_"N^"_$P(PSORDSEQ("N"),"^",2)
    166         F  S ORD=$O(^PS(55,PSODFN,"NVA",ORD)) Q:'ORD  D
    167         . I $$GET1^DIQ(55.05,ORD_","_PSODFN,5,"I") Q
    168         . S DRNAME=$$GET1^DIQ(55.05,ORD_","_PSODFN,1)
    169         . I DRNAME="" D  Q:DRNAME=""
    170         . . S OI=$$GET1^DIQ(55.05,ORD_","_PSODFN,.01,"I") I 'OI Q
    171         . . S DRNAME=$$GET1^DIQ(50.7,OI,.01)_" "_$$GET1^DIQ(50.7,OI,.02)
    172         . S DOCDAT=$P($$GET1^DIQ(55.05,ORD_","_PSODFN_",",11,"I"),".")
    173         . S Z="",$P(Z,"^")=ORD,$P(Z,"^",3)=$E(DRNAME,1,38),$P(Z,"^",7)=$$DAT^PSOPMP1(DOCDAT,"-")
    174         . S SORT=$S(FIELD="RX":DRNAME_ORD,FIELD="DR":DRNAME_ORD,FIELD="ID":DOCDAT_ORD,FIELD="LF":DOCDAT_ORD)
    175         . S ^TMP("PSOPMPSR",$J,GROUP,"<NULL>",SORT)=Z
    176         . S GRPCNT(GROUP)=$G(GRPCNT(GROUP))+1
    177         ;
    178         S:$G(GRPCNT(GROUP)) ^TMP("PSOPMPSR",$J,GROUP)=$G(GRPCNT(GROUP))
    179         ;
    180         Q
    181         ;
    182 RX      ; - Sort by Rx
    183         D SORT("RX")
    184         Q
    185 DR      ; - Sort by Drug
    186         D SORT("DR")
    187         Q
    188 ID      ; - Sort by Issue Date
    189         D SORT("ID")
    190         Q
    191 LF      ; - Sort by Last Fill Date
    192         D SORT("LF")
    193         Q
    194         ;
    195 SORT(FIELD)     ; - Sort entries by FIELD
    196         I PSOSRTBY=FIELD S PSORDER=$S(PSORDER="A":"D",1:"A")
    197         E  S PSOSRTBY=FIELD,PSORDER="A"
    198         D REF
    199         Q
    200         ;
    201 REF     ; - Screen Refresh
    202         W ?52,"Please wait..." D INIT,HDR S VALMBCK="R"
    203         Q
    204 GS      ; - Group by Status
    205         W ?52,"Please wait..." S PSOSTSGP=$S($G(PSOSTSGP):0,1:1) D INIT,HDR S VALMBCK="R"
    206         Q
    207         ;
    208 SIG     ; - Display SIG
    209         W ?52,"Please wait..." S PSOSIGDP=$S($G(PSOSIGDP):0,1:1) D INIT,HDR S VALMBCK="R"
    210         I 'PSOSIGDP S VALMBG=VALMBG\2
    211         I PSOSIGDP S VALMBG=VALMBG*2-1
    212         S:VALMBG>(VALMCNT-10) VALMBG=VALMCNT-10 S:VALMBG<1 VALMBG=1
    213         Q
    214         ;
    215 PI      ; - Patient Information
    216         D EN^PSOLMPI S VALMBCK="R"
    217         Q
    218         ;
    219 CV      ; - Change View
    220         D LST^PSOPMPPF(SITE,DUZ) W !?52,"Please wait..." D INIT,HDR
    221         S VALMBG=1,VALMBCK="R"
    222         Q
    223         ;
    224 SEL     ; - Process selection of one entry
    225         N PSOSEL,TYPE,XQORM,ORD,TITLE
    226         S PSOSEL=+$P($P(Y(1),"^",4),"=",2) I 'PSOSEL S VALMSG="Invalid selection!",VALMBCK="R" Q
    227         S TYPE=$O(^TMP("PSOPMP0",$J,PSOSEL,0)) I TYPE="" S VALMSG="Invalid selection!",VALMBCK="R" Q
    228         S ORD=$G(^TMP("PSOPMP0",$J,PSOSEL,TYPE))
    229         I 'ORD S VALMSG="Invalid selection!",VALMBCK="R" Q
    230         S TITLE=VALM("TITLE")
    231         ;
    232         ; - Regular prescription
    233         I TYPE="RX" D  S VALMBCK="R" D REF
    234         . N PSOVDA,PSOSAVE,DA,PS
    235         . S (PSOVDA,DA)=ORD,PS="REJECTMP"
    236         . N LINE,TITLE,PSODFN D DP^PSORXVW
    237         ;
    238         ; - Pending Order
    239         I TYPE="PEN" D
    240         . N PSOACTOV,OR0
    241         . S OR0=^PS(52.41,ORD,0),PSOACTOV=""
    242         . N LINE,TITLE D PENHDR^PSOPMP1(PSODFN),DSPL^PSOORFI1
    243         ;
    244         ; - Pending Order
    245         I TYPE="NVA" D
    246         . N LINE,TITLE D EN^PSONVAVW(PSODFN,ORD)
    247         ;
    248         S VALMBCK="R",VALM("TITLE")=TITLE
    249         Q
    250         ;
    251 EXIT    ;
    252         K ^TMP("PSOPMP0",$J),^TMP("PSOPMPSR",$J)
    253         Q
    254         ;
    255 HELP    Q
     1PSOPMP0 ;BIRM/MFR - Patient Medication Profile - Listmanager ;10/28/06
     2 ;;7.0;OUTPATIENT PHARMACY;**260**;DEC 1997;Build 84
     3 ;Reference to EN1^GMRADPT supported by IA #10099
     4 ;Reference to EN6^GMRVUTL supported by IA #1120
     5 ;Reference to ^PS(55 supported by DBIA 2228
     6 ;
     7EN ; - Menu option entry point
     8 N PSOEXPDC,PSOEXDCE,PSOSRTBY,PSORDER,PSOSIGDP,PSOSTSGP,PSOSTORD,PSORDCNT,PSOSTSEQ,PSORDSEQ,PSOCHNG
     9 N GRPLN,DIC,Y,DFN,GRPLN,HIGHLN,LASTLINE,VALMCNT
     10 ;
     11 ; - Division selection
     12 I '$G(PSOSITE) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"Pharmacy Division Must be Selected!",! G EXIT
     13 ;
     14 ; - Patient selection
     15 W !! S DIC=2,DIC(0)="QEAM" D ^DIC G EXIT:Y<0  S DFN=+Y
     16 ;
     17 D LST(PSOSITE,DFN)
     18 Q
     19 ;
     20LST(SITE,PSODFN) ; - ListManager entry point
     21 ; Loading Division/User preferences
     22 D LOAD^PSOPMPPF(SITE,DUZ)
     23 ;
     24 W !,"Please wait..."
     25 D EN^VALM("PSO PMP MAIN")
     26 D FULL^VALM1
     27 G EXIT
     28 ;
     29HDR      ; - Header
     30 N LINE,POS,LINE1,LINE2,LINE3,LINE4,WT,WTDT,HT,HTDT,VADM,DFN,PNAME,DOB,SEX,X,GMRAL,ADVREA
     31 ;
     32 K VADM S DFN=PSODFN D DEM^VADPT
     33 S PNAME=VADM(1)
     34 S DOB=$S(+VADM(3):$P(VADM(3),"^",2)_" ("_$G(VADM(4))_")",1:"UNKNOWN")
     35 S SEX=$P(VADM(5),"^",2)
     36 S (WT,X)="",GMRVSTR="WT" D EN6^GMRVUTL I X'="" S WT=$J($P(X,"^",8)/2.2,6,2),WTDT=$$DAT^PSOPMP1($P(X,"^")\1,"/",1)
     37 S (HT,X)="",GMRVSTR="HT" D EN6^GMRVUTL I X'="" S HT=$J($P(X,"^",8)*2.54,6,2),HTDT=$$DAT^PSOPMP1($P(X,"^")\1,"/",1)
     38 S LINE1=PNAME
     39 S LINE1=$$ALLERGY^PSOPMP1(LINE1,DFN)
     40 S LINE2="  PID: "_$P(VADM(2),"^",2),$E(LINE2,50)="HEIGHT(cm): "_$S(HT'="":HT_" ("_HTDT_")",1:"NOT AVAILABLE")
     41 S LINE3="  DOB: "_DOB,$E(LINE3,50)="WEIGHT(kg): "_$S(WT'="":WT_" ("_WTDT_")",1:"NOT AVAILABLE")
     42 S LINE4="  SEX: "_SEX,$E(LINE4,43)="EXP/CANCEL CUTOFF: "_PSOEXDCE_" DAYS"
     43 ;
     44 K VALMHDR S VALMHDR(1)=LINE1,VALMHDR(2)=LINE2,VALMHDR(3)=LINE3,VALMHDR(4)=LINE4
     45 ;
     46 D SETHDR^PSOPMP1()
     47 Q
     48 ;
     49INIT ; - Populates the Body section for ListMan
     50 K ^TMP("PSOPMP0",$J)
     51 ;
     52 D SETSORT(PSOSRTBY),SETLINE
     53 S VALMSG="Select the entry # to view or ?? for more actions"
     54 Q
     55 ;
     56SETLINE ; - Sets the line to be displayed in ListMan
     57 N TYPE,STS,SUB,SEQ,LINE,Z,TOTAL,I,X,X1,ORDCNT,LBL,LN,IENSUB,GROUP,GRP,QTYL
     58 I '$D(^TMP("PSOPMPSR",$J)) D  Q
     59 . F I=1:1:6 S ^TMP("PSOPMP0",$J,I,0)=""
     60 . S ^TMP("PSOPMP0",$J,7,0)="                    No prescriptions found for this patient."
     61 . S VALMCNT=1
     62 ;
     63 ; - Resetting list to NORMAL video attributes
     64 F I=1:1:$G(LASTLINE) D RESTORE^VALM10(I)
     65 K GRPLN,HIGHLN
     66 ;
     67 ; - Building the list (line by line)
     68 S (GROUP,STS,SUB)="",LINE=0 K ^TMP("PSOPMP0",$J)
     69 F  S GROUP=$O(^TMP("PSOPMPSR",$J,GROUP)) Q:GROUP=""  D
     70 . S GRP=$P(GROUP,"^")
     71 . I GRP'["R"!('PSOSTSGP&($O(^TMP("PSOPMPSR",$J,GROUP),-1)'="")) D
     72 . . D GROUP^PSOPMP1($P(GROUP,"^",2),+$G(^TMP("PSOPMPSR",$J,GROUP)),.LINE)
     73 . F  S STS=$O(^TMP("PSOPMPSR",$J,GROUP,STS)) Q:STS=""  D
     74 . . I STS'="<NULL>" D
     75 . . . D GROUP^PSOPMP1($P(STS,"^",2),+$G(^TMP("PSOPMPSR",$J,GROUP,STS)),.LINE)
     76 . . F  S SUB=$O(^TMP("PSOPMPSR",$J,GROUP,STS,SUB),$S(PSORDER="A":1,1:-1)) Q:SUB=""  D
     77 . . . S Z=$G(^TMP("PSOPMPSR",$J,GROUP,STS,SUB))
     78 . . . S X1="",SEQ=$G(SEQ)+1,X1=$J(SEQ,3)
     79 . . . S QTYL=$L($P(Z,"^",4)) S:QTYL<5 QTYL=5
     80 . . . I GRP["R"!(GRP["T") S $E(X1,5)=$P(Z,"^",2),$E(X1,19)=$E($P(Z,"^",3),1,(32-QTYL))
     81 . . . I GRP["P"!(GRP["N") S $E(X1,5)=$P(Z,"^",3)
     82 . . . I GRP["N" S $E(X1,49)="Date Documented:"
     83 . . . I GRP'["N" S $E(X1,52-QTYL)=$J($P(Z,"^",4),QTYL),$E(X1,53)=$P(Z,"^",5),$E(X1,57)=$P(Z,"^",6)
     84 . . . S $E(X1,66)=$P(Z,"^",7)
     85 . . . S $E(X1,74)=$J($P(Z,"^",8),3),$E(X1,78)=$J($P(Z,"^",9),3)
     86 . . . S LINE=LINE+1,^TMP("PSOPMP0",$J,LINE,0)=X1,HIGHLN(LINE)=""
     87 . . . S IENSUB=$S(GRP["R"!(GRP["T"):"RX",GRP["P":"PEN",1:"NVA")
     88 . . . S ^TMP("PSOPMP0",$J,SEQ,IENSUB)=$P(Z,"^")
     89 . . . I $G(PSOSIGDP) D SETSIG^PSOPMP1($S(GRP["R"!(GRP["T"):"R",GRP["P":"P",1:"N"),+Z,.LINE,PSODFN)
     90 ;
     91 ; - Saving NORMAL video attributes to be reset later
     92 I LINE>$G(LASTLINE) D
     93 . F I=($G(LASTLINE)+1):1:LINE D SAVE^VALM10(I)
     94 . S LASTLINE=LINE
     95 ;
     96 D VIDEO^PSOPMP1()
     97 ;
     98 S VALMCNT=+$G(LINE)
     99 Q
     100 ;
     101SETSORT(FIELD) ; - Sets the data sorted by the FIELD specified
     102 N SEQ,RX,RXNUM,DRUG,DRNAME,QTY,STATUS,STS,ISSDT,DOCDAT,LSTFD,REFREM,DAYSUP,SIG,Z,ORD,GRPCNT,GROUP,RFRX,OI
     103 ;
     104 K ^TMP("PSOPMPSR",$J)
     105 ;
     106 ; - Loading prescription (file #55)
     107 S SEQ=0
     108 F  S SEQ=$O(^PS(55,PSODFN,"P",SEQ)) Q:'SEQ  D
     109 . S RX=+$G(^PS(55,PSODFN,"P",SEQ,0)) I 'RX!($G(^PSRX(RX,0))="") Q
     110 . I $$FILTER^PSOPMP1(RX) Q
     111 . S RXNUM=$$GET1^DIQ(52,RX,.01)
     112 . S DRUG=$$GET1^DIQ(52,RX,6,"I")
     113 . S DRNAME=$$GET1^DIQ(50,DRUG,.01)
     114 . S QTY=$$GET1^DIQ(52,RX,7)
     115 . S STATUS=$$STSINFO^PSOPMP1(RX)
     116 . S ISSDT=$$ISSDT^PSOPMP1(RX,"R")
     117 . S LSTFD=$$LSTFD^PSOPMP1(RX)
     118 . S REFREM=$$REFREM^PSOPMP1(RX)
     119 . S DAYSUP=$$GET1^DIQ(52,RX,8)
     120 . S Z="",$P(Z,"^")=RX,$P(Z,"^",2)=RXNUM_$$COPAY^PSOPMP1(RX)_$$ECME^PSOBPSUT(RX),$P(Z,"^",3)=$E(DRNAME,1,30)
     121 . S $P(Z,"^",4)=QTY,$P(Z,"^",5)=$P(STATUS,"^",3)_$$CMOP^PSOPMP1(DRUG,RX),$P(Z,"^",6)=$P(ISSDT,"^",2)
     122 . S $P(Z,"^",7)=$P(LSTFD,"^",2),$P(Z,"^",8)=REFREM,$P(Z,"^",9)=DAYSUP
     123 . S SORT=$S(FIELD="RX":RXNUM_" ",FIELD="DR":DRNAME_RXNUM,FIELD="ID":+ISSDT_RXNUM_" ",FIELD="LF":+LSTFD_RXNUM_" ")
     124 . S STS="<NULL>" I $G(PSOSTSGP) S STS=$P(STATUS,"^")_"^"_$P(STATUS,"^",2)
     125 . S GROUP=$P(PSORDSEQ("R"),"^")_"R^"_$P(PSORDSEQ("R"),"^",2)
     126 . I $$FIND^PSOREJUT(RX) S GROUP=$P(PSORDSEQ("T"),"^")_"T^"_$P(PSORDSEQ("T"),"^",2),STS="<NULL>"
     127 . S ^TMP("PSOPMPSR",$J,GROUP,STS,SORT)=Z
     128 . S GRPCNT(GROUP)=$G(GRPCNT(GROUP))+1,GRPCNT(GROUP,STS)=$G(GRPCNT(GROUP,STS))+1
     129 ;
     130 S GROUP=""
     131 F  S GROUP=$O(GRPCNT(GROUP)) Q:GROUP=""  D
     132 . S ^TMP("PSOPMPSR",$J,GROUP)=$G(GRPCNT(GROUP))
     133 . S STS="" F  S STS=$O(GRPCNT(GROUP,STS)) Q:STS=""  D
     134 . . S ^TMP("PSOPMPSR",$J,GROUP,STS)=GRPCNT(GROUP,STS)
     135 ;
     136 ; - Loading pending orders (file #52.41)
     137 S ORD=0,GROUP=$P(PSORDSEQ("P"),"^")_"P^"_$P(PSORDSEQ("P"),"^",2)
     138 F  S ORD=$O(^PS(52.41,"P",PSODFN,ORD)) Q:'ORD  D
     139 . S TYPE=$$GET1^DIQ(52.41,ORD,2,"I")
     140 . I TYPE="DC"!(TYPE="DE")!(TYPE="HD") Q
     141 . S DRNAME="",DRUG=+$$GET1^DIQ(52.41,ORD,11,"I") I DRUG S DRNAME=$$GET1^DIQ(50,DRUG,.01)
     142 . I DRNAME="" D  Q:DRNAME=""
     143 . . S OI=$$GET1^DIQ(52.41,ORD,8,"I") I 'OI Q
     144 . . S DRNAME=$$GET1^DIQ(50.7,OI,.01)_" "_$$GET1^DIQ(50.7,OI,.02)
     145 . S QTY=$$GET1^DIQ(52.41,ORD,12)
     146 . S STATUS=$$GET1^DIQ(52.41,ORD,2,"I")
     147 . S ISSDT=$$ISSDT^PSOPMP1(ORD,"P")
     148 . S REFREM=$$GET1^DIQ(52.41,ORD,13)
     149 . S DAYSUP=$$GET1^DIQ(52.41,ORD,101)
     150 . S RFRX="" I STATUS="RF" S RFRX=$$GET1^DIQ(52.41,ORD,21,"I") I RFRX S RFRX=$$GET1^DIQ(52,RFRX,.01)
     151 . S Z="",$P(Z,"^")=ORD,$P(Z,"^",3)=$E(DRNAME,1,45),$P(Z,"^",4)=QTY,$P(Z,"^",5)=$E(STATUS,1,2)_$$CMOP^PSOPMP1(DRUG)
     152 . S $P(Z,"^",6)=$S(RFRX'="":"Rx#: "_RFRX,1:$P(ISSDT,"^",2)),$P(Z,"^",8)=REFREM,$P(Z,"^",9)=DAYSUP
     153 . S SORT=$S(FIELD="RX":DRNAME_ORD,FIELD="DR":DRNAME_ORD,FIELD="ID":+ISSDT_ORD,FIELD="LF":+ISSDT_ORD)
     154 . S ^TMP("PSOPMPSR",$J,GROUP,"<NULL>",SORT)=Z
     155 . S GRPCNT(GROUP)=$G(GRPCNT(GROUP))+1
     156 ;
     157 S:$G(GRPCNT(GROUP)) ^TMP("PSOPMPSR",$J,GROUP)=$G(GRPCNT(GROUP))
     158 ;
     159 ; - Loading Non-VA Med orders (file #55, sub-file #55.05)
     160 S ORD=0,GROUP=$P(PSORDSEQ("N"),"^")_"N^"_$P(PSORDSEQ("N"),"^",2)
     161 F  S ORD=$O(^PS(55,PSODFN,"NVA",ORD)) Q:'ORD  D
     162 . I $$GET1^DIQ(55.05,ORD_","_PSODFN,5,"I") Q
     163 . S DRNAME=$$GET1^DIQ(55.05,ORD_","_PSODFN,1)
     164 . I DRNAME="" D  Q:DRNAME=""
     165 . . S OI=$$GET1^DIQ(55.05,ORD_","_PSODFN,.01,"I") I 'OI Q
     166 . . S DRNAME=$$GET1^DIQ(50.7,OI,.01)_" "_$$GET1^DIQ(50.7,OI,.02)
     167 . S DOCDAT=$P($$GET1^DIQ(55.05,ORD_","_PSODFN_",",11,"I"),".")
     168 . S Z="",$P(Z,"^")=ORD,$P(Z,"^",3)=$E(DRNAME,1,38),$P(Z,"^",7)=$$DAT^PSOPMP1(DOCDAT,"-")
     169 . S SORT=$S(FIELD="RX":DRNAME_ORD,FIELD="DR":DRNAME_ORD,FIELD="ID":DOCDAT_ORD,FIELD="LF":DOCDAT_ORD)
     170 . S ^TMP("PSOPMPSR",$J,GROUP,"<NULL>",SORT)=Z
     171 . S GRPCNT(GROUP)=$G(GRPCNT(GROUP))+1
     172 ;
     173 S:$G(GRPCNT(GROUP)) ^TMP("PSOPMPSR",$J,GROUP)=$G(GRPCNT(GROUP))
     174 ;
     175 Q
     176 ;
     177RX ; - Sort by Rx
     178 D SORT("RX")
     179 Q
     180DR ; - Sort by Drug
     181 D SORT("DR")
     182 Q
     183ID ; - Sort by Issue Date
     184 D SORT("ID")
     185 Q
     186LF ; - Sort by Last Fill Date
     187 D SORT("LF")
     188 Q
     189 ;
     190SORT(FIELD) ; - Sort entries by FIELD
     191 I PSOSRTBY=FIELD S PSORDER=$S(PSORDER="A":"D",1:"A")
     192 E  S PSOSRTBY=FIELD,PSORDER="A"
     193 D REF
     194 Q
     195 ;
     196REF ; - Screen Refresh
     197 W ?52,"Please wait..." D INIT,HDR S VALMBCK="R"
     198 Q
     199GS ; - Group by Status
     200 W ?52,"Please wait..." S PSOSTSGP=$S($G(PSOSTSGP):0,1:1) D INIT,HDR S VALMBCK="R"
     201 Q
     202 ;
     203SIG ; - Display SIG
     204 W ?52,"Please wait..." S PSOSIGDP=$S($G(PSOSIGDP):0,1:1) D INIT,HDR S VALMBCK="R"
     205 I 'PSOSIGDP S VALMBG=VALMBG\2
     206 I PSOSIGDP S VALMBG=VALMBG*2-1
     207 S:VALMBG>(VALMCNT-10) VALMBG=VALMCNT-10 S:VALMBG<1 VALMBG=1
     208 Q
     209 ;
     210PI ; - Patient Information
     211 D EN^PSOLMPI S VALMBCK="R"
     212 Q
     213 ;
     214CV ; - Change View
     215 D LST^PSOPMPPF(SITE,DUZ) W !?52,"Please wait..." D INIT,HDR
     216 S VALMBG=1,VALMBCK="R"
     217 Q
     218 ;
     219SEL ; - Process selection of one entry
     220 N PSOSEL,TYPE,XQORM,ORD,TITLE
     221 S PSOSEL=+$P($P(Y(1),"^",4),"=",2) I 'PSOSEL S VALMSG="Invalid selection!",VALMBCK="R" Q
     222 S TYPE=$O(^TMP("PSOPMP0",$J,PSOSEL,0)) I TYPE="" S VALMSG="Invalid selection!",VALMBCK="R" Q
     223 S ORD=$G(^TMP("PSOPMP0",$J,PSOSEL,TYPE))
     224 I 'ORD S VALMSG="Invalid selection!",VALMBCK="R" Q
     225 S TITLE=VALM("TITLE")
     226 ;
     227 ; - Regular prescription
     228 I TYPE="RX" D
     229 . N PSOVDA,PSOSAVE,DA,PS
     230 . S (PSOVDA,DA)=ORD,PS="REJECT"
     231 . N LINE,TITLE,PSODFN D DP^PSORXVW
     232 ;
     233 ; - Pending Order
     234 I TYPE="PEN" D
     235 . N PSOACTOV,OR0
     236 . S OR0=^PS(52.41,ORD,0),PSOACTOV=""
     237 . N LINE,TITLE D PENHDR^PSOPMP1(PSODFN),DSPL^PSOORFI1
     238 ;
     239 ; - Pending Order
     240 I TYPE="NVA" D
     241 . N LINE,TITLE D EN^PSONVAVW(PSODFN,ORD)
     242 ;
     243 S VALMBCK="R",VALM("TITLE")=TITLE
     244 Q
     245 ;
     246EXIT ;
     247 K ^TMP("PSOPMP0",$J),^TMP("PSOPMPSR",$J)
     248 Q
     249 ;
     250HELP Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPMP1.m

    r613 r623  
    1 PSOPMP1 ;BIRM/MFR - Patient Medication Profile - Listmanager ;04/28/05
    2         ;;7.0;OUTPATIENT PHARMACY;**260,285,281**;DEC 1997;Build 41
    3         ;Reference to ^PSDRUG("AQ" supported by IA 3165
    4         ;Reference to EN1^GMRADPT supported by IA 10099
    5         ;Reference to ^PSXOPUTL supported by IA 2200
    6         ;
    7 VIDEO() ; - Changes the Video Attributes for the list
    8         ;
    9         ; - Highlighting the PRESCRIPTION line if SIG is displayed
    10         I $G(PSOSIGDP) D
    11         . F I=1:1:LINE D
    12         . . I $D(HIGHLN(I)) D CNTRL^VALM10(I,1,80,IOINHI,IOINORM)
    13         ;
    14         ; - Highlighting the group lines (order type and status)
    15         I $D(GRPLN) D
    16         . S LN=0 F I=1:1 S LN=$O(GRPLN(LN)) Q:'LN  D
    17         . . S LBL=GRPLN(LN),POS=41-($L(LBL)\2)
    18         . . D CNTRL^VALM10(LN,1,POS-1,IOUON_IOINHI,IOINORM)
    19         . . D CNTRL^VALM10(LN,POS,$L(LBL),IORVON_IOINHI,IORVOFF_IOINORM)
    20         . . D CNTRL^VALM10(LN,POS+$L(LBL),81-POS-$L(LBL),IOUON_IOINHI,IOINORM)
    21         Q
    22         ;
    23 SETHDR()        ; - Displays the Header Line
    24         N HDR,ORD,POS
    25         ;
    26         ; - Line 1
    27         S $E(HDR,57)="ISSUE",$E(HDR,66)="LAST",$E(HDR,74)="REF",$E(HDR,78)="DAY"
    28         S $E(HDR,81)="" D INSTR^VALM1(IORVON_HDR_IOINORM,1,6)
    29         ; - Line 2
    30         S HDR="  #",$E(HDR,5)="Rx#",$E(HDR,19)="DRUG",$E(HDR,49)="QTY",$E(HDR,53)="ST"
    31         S $E(HDR,57)="DATE",$E(HDR,66)="FILL",$E(HDR,74)="REM",$E(HDR,78)="SUP"
    32         S $E(HDR,81)="" D INSTR^VALM1(IORVON_HDR_IOINORM,1,7)
    33         S ORD=$S(PSORDER="A":"[^]",1:"[v]")
    34         S:PSOSRTBY="RX" POS=9 S:PSOSRTBY="DR" POS=24 S:PSOSRTBY="ID" POS=61 S:PSOSRTBY="LF" POS=70
    35         D INSTR^VALM1(IOINHI_IORVON_ORD_IOINORM,POS,7)
    36         Q
    37         ;
    38 SETSIG(TYPE,RX,LINE,DFN)        ; Set the SIG line
    39         N FSIG,L,X,DIWL,DIWR
    40         ;
    41         I TYPE="N" D  Q
    42         . K ^UTILITY($J,"W")
    43         . S X=$$SCHED^PSONVNEW($$GET1^DIQ(55.05,RX_","_DFN,4)),DIWL=1,DIWR=71 D ^DIWP
    44         . F L=1:1 Q:'$D(^UTILITY($J,"W",1,L))  D
    45         . . S X="" S:L=1 $E(X,5)="SIG:" S $E(X,10)=^UTILITY($J,"W",1,L,0)
    46         . . S LINE=LINE+1,^TMP("PSOPMP0",$J,LINE,0)=X
    47         ;
    48         D FSIG^PSOUTLA(TYPE,+RX,71)
    49         F L=1:1 Q:'$D(FSIG(L))  D
    50         . S X="" S:L=1 $E(X,5)="SIG:" S $E(X,10)=FSIG(L)
    51         . S LINE=LINE+1,^TMP("PSOPMP0",$J,LINE,0)=X
    52         Q
    53         ;
    54 GROUP(LBL,CNT,LINE)     ; Sets a group delimiter line
    55         N X,POS
    56         S LBL=LBL_$S(PSORDCNT:" ("_CNT_" order"_$S(CNT>1:"s",1:"")_")",1:"")
    57         S POS=41-($L(LBL)\2)
    58         S X="",$P(X," ",81)="",$E(X,POS,POS-1+$L(LBL))=LBL
    59         S LINE=LINE+1,^TMP("PSOPMP0",$J,LINE,0)=X,GRPLN(LINE)=LBL
    60         Q
    61         ;
    62 PENHDR(DFN)     ; Sets the Header in the ^TMP("PSOHDR",$J) global for displaying individual Pending Order
    63         N VADM,WT,HT,PSOERR,GMRA
    64         K ^TMP("PSOHDR",$J) D ^VADPT,ADD^VADPT
    65         S ^TMP("PSOHDR",$J,1,0)=VADM(1),^TMP("PSOHDR",$J,2,0)=$P(VADM(2),"^",2)
    66         S ^TMP("PSOHDR",$J,3,0)=$P(VADM(3),"^",2),^TMP("PSOHDR",$J,4,0)=VADM(4),^TMP("PSOHDR",$J,5,0)=$P(VADM(5),"^",2)
    67         S POERR=1 D RE^PSODEM K PSOERR
    68         S ^TMP("PSOHDR",$J,6,0)=$S(+$P(WT,"^",8):$J($P(WT,"^",9),6)_" ("_$P(WT,"^")_")",1:"_______ (______)")
    69         S ^TMP("PSOHDR",$J,7,0)=$S($P(HT,"^",8):$J($P(HT,"^",9),6)_" ("_$P(HT,"^")_")",1:"_______ (______)") K VM,WT,HT S PSOHD=7
    70         S GMRA="0^0^111" D EN1^GMRADPT S ^TMP("PSOHDR",$J,8,0)=+$G(GMRAL)
    71         Q
    72         ;
    73 FILTER(RX)      ; - Filter Rx's that should not be displayed
    74         I $$GET1^DIQ(52,RX,26,"I")<PSOEXPDC Q 1
    75         I $$GET1^DIQ(52,RX,26.1,"I"),$$GET1^DIQ(52,RX,26.1,"I")<PSOEXPDC,$$GET1^DIQ(52,RX,100,"I")>11,$$GET1^DIQ(52,RX,100,"I")'=16 Q 1
    76         I $$GET1^DIQ(52,RX,100,"I")=""!($$GET1^DIQ(52,RX,100,"I")=13) Q 1
    77         I $$GET1^DIQ(52,RX,.01)="" Q 1
    78         Q 0
    79         ;
    80 STSINFO(RX)     ; Returns the Rx Status MNEMONIC^NAME
    81         ; Input: RX - Prescription IEN (#52)
    82         ;Output: Status Mnemonic ("A","DC",etc.)^Status Name ("ACTIVE","DISCONTINUED",etc.)
    83         ;
    84         N STS
    85         I '$D(^PSRX(RX,"STA")) Q ""
    86         S STS=$$GET1^DIQ(52,RX,100,"I")
    87         I STS=0 Q:$$GET1^DIQ(52,RX,26,"I")>DT PSOSTSEQ("A") Q PSOSTSEQ("E")
    88         I STS=1 Q PSOSTSEQ("N")
    89         I STS=3 Q PSOSTSEQ("H")
    90         I STS=5 Q PSOSTSEQ("S")
    91         I STS=11 Q PSOSTSEQ("E")
    92         I STS=12 Q PSOSTSEQ("DC")
    93         I STS=14 Q PSOSTSEQ("DP")
    94         I STS=15 Q PSOSTSEQ("DE")
    95         I STS=16 Q PSOSTSEQ("PH")
    96         Q "99^UNKNOWN^??"
    97         ;
    98 ISSDT(IEN,TYPE) ; Returns the Rx ISSUE DATE formatted MM-DD-YY
    99         ;Input: RX   - PrescrXiption IEN (#52)
    100         ;       TYPE - "R":Regular Rx, "P":Pending order
    101         N ISSDT
    102         I TYPE="R" S ISSDT=$$GET1^DIQ(52,IEN,1,"I")
    103         I TYPE="P" S ISSDT=$$GET1^DIQ(52.41,IEN,6,"I")
    104         I ISSDT'="" S ISSDT=ISSDT\1
    105         ;
    106         Q (ISSDT_"^"_$$DAT(ISSDT,"-"))
    107         ;
    108 LSTFD(RX)       ; Returns the Rx LAST FILL DATE formatted MM-DD-YY[R], where [R] = Returned to Stock
    109         ;Input: RX  - Prescription IEN (#52)
    110         N LSTFD,RTSTK,RFL
    111         S LSTFD=$$GET1^DIQ(52,RX,101,"I")\1 I LSTFD="" Q ""
    112         I '$$LSTRFL^PSOBPSU1(RX) D
    113         . I $$GET1^DIQ(52,RX,32.1,"I") S RTSTK="R"
    114         E  S RFL=0 F  S RFL=$O(^PSRX(RX,1,RFL)) Q:'RFL  D
    115         . I $$RXFLDT^PSOBPSUT(RX,RFL)'=LSTFD Q
    116         . I $$GET1^DIQ(52.1,RFL_","_RX,14,"I") S RTSTK="R"
    117         ;
    118         Q (LSTFD_"^"_$$DAT(LSTFD,"-")_$G(RTSTK))
    119         ;
    120 REFREM(RX)      ; - Returns the number of refills remaining
    121         N REFREM,RFL
    122         S REFREM=+$$GET1^DIQ(52,RX,9)
    123         F RFL=0:1 S RFL=$O(^PSRX(RX,1,RFL)) Q:'RFL  S REFREM=REFREM-1
    124         Q $S(REFREM<0:0,1:REFREM)
    125         ;
    126         ;
    127 DAT(FMDT,SEP,Y4)        ; - Formats FM dates to MM/DD/YY (SEP: Separator:"/","-",etc...)
    128         ;Input: (r) FMDT - Fileman Date
    129         ;       (r) SEP  - Separator
    130         ;       (o) Y4   - 4 digits year flag
    131         I $G(FMDT)="" Q ""
    132         I '$E(FMDT,6,7)!'$E(FMDT,4,7) Q $$UP^XLFSTR($TR($$FMTE^XLFDT(FMDT)," ","-"))
    133         Q ($E(FMDT,4,5)_SEP_$E(FMDT,6,7)_SEP_$S($G(Y4):$E(FMDT,1,3)+1700,1:$E(FMDT,2,3)))
    134         ;
    135 COPAY(RX)       ; Returns "$" is Rx has a copay and "" if not
    136         Q $S($D(^PSRX(RX,"IB")):"$",1:"")
    137         ;
    138 CMOP(DRUG,RX)   ; Returns the CMOP indicator (">", "T", etc)
    139         N CMOP,X,DA,PSXZ
    140         S CMOP="" I $D(^PSDRUG("AQ",DRUG)) S CMOP=">"
    141         I $G(RX) S DA=RX D ^PSXOPUTL I $G(PSXZ(PSXZ("L")))=0!($G(PSXZ(PSXZ("L")))=2) S CMOP="T"
    142         Q CMOP
    143         ;
    144 ALLERGY(LINE,DFN,POS)   ; also called from PSONVAVW & PSOPMP0
    145         ; Input:  LINE - (r) text to concatenate allergy information to
    146         ;         DFN - (r) patient IEN used for ^GMRADTP
    147         ;         POS - (o) position # to include text
    148         ;Output: LINE - modified text
    149         N ALLERGY,PSONOAL
    150         S (PSONOAL,ALLERGY)=""
    151         D EN1^GMRADPT
    152         I GMRAL S ALLERGY="<A>"
    153         E  D ALLERGY^PSOORUT2 I PSONOAL'="" S ALLERGY="<NO ALLERGY ASSESSMENT>"
    154         S ALLERGY=IORVON_ALLERGY_IORVOFF_IOINORM
    155         I '$G(POS) S POS=80-$L(ALLERGY)
    156         S LINE=$$SETSTR^VALM1(ALLERGY,LINE,POS,80)
    157         Q LINE
     1PSOPMP1 ;BIRM/MFR - Patient Medication Profile - Listmanager ;04/28/05
     2 ;;7.0;OUTPATIENT PHARMACY;**260**;DEC 1997;Build 84
     3 ;Reference to ^PSDRUG("AQ" supported by IA 3165
     4 ;Reference to EN1^GMRADPT supported by IA 10099
     5 ;Reference to ^PSXOPUTL supported by IA 2200
     6 ;
     7VIDEO() ; - Changes the Video Attributes for the list
     8 ;
     9 ; - Highlighting the PRESCRIPTION line if SIG is displayed
     10 I $G(PSOSIGDP) D
     11 . F I=1:1:LINE D
     12 . . I $D(HIGHLN(I)) D CNTRL^VALM10(I,1,80,IOINHI,IOINORM)
     13 ;
     14 ; - Highlighting the group lines (order type and status)
     15 I $D(GRPLN) D
     16 . S LN=0 F I=1:1 S LN=$O(GRPLN(LN)) Q:'LN  D
     17 . . S LBL=GRPLN(LN),POS=41-($L(LBL)\2)
     18 . . D CNTRL^VALM10(LN,1,POS-1,IOUON_IOINHI,IOINORM)
     19 . . D CNTRL^VALM10(LN,POS,$L(LBL),IORVON_IOINHI,IOINORM)
     20 . . D CNTRL^VALM10(LN,POS+$L(LBL),81-POS-$L(LBL),IOUON_IOINHI,IOINORM)
     21 Q
     22 ;
     23SETHDR() ; - Displays the Header Line
     24 N HDR,ORD,POS
     25 ;
     26 ; - Line 1
     27 S $E(HDR,57)="ISSUE",$E(HDR,66)="LAST",$E(HDR,74)="REF",$E(HDR,78)="DAY"
     28 S $E(HDR,81)="" D INSTR^VALM1(IORVON_HDR_IOINORM,1,6)
     29 ; - Line 2
     30 S HDR="  #",$E(HDR,5)="Rx#",$E(HDR,19)="DRUG",$E(HDR,49)="QTY",$E(HDR,53)="ST"
     31 S $E(HDR,57)="DATE",$E(HDR,66)="FILL",$E(HDR,74)="REM",$E(HDR,78)="SUP"
     32 S $E(HDR,81)="" D INSTR^VALM1(IORVON_HDR_IOINORM,1,7)
     33 S ORD=$S(PSORDER="A":"[^]",1:"[v]")
     34 S:PSOSRTBY="RX" POS=9 S:PSOSRTBY="DR" POS=24 S:PSOSRTBY="ID" POS=61 S:PSOSRTBY="LF" POS=70
     35 D INSTR^VALM1(IOINHI_IORVON_ORD_IOINORM,POS,7)
     36 Q
     37 ;
     38SETSIG(TYPE,RX,LINE,DFN) ; Set the SIG line
     39 N FSIG,L,X,DIWL,DIWR
     40 ;
     41 I TYPE="N" D  Q
     42 . K ^UTILITY($J,"W")
     43 . S X=$$SCHED^PSONVNEW($$GET1^DIQ(55.05,RX_","_DFN,4)),DIWL=1,DIWR=71 D ^DIWP
     44 . F L=1:1 Q:'$D(^UTILITY($J,"W",1,L))  D
     45 . . S X="" S:L=1 $E(X,5)="SIG:" S $E(X,10)=^UTILITY($J,"W",1,L,0)
     46 . . S LINE=LINE+1,^TMP("PSOPMP0",$J,LINE,0)=X
     47 ;
     48 D FSIG^PSOUTLA(TYPE,+RX,71)
     49 F L=1:1 Q:'$D(FSIG(L))  D
     50 . S X="" S:L=1 $E(X,5)="SIG:" S $E(X,10)=FSIG(L)
     51 . S LINE=LINE+1,^TMP("PSOPMP0",$J,LINE,0)=X
     52 Q
     53 ;
     54GROUP(LBL,CNT,LINE) ; Sets a group delimiter line
     55 N X,POS
     56 S LBL=LBL_$S(PSORDCNT:" ("_CNT_" order"_$S(CNT>1:"s",1:"")_")",1:"")
     57 S POS=41-($L(LBL)\2)
     58 S X="",$P(X," ",81)="",$E(X,POS,POS-1+$L(LBL))=LBL
     59 S LINE=LINE+1,^TMP("PSOPMP0",$J,LINE,0)=X,GRPLN(LINE)=LBL
     60 Q
     61 ;
     62PENHDR(DFN) ; Sets the Header in the ^TMP("PSOHDR",$J) global for displaying individual Pending Order
     63 N VADM,WT,HT,PSOERR,GMRA
     64 K ^TMP("PSOHDR",$J) D ^VADPT,ADD^VADPT
     65 S ^TMP("PSOHDR",$J,1,0)=VADM(1),^TMP("PSOHDR",$J,2,0)=$P(VADM(2),"^",2)
     66 S ^TMP("PSOHDR",$J,3,0)=$P(VADM(3),"^",2),^TMP("PSOHDR",$J,4,0)=VADM(4),^TMP("PSOHDR",$J,5,0)=$P(VADM(5),"^",2)
     67 S POERR=1 D RE^PSODEM K PSOERR
     68 S ^TMP("PSOHDR",$J,6,0)=$S(+$P(WT,"^",8):$J($P(WT,"^",9),6)_" ("_$P(WT,"^")_")",1:"_______ (______)")
     69 S ^TMP("PSOHDR",$J,7,0)=$S($P(HT,"^",8):$J($P(HT,"^",9),6)_" ("_$P(HT,"^")_")",1:"_______ (______)") K VM,WT,HT S PSOHD=7
     70 S GMRA="0^0^111" D EN1^GMRADPT S ^TMP("PSOHDR",$J,8,0)=+$G(GMRAL)
     71 Q
     72 ;
     73FILTER(RX) ; - Filter Rx's that should not be displayed
     74 I $$GET1^DIQ(52,RX,26,"I")<PSOEXPDC Q 1
     75 I $$GET1^DIQ(52,RX,26.1,"I")<PSOEXPDC,$$GET1^DIQ(52,RX,100,"I")>11,$$GET1^DIQ(52,RX,100,"I")'=16 Q 1
     76 I $$GET1^DIQ(52,RX,100,"I")=""!($$GET1^DIQ(52,RX,100,"I")=13) Q 1
     77 I $$GET1^DIQ(52,RX,.01)="" Q 1
     78 Q 0
     79 ;
     80STSINFO(RX) ; Returns the Rx Status MNEMONIC^NAME
     81 ; Input: RX - Prescription IEN (#52)
     82 ;Output: Status Mnemonic ("A","DC",etc.)^Status Name ("ACTIVE","DISCONTINUED",etc.)
     83 ;
     84 N STS
     85 I '$D(^PSRX(RX,"STA")) Q ""
     86 S STS=$$GET1^DIQ(52,RX,100,"I")
     87 I STS=0 Q:$$GET1^DIQ(52,RX,26,"I")>DT PSOSTSEQ("A") Q PSOSTSEQ("E")
     88 I STS=1 Q PSOSTSEQ("N")
     89 I STS=3 Q PSOSTSEQ("H")
     90 I STS=5 Q PSOSTSEQ("S")
     91 I STS=11 Q PSOSTSEQ("E")
     92 I STS=12 Q PSOSTSEQ("DC")
     93 I STS=14 Q PSOSTSEQ("DP")
     94 I STS=15 Q PSOSTSEQ("DE")
     95 I STS=16 Q PSOSTSEQ("PH")
     96 Q "99^UNKNOWN^??"
     97 ;
     98ISSDT(IEN,TYPE) ; Returns the Rx ISSUE DATE formatted MM-DD-YY
     99 ;Input: RX   - PrescrXiption IEN (#52)
     100 ;       TYPE - "R":Regular Rx, "P":Pending order
     101 N ISSDT
     102 I TYPE="R" S ISSDT=$$GET1^DIQ(52,IEN,1,"I")
     103 I TYPE="P" S ISSDT=$$GET1^DIQ(52.41,IEN,6,"I")
     104 I ISSDT'="" S ISSDT=ISSDT\1
     105 ;
     106 Q (ISSDT_"^"_$$DAT(ISSDT,"-"))
     107 ;
     108LSTFD(RX) ; Returns the Rx LAST FILL DATE formatted MM-DD-YY[R], where [R] = Returned to Stock
     109 ;Input: RX  - Prescription IEN (#52)
     110 N LSTFD,RTSTK,RFL
     111 S LSTFD=$$GET1^DIQ(52,RX,101,"I")\1 I LSTFD="" Q ""
     112 I '$$LSTRFL^PSOBPSU1(RX) D
     113 . I $$GET1^DIQ(52,RX,32.1,"I") S RTSTK="R"
     114 E  S RFL=0 F  S RFL=$O(^PSRX(RX,1,RFL)) Q:'RFL  D
     115 . I $$RXFLDT^PSOBPSUT(RX,RFL)'=LSTFD Q
     116 . I $$GET1^DIQ(52.1,RFL_","_RX,14,"I") S RTSTK="R"
     117 ;
     118 Q (LSTFD_"^"_$$DAT(LSTFD,"-")_$G(RTSTK))
     119 ;
     120REFREM(RX) ; - Returns the number of refills remaining
     121 N REFREM,RFL
     122 S REFREM=+$$GET1^DIQ(52,RX,9)
     123 F RFL=0:1 S RFL=$O(^PSRX(RX,1,RFL)) Q:'RFL  S REFREM=REFREM-1
     124 Q $S(REFREM<0:0,1:REFREM)
     125 ;
     126 ;
     127DAT(FMDT,SEP,Y4) ; - Formats FM dates to MM/DD/YY (SEP: Separator:"/","-",etc...)
     128 ;Input: (r) FMDT - Fileman Date
     129 ;       (r) SEP  - Separator
     130 ;       (o) Y4   - 4 digits year flag
     131 I $G(FMDT)="" Q ""
     132 I '$E(FMDT,6,7)!'$E(FMDT,4,7) Q $$UP^XLFSTR($TR($$FMTE^XLFDT(FMDT)," ","-"))
     133 Q ($E(FMDT,4,5)_SEP_$E(FMDT,6,7)_SEP_$S($G(Y4):$E(FMDT,1,3)+1700,1:$E(FMDT,2,3)))
     134 ;
     135COPAY(RX) ; Returns "$" is Rx has a copay and "" if not
     136 Q $S($D(^PSRX(RX,"IB")):"$",1:"")
     137 ;
     138CMOP(DRUG,RX) ; Returns the CMOP indicator (">", "T", etc)
     139 N CMOP,X,DA,PSXZ
     140 S CMOP="" I $D(^PSDRUG("AQ",DRUG)) S CMOP=">"
     141 I $G(RX) S DA=RX D ^PSXOPUTL I $G(PSXZ(PSXZ("L")))=0!($G(PSXZ(PSXZ("L")))=2) S CMOP="T"
     142 Q CMOP
     143 ;
     144ALLERGY(LINE,DFN,POS) ; also called from PSONVAVW & PSOPMP0
     145 ; Input:  LINE - (r) text to concatenate allergy information to
     146 ;         DFN - (r) patient IEN used for ^GMRADTP
     147 ;         POS - (o) position # to include text
     148 ;Output: LINE - modified text
     149 N ALLERGY,PSONOAL
     150 S (PSONOAL,ALLERGY)=""
     151 D EN1^GMRADPT
     152 I GMRAL S ALLERGY="<A>"
     153 E  D ALLERGY^PSOORUT2 I PSONOAL'="" S ALLERGY="<NO ALLERGY ASSESSMENT>"
     154 S ALLERGY=IORVON_ALLERGY_IOINORM
     155 I '$G(POS) S POS=80-$L(ALLERGY)
     156 S LINE=$$SETSTR^VALM1(ALLERGY,LINE,POS,80)
     157 Q LINE

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPTPST.m

    r613 r623  
    1 PSOPTPST        ;BIR/DSD - Post Patient Selection Action ;07/25/96
    2         ;;7.0;OUTPATIENT PHARMACY;**7,71,88,146,157,143,225**;DEC 1997;Build 29
    3         ;External reference to SDCO22 supported by DBIA 1579
    4         ;External reference to IBE(350.1,"ANEW" supported by DBIA 592
    5         ;External reference to PS(55 supported by DBIA 2228
    6         ;External reference to IBARX supported by DBIA 125
    7         ;External reference to $$GETSHAD^DGUTL3 supported by DBIA 4462
    8 START   S PSOQFLG=0
    9         D GET ; Gets data from Patient file
    10         D DEAD G:PSOQFLG END ; Checks to see if patient still alive
    11         G:$G(PSOFROM("PTLKUP"))']"" END ; skips questions if not called by RX data entry
    12         D INP G:PSOQFLG END ;Checks to see if inpatient and whether to continue
    13         D CNH G:PSOQFLG END ; Checks to see if nursing home patient
    14         D ELIG ; Checks eligibility
    15         D:$G(DUZ("AG"))="V" COPAY ; Deals with copay
    16         D ADDRESS ; Display address information
    17         D:$G(^PS(55,PSODFN,1))]"" REMARKS ; Displays narrative about patient
    18 END     D EOJ
    19         Q
    20         ;----------------------------------------------------------
    21 GET     K DIC,DR,DIQ S DIC=2,DA=PSODFN,DR=".1;.172;.351;.361;148",DIQ="PSOPTPST"
    22         D EN^DIQ1 K DIC,DA,DR,DIQ
    23         Q
    24         ;
    25 DEAD    ;
    26         I $G(PSOPTPST(2,PSODFN,.351))]"" S (PSODEATH,PSOQFLG)=1 S SSN=$P(^DPT(PSODFN,0),"^",9) W !?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_") DIED "_PSOPTPST(2,PSODFN,.351),! S:$G(POERR) POERR("DEAD")=1 D
    27         .;I '$O(^PS(55,PSODFN,"P","A",DT)) Q
    28         .S ACOM="Date of Death "_PSOPTPST(2,PSODFN,.351)_".",ZTRTN="CAN^PSOCAN3",ZTDESC="Outpatient Pharmacy Autocancel Due to Death of Patient",ZTSAVE("ACOM")="",ZTSAVE("PSODFN")="",ZTSAVE("PSODEATH")=""
    29         .S ZTIO="",PSOCLC=DUZ,ZTSAVE("PSOCLC")="",ZTDTH=$H D ^%ZTLOAD K ACOM,ZTSK,PSODEATH
    30         Q
    31         ;
    32 INP     I '$G(PSOXFLG),'$G(PSOFIN),$G(PSOPTPST(2,PSODFN,.1))]"" S PSOXFLG=1,SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")" K SSN
    33         I $G(PSOPTPST(2,PSODFN,.1))]"" W !?10,$C(7),"Patient is an Inpatient on Ward "_PSOPTPST(2,PSODFN,.1)_" !!" D DIR
    34         Q
    35 TPB     ;
    36         N PSOTPSSN
    37         I '$G(PSODFN) Q
    38         I $D(^PS(52.91,PSODFN,0)) I '$P(^PS(52.91,PSODFN,0),"^",3)!($P(^(0),"^",3)>DT) D
    39         .S PSOTPSSN=$P($G(^DPT(PSODFN,0)),"^",9)
    40         .I $G(PSOFIN)!($G(MEDP)) D
    41         ..I $G(MEDP) W !!?10,$C(7),$P($G(^DPT(PSODFN,0)),"^")_" ("_$E(PSOTPSSN,1,3)_"-"_$E(PSOTPSSN,4,5)_"-"_$E(PSOTPSSN,6,9)_")" Q
    42         ..I $G(PSOFIN) I $G(PSOPTPST(2,PSODFN,148))="YES"!($G(PSOPTPST(2,PSODFN,.1))]"") W !!?10,$C(7),$P($G(^DPT(PSODFN,0)),"^")_" ("_$E(PSOTPSSN,1,3)_"-"_$E(PSOTPSSN,4,5)_"-"_$E(PSOTPSSN,6,9)_")"
    43         .I '$G(PSOFIN),'$G(MEDP) W !
    44         .W !?10,"Patient is eligible for the Transitional Pharmacy Benefit!!" D DIR
    45         Q
    46         ;
    47 CNH     I $G(MEDP),$G(PSOPTPST(2,PSODFN,148))="YES",$G(PSOPTPST(2,PSODFN,.1))']"" D
    48         .S SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")" K SSN
    49         K PSORX("CNH") I $G(PSOPTPST(2,PSODFN,148))="YES" W !?10,$C(7),"Patient is in a Contract Nursing Home !!" D DIR S:'$G(PSOQFLG) PSORX("CNH")=1
    50         Q
    51         ;
    52 ELIG    I $G(PSOPTPST(2,PSODFN,.361))]"",$G(PSOPTPST(2,PSODFN,.172))'="I" W !,"MAS Eligibility: "_PSOPTPST(2,PSODFN,.361)
    53         S DFN=PSODFN D RE^PSODEM
    54         Q
    55         ;
    56 COPAY   K PSOBILL,PSOCPAY S DFN=PSODFN,(X,PSOPTIB)=$P($G(^PS(59,+PSOSITE,"IB")),"^")_"^"_PSODFN D XTYPE^IBARX
    57         I '$D(^IBE(350.1,"ANEW",+PSOPTIB,1,1)) S PSOQFLG=1 D  K PSOPTIB Q
    58         .W $C(7),!!,"There is a problem with the IB SERVICE/SECTION entry in your Pharmacy Site File."
    59         .W !,"You will not be able to enter any new prescriptions until this is corrected!",!
    60         S (ACTYP,BL)="",(PSOBILL,PSOCPAY)=0 I +Y=-1 W !,"ERROR IN COPAY ELIGIBILITY ENCOUNTERED." G COPAYX
    61 COPAY1  S ACTYP=$O(Y(ACTYP)) G:'ACTYP COPAYX F III=0:0 S BL=$O(Y(ACTYP,BL)) Q:BL=""  I BL>0 S PSOBILL=BL,PSOCPAY=BL_"^"_Y(ACTYP,BL)
    62         G COPAY1
    63 COPAYX  K X,Y,ACTYP,BL,III,PSOPTIB
    64         ;I $G(PSOBILL)
    65         D QST
    66         Q
    67         ;
    68 ADDRESS N DFN S (DA,DFN)=PSODFN D ADD^VADPT K DFN,PSOI,DA,DR
    69         Q
    70         ;
    71 REMARKS S PSOX=$G(^PS(55,PSODFN,1)) W !!,?5
    72         F PSOI=1:1 Q:$P(PSOX," ",PSOI,900)=""  W:$X+$L($P(PSOX," ",PSOI))+$L(" ")>IOM !?5 W $P(PSOX," ",PSOI)_" "
    73         K PSOX,PSOI
    74         Q
    75         ;
    76 DIR     K DIR W !
    77         S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do You Want To Continue" D ^DIR K DIR
    78         S:'Y PSOQFLG=1 K X,Y,DIRUT,DTOUT,DUOUT
    79         Q
    80         ;
    81 EOJ     K:PSOQFLG PSORX("CNH") K PSOPTPST,VAPA
    82         Q
    83 QST     ;Ask new questions for Copay
    84         I '$$DT^PSOMLLDT Q
    85         K PSOIBQS
    86         I $G(PSOBILL) S PSOIBQS(PSODFN,"SC")=""
    87         S PSOIBQS(PSODFN,"SC>50")=""
    88         I +$P($$CVEDT^DGCV(PSODFN),"^",3) S PSOIBQS(PSODFN,"CV")=""
    89         I $$AO^SDCO22(PSODFN) S PSOIBQS(PSODFN,"VEH")=""
    90         I $$IR^SDCO22(PSODFN) S PSOIBQS(PSODFN,"RAD")=""
    91         I $$EC^SDCO22(PSODFN) S PSOIBQS(PSODFN,"PGW")=""
    92         I $L($T(GETSHAD^DGUTL3)) S:$$GETSHAD^DGUTL3(PSODFN)=1 PSOIBQS(PSODFN,"SHAD")=""
    93         I $P($$GETSTAT^DGMSTAPI(PSODFN),"^",2)="Y" S PSOIBQS(PSODFN,"MST")=""
    94         I $T(GETCUR^DGNTAPI)]"" N PSONCP,PSONCPX S PSONCPX=$$GETCUR^DGNTAPI(PSODFN,"PSONCP") I $P($G(PSONCP("IND")),"^")="Y" S PSOIBQS(PSODFN,"HNC")=""
    95         Q
     1PSOPTPST ;BIR/DSD - Post Patient Selection Action ;07/25/96
     2 ;;7.0;OUTPATIENT PHARMACY;**7,71,88,146,157,143**;DEC 1997
     3 ;External reference to SDCO22 supported by DBIA 1579
     4 ;External reference to IBE(350.1,"ANEW" supported by DBIA 592
     5 ;External reference to PS(55 supported by DBIA 2228
     6 ;External reference to IBARX supported by DBIA 125
     7START S PSOQFLG=0
     8 D GET ; Gets data from Patient file
     9 D DEAD G:PSOQFLG END ; Checks to see if patient still alive
     10 G:$G(PSOFROM("PTLKUP"))']"" END ; skips questions if not called by RX data entry
     11 D INP G:PSOQFLG END ;Checks to see if inpatient and whether to continue
     12 D CNH G:PSOQFLG END ; Checks to see if nursing home patient
     13 D ELIG ; Checks eligibility
     14 D:$G(DUZ("AG"))="V" COPAY ; Deals with copay
     15 D ADDRESS ; Display address information
     16 D:$G(^PS(55,PSODFN,1))]"" REMARKS ; Displays narrative about patient
     17END D EOJ
     18 Q
     19 ;----------------------------------------------------------
     20GET K DIC,DR,DIQ S DIC=2,DA=PSODFN,DR=".1;.172;.351;.361;148",DIQ="PSOPTPST"
     21 D EN^DIQ1 K DIC,DA,DR,DIQ
     22 Q
     23 ;
     24DEAD ;
     25 I $G(PSOPTPST(2,PSODFN,.351))]"" S (PSODEATH,PSOQFLG)=1 S SSN=$P(^DPT(PSODFN,0),"^",9) W !?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_") DIED "_PSOPTPST(2,PSODFN,.351),! S:$G(POERR) POERR("DEAD")=1 D
     26 .;I '$O(^PS(55,PSODFN,"P","A",DT)) Q
     27 .S ACOM="Date of Death "_PSOPTPST(2,PSODFN,.351)_".",ZTRTN="CAN^PSOCAN3",ZTDESC="Outpatient Pharmacy Autocancel Due to Death of Patient",ZTSAVE("ACOM")="",ZTSAVE("PSODFN")="",ZTSAVE("PSODEATH")=""
     28 .S ZTIO="",PSOCLC=DUZ,ZTSAVE("PSOCLC")="",ZTDTH=$H D ^%ZTLOAD K ACOM,ZTSK,PSODEATH
     29 Q
     30 ;
     31INP I '$G(PSOXFLG),'$G(PSOFIN),$G(PSOPTPST(2,PSODFN,.1))]"" S PSOXFLG=1,SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")" K SSN
     32 I $G(PSOPTPST(2,PSODFN,.1))]"" W !?10,$C(7),"Patient is an Inpatient on Ward "_PSOPTPST(2,PSODFN,.1)_" !!" D DIR
     33 Q
     34TPB ;
     35 N PSOTPSSN
     36 I '$G(PSODFN) Q
     37 I $D(^PS(52.91,PSODFN,0)) I '$P(^PS(52.91,PSODFN,0),"^",3)!($P(^(0),"^",3)>DT) D
     38 .S PSOTPSSN=$P($G(^DPT(PSODFN,0)),"^",9)
     39 .I $G(PSOFIN)!($G(MEDP)) D
     40 ..I $G(MEDP) W !!?10,$C(7),$P($G(^DPT(PSODFN,0)),"^")_" ("_$E(PSOTPSSN,1,3)_"-"_$E(PSOTPSSN,4,5)_"-"_$E(PSOTPSSN,6,9)_")" Q
     41 ..I $G(PSOFIN) I $G(PSOPTPST(2,PSODFN,148))="YES"!($G(PSOPTPST(2,PSODFN,.1))]"") W !!?10,$C(7),$P($G(^DPT(PSODFN,0)),"^")_" ("_$E(PSOTPSSN,1,3)_"-"_$E(PSOTPSSN,4,5)_"-"_$E(PSOTPSSN,6,9)_")"
     42 .I '$G(PSOFIN),'$G(MEDP) W !
     43 .W !?10,"Patient is eligible for the Transitional Pharmacy Benefit!!" D DIR
     44 Q
     45 ;
     46CNH I $G(MEDP),$G(PSOPTPST(2,PSODFN,148))="YES",$G(PSOPTPST(2,PSODFN,.1))']"" D
     47 .S SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")" K SSN
     48 K PSORX("CNH") I $G(PSOPTPST(2,PSODFN,148))="YES" W !?10,$C(7),"Patient is in a Contract Nursing Home !!" D DIR S:'$G(PSOQFLG) PSORX("CNH")=1
     49 Q
     50 ;
     51ELIG I $G(PSOPTPST(2,PSODFN,.361))]"",$G(PSOPTPST(2,PSODFN,.172))'="I" W !,"MAS Eligibility: "_PSOPTPST(2,PSODFN,.361)
     52 S DFN=PSODFN D RE^PSODEM
     53 Q
     54 ;
     55COPAY K PSOBILL,PSOCPAY S DFN=PSODFN,(X,PSOPTIB)=$P($G(^PS(59,+PSOSITE,"IB")),"^")_"^"_PSODFN D XTYPE^IBARX
     56 I '$D(^IBE(350.1,"ANEW",+PSOPTIB,1,1)) S PSOQFLG=1 D  K PSOPTIB Q
     57 .W $C(7),!!,"There is a problem with the IB SERVICE/SECTION entry in your Pharmacy Site File."
     58 .W !,"You will not be able to enter any new prescriptions until this is corrected!",!
     59 S (ACTYP,BL)="",(PSOBILL,PSOCPAY)=0 I +Y=-1 W !,"ERROR IN COPAY ELIGIBILITY ENCOUNTERED." G COPAYX
     60COPAY1 S ACTYP=$O(Y(ACTYP)) G:'ACTYP COPAYX F III=0:0 S BL=$O(Y(ACTYP,BL)) Q:BL=""  I BL>0 S PSOBILL=BL,PSOCPAY=BL_"^"_Y(ACTYP,BL)
     61 G COPAY1
     62COPAYX K X,Y,ACTYP,BL,III,PSOPTIB
     63 ;I $G(PSOBILL)
     64 D QST
     65 Q
     66 ;
     67ADDRESS N DFN S (DA,DFN)=PSODFN D ADD^VADPT K DFN,PSOI,DA,DR
     68 Q
     69 ;
     70REMARKS S PSOX=$G(^PS(55,PSODFN,1)) W !!,?5
     71 F PSOI=1:1 Q:$P(PSOX," ",PSOI,900)=""  W:$X+$L($P(PSOX," ",PSOI))+$L(" ")>IOM !?5 W $P(PSOX," ",PSOI)_" "
     72 K PSOX,PSOI
     73 Q
     74 ;
     75DIR K DIR W !
     76 S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do You Want To Continue" D ^DIR K DIR
     77 S:'Y PSOQFLG=1 K X,Y,DIRUT,DTOUT,DUOUT
     78 Q
     79 ;
     80EOJ K:PSOQFLG PSORX("CNH") K PSOPTPST,VAPA
     81 Q
     82QST ;Ask new questions for Copay
     83 I '$$DT^PSOMLLDT Q
     84 K PSOIBQS
     85 I $G(PSOBILL) S PSOIBQS(PSODFN,"SC")=""
     86 S PSOIBQS(PSODFN,"SC>50")=""
     87 I +$P($$CVEDT^DGCV(PSODFN),"^",3) S PSOIBQS(PSODFN,"CV")=""
     88 I $$AO^SDCO22(PSODFN) S PSOIBQS(PSODFN,"VEH")=""
     89 I $$IR^SDCO22(PSODFN) S PSOIBQS(PSODFN,"RAD")=""
     90 I $$EC^SDCO22(PSODFN) S PSOIBQS(PSODFN,"PGW")=""
     91 I $P($$GETSTAT^DGMSTAPI(PSODFN),"^",2)="Y" S PSOIBQS(PSODFN,"MST")=""
     92 I $T(GETCUR^DGNTAPI)]"" N PSONCP,PSONCPX S PSONCPX=$$GETCUR^DGNTAPI(PSODFN,"PSONCP") I $P($G(PSONCP("IND")),"^")="Y" S PSOIBQS(PSODFN,"HNC")=""
     93 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOR52.m

    r613 r623  
    1 PSOR52  ;IHS/DSD/JCM - Files refill entries in prescription file ;03/10/93
    2         ;;7.0;OUTPATIENT PHARMACY;**10,22,27,181,148,201,260,281**;DEC 1997;Build 41
    3         ;Reference to ^PSDRUG supported by DBIA 221
    4         ;Reference to PSOUL^PSSLOCK supported by DBIA 2789
    5         ;Reference SWSTAT^IBBAPI supported by DBIA 4663
    6         ;Reference SAVNDC^PSSNDCUT supported by DBIA 4707
    7         ; This routine is responsible for the actual
    8         ; filling of the refill prescription.
    9         ;---------------------------------------------------------   
    10 EN(PSOX)        ;Entry Point
    11 START   ;
    12         D:$D(XRTL) T0^%ZOSV ; Start RT monitor
    13         D INIT G:PSOR52("QFLG") END
    14         D FILE
    15         D DIK
    16         S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; Stop RT Monitor
    17         D FINISH
    18 END     D EOJ
    19         Q
    20         ;---------------------------------------------------------
    21         ;
    22 INIT    ;
    23         S PSOR52("QFLG")=0
    24         S PSOX("QTY")=$P(PSOX("RX0"),"^",7),PSOX("DAYS SUPPLY")=$P(PSOX("RX0"),"^",8)
    25         S:$G(^PSDRUG($P(PSOX("RX0"),"^",6),660))]"" PSOX("COST")=$P(^PSDRUG($P(PSOX("RX0"),"^",6),660),"^",6)
    26         D NOW^%DTC S PSOX("LOGIN DATE")=$E(%,1,7)
    27         S X1=PSOX("FILL DATE"),X2=PSOX("DAYS SUPPLY")-10\1 D C^%DTC S PSOX1=X
    28         S X1=$P(PSOX("RX2"),"^",2)
    29         S X2=PSOX("DAYS SUPPLY")*(PSOX("NUMBER")+1)-10\1
    30         D C^%DTC S PSOX2=X
    31         S PSOX("NEXT POSSIBLE REFILL")=$S(PSOX1>PSOX2:PSOX1,1:PSOX2)
    32         K X,PSOX1,PSOX2
    33         S (PSOX("LAST DISPENSED DATE"),PSOX("DISPENSED DATE"))=PSOX("FILL DATE")
    34         I PSOX("FILL DATE")>$S($G(PSOX("LOGIN DATE")):$E(PSOX("LOGIN DATE"),1,7),1:DT),$P(PSOPAR,"^",6) D
    35         .S PSOX("OLD MAIL/WINDOW")=$S($G(PSOX("MAIL/WINDOW"))]"":PSOX("MAIL/WINDOW"),1:"MAIL"),PSOX("MAIL/WINDOW")="M"
    36         I $P(PSOX("RX2"),"^",12)]"" S PSOX("GENERIC PROVIDER")=$P(PSOX("RX2"),"^",12)
    37         S PSOX("PROVIDER")=$P(PSOX("RX0"),"^",4)
    38         S:'$D(PSOX("CLERK CODE")) PSOX("CLERK CODE")=DUZ
    39         S PSOX("DAW")=$$GETDAW^PSODAWUT(+PSOX("IRXN")),PSOX("NDC")=$$GETNDC^PSSNDCUT($P(PSOX("RX0"),"^",6))
    40 INITX   Q
    41         ;
    42 FILE    ;     
    43         ;L +^PSRX(PSOX("IRXN")):0
    44         I '$D(^PSRX(PSOX("IRXN"),1,0)) S ^(0)="^52.1DA^1^1"
    45         E  S ^PSRX(PSOX("IRXN"),1,0)=$P(^PSRX(PSOX("IRXN"),1,0),"^",1,2)_"^"_PSOX("NUMBER")_"^"_($P(^(0),"^",4)+1)
    46         F PSOX1=1:1 S PSOR52=$P($T(DD+PSOX1),";;",2,4) Q:PSOR52=""  K PSOY S PSOY=$P(PSOR52,";;") I $D(@PSOY) S $P(PSOR52(PSOX("IRXN"),1,PSOX("NUMBER"),$P(PSOR52,";;",2)),"^",$P(PSOR52,";;",3))=@PSOY
    47         K PSOX1,PSOY
    48         S PSOX1="" F  S PSOX1=$O(PSOR52(PSOX("IRXN"),1,PSOX("NUMBER"),PSOX1)) Q:PSOX1=""  S ^PSRX(PSOX("IRXN"),1,PSOX("NUMBER"),PSOX1)=$G(PSOR52(PSOX("IRXN"),1,PSOX("NUMBER"),PSOX1))
    49         K PSOX1
    50         S:PSOX("STA")=6 $P(^PSRX(PSOX("IRXN"),"STA"),"^")=0
    51         S $P(^PSRX(PSOX("IRXN"),3),"^",1,2)=PSOX("LAST DISPENSED DATE")_"^"_PSOX("NEXT POSSIBLE REFILL")
    52         S $P(^PSRX(PSOX("IRXN"),3),"^",4)=PSOX("LAST REFILL DATE")
    53         I $D(PSOX("METHOD OF PICK-UP")),PSOX("FILL DATE")'>DT S $P(^PSRX(PSOX("IRXN"),"MP"),"^")=PSOX("METHOD OF PICK-UP")
    54         D:$$SWSTAT^IBBAPI() GACT^PSOPFSU0(PSOX("IRXN"),PSOX("NUMBER"))
    55         ;L -^PSRX(PSOX("IRXN"))
    56         Q
    57         ;
    58 DIK     ;
    59         K DIK,DA
    60         S DIK="^PSRX(",DA=PSOX("IRXN") D IX1^DIK K DIK
    61         I +$G(^PSRX(DA,"IB")),$P(^PSRX(DA,1,PSOX("NUMBER"),0),"^",2)="W" S ^PSRX("ACP",$P(^PSRX(DA,0),"^",2),$P(^PSRX(DA,1,PSOX("NUMBER"),0),"^"),PSOX("NUMBER"),DA)="" K DA
    62         D:$T(EN^PSOHDR)]"" EN^PSOHDR("PREF",PSOX("IRXN"))
    63         Q
    64         ;
    65 FINISH  ;
    66         I $G(PSOX("QS"))="S" D  G FINISHX
    67         . S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=PSOX("NUMBER")
    68         . D SUS^PSORXL K DA
    69         ;
    70         ; - Previous ePharmacy Refill was Deleted and a new one is being entered
    71         I '$$SUBMIT^PSOBPSUT(PSOX("IRXN"),PSOX("NUMBER")),$$STATUS^PSOBPSUT(PSOX("IRXN"),PSOX("NUMBER"))'="" D
    72         . D RETRXF^PSOREJU2(PSOX("IRXN"),PSOX("NUMBER"),1)
    73         ;
    74         I PSOX("FILL DATE")>$S($G(PSOX("LOGIN DATE")):$E(PSOX("LOGIN DATE"),1,7),1:DT),$P(PSOPAR,"^",6) D  G FINISHX
    75         .K PSOXRXFL I $D(RXFL(PSOX("IRXN"))) S PSOXRXFL=$G(RXFL(PSOX("IRXN")))
    76         .S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=PSOX("NUMBER")
    77         .D SUS^PSORXL K DA
    78         .I $G(PSOXRXFL)'="" S RXFL(PSOX("IRXN"))=$G(PSOXRXFL) K PSOXRXFL
    79         ;
    80         ; - Calling ECME for claims generation and transmission / REJECT handling
    81         N ACTION,PSOERX,PSOERF
    82         S PSOERX=PSOX("IRXN"),PSOERF=PSOX("NUMBER")
    83         I $$SUBMIT^PSOBPSUT(PSOERX,PSOERF) D  I ACTION="Q"!(ACTION="^") Q
    84         . S ACTION="" D ECMESND^PSOBPSU1(PSOERX,PSOERF,PSOX("FILL DATE"),"RF")
    85         . I $$FIND^PSOREJUT(PSOERX,PSOERF) D
    86         . . S ACTION=$$HDLG^PSOREJU1(PSOERX,PSOERF,"79,88","OF","IOQ","Q")
    87         . I $$STATUS^PSOBPSUT(PSOERX,PSOERF)="E PAYABLE" D
    88         . . D SAVNDC^PSSNDCUT(+$$GET1^DIQ(52,PSOERX,6,"I"),$G(PSOSITE),$$GETNDC^PSONDCUT(PSOERX,PSOERF))
    89         ;
    90         I $G(PSOX("QS"))="Q" D  G FINISHX
    91         . I $G(PPL),$L(PPL_PSOX("IRXN")_",")>240 D TRI^PSOBBC D Q^PSORXL K PPL,RXFL
    92         . S RXFL(PSOX("IRXN"))=PSOX("NUMBER")
    93         . I $G(PPL) S PPL=PPL_PSOX("IRXN")_","
    94         . E  S PPL=PSOX("IRXN")_","
    95         ;
    96         I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSOX("IRXN")_",",RXFL(PSOX("IRXN"))=PSOX("NUMBER") G FINISHX
    97         F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
    98         I $L(PSORX("PSOL",PSOX2))+$L(PSOX("IRXN"))<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSOX("IRXN")_","
    99         E  S PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_","
    100         S RXFL(PSOX("IRXN"))=PSOX("NUMBER")
    101         ;
    102 FINISHX ;
    103         I $G(PSORX("MAIL/WINDOW"))["W" S BINGCRT=1,BINGRTE="W",BBFLG=1 D BBRX^PSORN52C
    104         K PSOX1,PSOX2
    105         Q
    106 EOJ     ;
    107         I $D(PSOX("OLD MAIL/WINDOW")) S PSOX("MAIL/WINDOW")=PSOX("OLD MAIL/WINDOW") K PSOX("OLD MAIL/WINDOW")
    108         S DA=$O(^PS(52.41,"ARF",PSOX("IRXN"),0)) I DA D  S DIK="^PS(52.41," D ^DIK
    109         .S PSORFKL=DA D PSOUL^PSSLOCK(PSORFKL_"S") K PSORFKL
    110         K PSOR52,DA,DIK
    111         Q
    112         ;
    113 DD      ;rx data nodes
    114         ;;PSOX("PROVIDER");;0;;17
    115         ;;PSOX("QTY");;0;;4
    116         ;;PSOX("DAYS SUPPLY");;0;;10
    117         ;;PSOX("MAIL/WINDOW");;0;;2
    118         ;;PSOX("REMARKS");;0;;3
    119         ;;PSOX("CLERK CODE");;0;;7
    120         ;;PSOX("COST");;0;;11
    121         ;;PSOSITE;;0;;9
    122         ;;PSOX("LOGIN DATE");;0;;8
    123         ;;PSOX("FILL DATE");;0;;1
    124         ;;PSOX("PHARMACIST");;0;;5
    125         ;;PSOX("LOT #");;0;;6
    126         ;;PSOX("DISPENSED DATE");;0;;19
    127         ;;PSOX("NDC");;1;;3
    128         ;;PSOX("DAW");;EPH;;1
    129         ;;PSOX("MANUFACTURER");;0;;14
    130         ;;PSOX("EXPIRATION DATE");;0;;15
    131         ;;PSOX("GENERIC PROVIDER");;1;;1
    132         ;;PSOX("RELEASED DATE/TIME");;0;;18
     1PSOR52 ;IHS/DSD/JCM - Files refill entries in prescription file ;03/10/93
     2 ;;7.0;OUTPATIENT PHARMACY;**10,22,27,181,148,201,260**;DEC 1997;Build 84
     3 ;Reference to ^PSDRUG supported by DBIA 221
     4 ;Reference to PSOUL^PSSLOCK supported by DBIA 2789
     5 ;Reference SWSTAT^IBBAPI supported by DBIA 4663
     6 ;Reference SAVNDC^PSSNDCUT supported by DBIA 4707
     7 ; This routine is responsible for the actual
     8 ; filling of the refill prescription.
     9 ;---------------------------------------------------------   
     10EN(PSOX) ;Entry Point
     11START ;
     12 D:$D(XRTL) T0^%ZOSV ; Start RT monitor
     13 D INIT G:PSOR52("QFLG") END
     14 D FILE
     15 D DIK
     16 S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; Stop RT Monitor
     17 D FINISH
     18END D EOJ
     19 Q
     20 ;---------------------------------------------------------
     21 ;
     22INIT ;
     23 S PSOR52("QFLG")=0
     24 S PSOX("QTY")=$P(PSOX("RX0"),"^",7),PSOX("DAYS SUPPLY")=$P(PSOX("RX0"),"^",8)
     25 S:$G(^PSDRUG($P(PSOX("RX0"),"^",6),660))]"" PSOX("COST")=$P(^PSDRUG($P(PSOX("RX0"),"^",6),660),"^",6)
     26 D NOW^%DTC S PSOX("LOGIN DATE")=$E(%,1,7)
     27 S X1=PSOX("FILL DATE"),X2=PSOX("DAYS SUPPLY")-10\1 D C^%DTC S PSOX1=X
     28 S X1=$P(PSOX("RX2"),"^",2)
     29 S X2=PSOX("DAYS SUPPLY")*(PSOX("NUMBER")+1)-10\1
     30 D C^%DTC S PSOX2=X
     31 S PSOX("NEXT POSSIBLE REFILL")=$S(PSOX1>PSOX2:PSOX1,1:PSOX2)
     32 K X,PSOX1,PSOX2
     33 S (PSOX("LAST DISPENSED DATE"),PSOX("DISPENSED DATE"))=PSOX("FILL DATE")
     34 I PSOX("FILL DATE")>$S($G(PSOX("LOGIN DATE")):$E(PSOX("LOGIN DATE"),1,7),1:DT),$P(PSOPAR,"^",6) D
     35 .S PSOX("OLD MAIL/WINDOW")=$S($G(PSOX("MAIL/WINDOW"))]"":PSOX("MAIL/WINDOW"),1:"MAIL"),PSOX("MAIL/WINDOW")="M"
     36 I $P(PSOX("RX2"),"^",12)]"" S PSOX("GENERIC PROVIDER")=$P(PSOX("RX2"),"^",12)
     37 S PSOX("PROVIDER")=$P(PSOX("RX0"),"^",4)
     38 S:'$D(PSOX("CLERK CODE")) PSOX("CLERK CODE")=DUZ
     39 S PSOX("DAW")=$$GETDAW^PSODAWUT(+PSOX("IRXN")),PSOX("NDC")=$$GETNDC^PSSNDCUT($P(PSOX("RX0"),"^",6))
     40INITX Q
     41 ;
     42FILE ;     
     43 ;L +^PSRX(PSOX("IRXN")):0
     44 I '$D(^PSRX(PSOX("IRXN"),1,0)) S ^(0)="^52.1DA^1^1"
     45 E  S ^PSRX(PSOX("IRXN"),1,0)=$P(^PSRX(PSOX("IRXN"),1,0),"^",1,2)_"^"_PSOX("NUMBER")_"^"_($P(^(0),"^",4)+1)
     46 F PSOX1=1:1 S PSOR52=$P($T(DD+PSOX1),";;",2,4) Q:PSOR52=""  K PSOY S PSOY=$P(PSOR52,";;") I $D(@PSOY) S $P(PSOR52(PSOX("IRXN"),1,PSOX("NUMBER"),$P(PSOR52,";;",2)),"^",$P(PSOR52,";;",3))=@PSOY
     47 K PSOX1,PSOY
     48 S PSOX1="" F  S PSOX1=$O(PSOR52(PSOX("IRXN"),1,PSOX("NUMBER"),PSOX1)) Q:PSOX1=""  S ^PSRX(PSOX("IRXN"),1,PSOX("NUMBER"),PSOX1)=$G(PSOR52(PSOX("IRXN"),1,PSOX("NUMBER"),PSOX1))
     49 K PSOX1
     50 S:PSOX("STA")=6 $P(^PSRX(PSOX("IRXN"),"STA"),"^")=0
     51 S $P(^PSRX(PSOX("IRXN"),3),"^",1,2)=PSOX("LAST DISPENSED DATE")_"^"_PSOX("NEXT POSSIBLE REFILL")
     52 S $P(^PSRX(PSOX("IRXN"),3),"^",4)=PSOX("LAST REFILL DATE")
     53 I $D(PSOX("METHOD OF PICK-UP")),PSOX("FILL DATE")'>DT S $P(^PSRX(PSOX("IRXN"),"MP"),"^")=PSOX("METHOD OF PICK-UP")
     54 D:$$SWSTAT^IBBAPI() GACT^PSOPFSU0(PSOX("IRXN"),PSOX("NUMBER"))
     55 ;L -^PSRX(PSOX("IRXN"))
     56 Q
     57 ;
     58DIK ;
     59 K DIK,DA
     60 S DIK="^PSRX(",DA=PSOX("IRXN") D IX1^DIK K DIK
     61 I +$G(^PSRX(DA,"IB")),$P(^PSRX(DA,1,PSOX("NUMBER"),0),"^",2)="W" S ^PSRX("ACP",$P(^PSRX(DA,0),"^",2),$P(^PSRX(DA,1,PSOX("NUMBER"),0),"^"),PSOX("NUMBER"),DA)="" K DA
     62 D:$T(EN^PSOHDR)]"" EN^PSOHDR("PREF",PSOX("IRXN"))
     63 Q
     64 ;
     65FINISH ;
     66 I $G(PSOX("QS"))="S" D  G FINISHX
     67 . S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=PSOX("NUMBER")
     68 . D SUS^PSORXL K DA
     69 ;
     70 ; - Previous ePharmacy Refill was Deleted and a new one is being entered
     71 I '$$SUBMIT^PSOBPSUT(PSOX("IRXN"),PSOX("NUMBER")),$$STATUS^PSOBPSUT(PSOX("IRXN"),PSOX("NUMBER"))'="" D
     72 . D RETRXF^PSOREJU2(PSOX("IRXN"),PSOX("NUMBER"),1)
     73 ;
     74 I PSOX("FILL DATE")>$S($G(PSOX("LOGIN DATE")):$E(PSOX("LOGIN DATE"),1,7),1:DT),$P(PSOPAR,"^",6) D  G FINISHX
     75 .K PSOXRXFL I $D(RXFL(PSOX("IRXN"))) S PSOXRXFL=$G(RXFL(PSOX("IRXN")))
     76 .S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=PSOX("NUMBER")
     77 .D SUS^PSORXL K DA
     78 .I $G(PSOXRXFL)'="" S RXFL(PSOX("IRXN"))=$G(PSOXRXFL) K PSOXRXFL
     79 ;
     80 ; - Calling ECME for claims generation and transmission / REJECT handling
     81 N ACTION,PSOERX,PSOERF
     82 S PSOERX=PSOX("IRXN"),PSOERF=PSOX("NUMBER")
     83 I $$SUBMIT^PSOBPSUT(PSOERX,PSOERF) D  I ACTION="Q"!(ACTION="^") Q
     84 . S ACTION="" D ECMESND^PSOBPSU1(PSOERX,PSOERF,PSOX("FILL DATE"),"RF")
     85 . I $$FIND^PSOREJUT(PSOERX,PSOERF) D
     86 . . S ACTION=$$HDLG^PSOREJU1(PSOERX,PSOERF,"79,88","OF","IOQ","I")
     87 . I $$STATUS^PSOBPSUT(PSOERX,PSOERF)="E PAYABLE" D
     88 . . D SAVNDC^PSSNDCUT(+$$GET1^DIQ(52,PSOERX,6,"I"),$G(PSOSITE),$$GETNDC^PSONDCUT(PSOERX,PSOERF))
     89 ;
     90 I $G(PSOX("QS"))="Q" D  G FINISHX
     91 . I $G(PPL),$L(PPL_PSOX("IRXN")_",")>240 D TRI^PSOBBC D Q^PSORXL K PPL,RXFL
     92 . S RXFL(PSOX("IRXN"))=PSOX("NUMBER")
     93 . I $G(PPL) S PPL=PPL_PSOX("IRXN")_","
     94 . E  S PPL=PSOX("IRXN")_","
     95 ;
     96 I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSOX("IRXN")_",",RXFL(PSOX("IRXN"))=PSOX("NUMBER") G FINISHX
     97 F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
     98 I $L(PSORX("PSOL",PSOX2))+$L(PSOX("IRXN"))<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSOX("IRXN")_","
     99 E  S PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_","
     100 S RXFL(PSOX("IRXN"))=PSOX("NUMBER")
     101 ;
     102FINISHX ;
     103 I $G(PSORX("MAIL/WINDOW"))["W" S BINGCRT=1,BINGRTE="W",BBFLG=1 D BBRX^PSORN52C
     104 K PSOX1,PSOX2
     105 Q
     106EOJ ;
     107 I $D(PSOX("OLD MAIL/WINDOW")) S PSOX("MAIL/WINDOW")=PSOX("OLD MAIL/WINDOW") K PSOX("OLD MAIL/WINDOW")
     108 S DA=$O(^PS(52.41,"ARF",PSOX("IRXN"),0)) I DA D  S DIK="^PS(52.41," D ^DIK
     109 .S PSORFKL=DA D PSOUL^PSSLOCK(PSORFKL_"S") K PSORFKL
     110 K PSOR52,DA,DIK
     111 Q
     112 ;
     113DD ;rx data nodes
     114 ;;PSOX("PROVIDER");;0;;17
     115 ;;PSOX("QTY");;0;;4
     116 ;;PSOX("DAYS SUPPLY");;0;;10
     117 ;;PSOX("MAIL/WINDOW");;0;;2
     118 ;;PSOX("REMARKS");;0;;3
     119 ;;PSOX("CLERK CODE");;0;;7
     120 ;;PSOX("COST");;0;;11
     121 ;;PSOSITE;;0;;9
     122 ;;PSOX("LOGIN DATE");;0;;8
     123 ;;PSOX("FILL DATE");;0;;1
     124 ;;PSOX("PHARMACIST");;0;;5
     125 ;;PSOX("LOT #");;0;;6
     126 ;;PSOX("DISPENSED DATE");;0;;19
     127 ;;PSOX("NDC");;1;;3
     128 ;;PSOX("DAW");;EPH;;1
     129 ;;PSOX("MANUFACTURER");;0;;14
     130 ;;PSOX("EXPIRATION DATE");;0;;15
     131 ;;PSOX("GENERIC PROVIDER");;1;;1
     132 ;;PSOX("RELEASED DATE/TIME");;0;;18

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREF.m

    r613 r623  
    1 PSOREF  ;BIR/SAB-refill data entry ;12:03 PM  31 Dec 2008
    2         ;;7.0;OUTPATIENT PHARMACY;**1,23,27,36,46,78,130,131,148,206,208**;DEC 1997;Build 41;WorldVistA 30-Jan-08
    3         ;
    4         ;Modified from FOIA VISTA,
    5         ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    6         ;General Public License See attached copy of the License.
    7         ;
    8         ;This program is free software; you can redistribute it and/or modify
    9         ;it under the terms of the GNU General Public License as published by
    10         ;the Free Software Foundation; either version 2 of the License, or
    11         ;(at your option) any later version.
    12         ;
    13         ;This program is distributed in the hope that it will be useful,
    14         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    15         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    16         ;GNU General Public License for more details.
    17         ;
    18         ;You should have received a copy of the GNU General Public License along
    19         ;with this program; if not, write to the Free Software Foundation, Inc.,
    20         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    21         ;
    22         ;External reference to ^PSDRUG supported by DBIA 221
    23         ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
    24         ;
    25 EOJ     ;
    26         K PSOMSG,PSOREF,PSORX("BAR CODE"),PSOLIST,LFD,MAX,MIN,NODE,PS,PSOERR,REF,RF,RXO,RXN,RXP,RXS,SD,VAERR,PSORX("FILL DATE")
    27         D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
    28         Q
    29 OERR    ;single refil
    30         ;WVEHR ;begin p208
    31         S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
    32         D ^DIC K DIC ;vfah
    33         S PSOZAF=+Y ;vfah
    34         I $P($G(^PSRX(RXN,"OR1")),"^",5)=$G(PSOZAF) S VALMBCK="",VALMSG="Refill option is not available for Autofinshed Rxs" K PSOZAF Q  ;vfah
    35         ;WVEHR ;end p208
    36         I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2),,.VALMSG,.VALMBCK) Q
    37         I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!" Q
    38         I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial has already been requested!" Q
    39         I $D(RXRS($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="Rx is being pulled from suspense!" Q
    40         I $D(RXFL($P(PSOLST(ORN),"^",2))) S PTRX=$P(PSOLST(ORN),"^",2) D ^PSOCMOPT I '$G(PSOXFLAG) K PSOXFLAG S VALMBCK="",VALMSG="Fill already requested for CMOP!" Q
    41         K PSOXFLAG
    42         D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG Q
    43         N RXN K PSORX("FILL DATE") D FULL^VALM1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0,PSOREF("IRXN")=$P(PSOLST(ORN),"^",2),PSOREF("QFLG")=0
    44         K PSOID D ^PSOREF1 I PSOREF("DFLG") D EOJ S VALMBCK="R" Q
    45         D ^PSOREF0
    46         W ! K DIR,DIRUT,DTOUT,DUOUT S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DTOUT,DUOUT S PSORXED=1 D ^PSOBUILD,ACT^PSOORNE2 K PSORXED S VALMBCK="Q" D EOJ
    47         Q
    48 SPEED   ;speed refill
    49         K LST,PSORX("FILL DATE") N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
    50         K DIR,DIRUT S DIR(0)="Y",DIR("B")="NO",DIR("A")="Barcode Refill",DIR("?")="If you want to use a barcode reader to process refills enter 'Y'."
    51         D ^DIR K DIR,DUOUT,DTOUT I $D(DIRUT) S VALMBCK="" Q
    52         G BCREF:Y
    53         K PSOREF,PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" Q
    54         K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +Y S (ASK,SPEED,PSOOELSE)=1 D FULL^VALM1 S LST=Y D  G:$G(PSOREF("DFLG"))!($G(PSOREF("QFLG"))) SPEEDX
    55         .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""!($G(PSOREF("QFLG")))  S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52
    56         ..;WVEHR ;begin p208
    57         ..S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
    58         ..D ^DIC K DIC ;vfah
    59         ..S PSOZAF=+Y ;vfah
    60         ..I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"OR1")),"^",5)=$G(PSOZAF) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" is an Autofinish,Rx and can not be refilled" K PSOZAF D PAUSE^VALM1 Q  ;vfah
    61         ..;WVEHR ;end p208
    62         ..I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Reject!" K DIR D PAUSE^VALM1 Q
    63         ..D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")),! D PAUSE^VALM1 K PSOMSG Q
    64         ..K PSOMSG I $D(RXRP($P(PSOLST(ORN),"^",2))) W $C(7),!!,"A Reprint Label has been requested!" D ULK D PAUSE^VALM1 Q
    65         ..I $D(RXPR($P(PSOLST(ORN),"^",2))) W $C(7),!!,"A Partial has already been requested!" D ULK D PAUSE^VALM1 Q
    66         ..I $D(RXFL($P(PSOLST(ORN),"^",2))) S PTRX=$P(PSOLST(ORN),"^",2) D ^PSOCMOPT I '$G(PSOXFLAG) K PSOXFLAG W $C(7),!!,"A CMOP fill has already been requested for Rx "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^") D ULK D PAUSE^VALM1 Q
    67         ..K PSOXFLAG I $D(RXRS($P(PSOLST(ORN),"^",2))) W $C(7),!!,"Rx is being pulled from suspense!" D ULK D PAUSE^VALM1 Q
    68         ..I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")=11 D  D ULK Q
    69         ...W $C(7),!!?5,"RX "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^")_" is in an EXPIRED status." W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
    70         ..S PSOREF("IRXN")=$P(PSOLST(ORN),"^",2) I ASK D ^PSOREF1 S ASK=0 D:$G(PSOREF("QFLG")) ULK Q:$G(PSOREF("QFLG"))
    71         ..N RXN D FULL^VALM1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0,PSOREF("IRXN")=$P(PSOLST(ORN),"^",2)
    72         ..I PSOREF("DFLG") D EOJ S VALMBCK="R" Q
    73         ..D ^PSOREF0 D ULK
    74         S:'$G(PSOOELSE) VALMBCK=""
    75         S PSORXED=1 D ^PSOBUILD,BLD^PSOORUT1
    76 SPEEDX  K PSOREF,PSORX("BAR CODE"),PSOLIST,LFD,MAX,MIN,NODE,PS,PSOERR,REF,RF,RXO,RXN,RXP,RXS,SD,VAERR,PSORX("FILL DATE")
    77         K LST,SPEED,PSORXED,PSOREF,PSOFDR,PSOOELSE,ASK S:'$D(VALMBCK) VALMBCK="R"
    78         K PSORX("FILL DATE"),PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
    79         Q
    80 BCREF   ;barcode refills
    81         K LST,DIR,DIRUT,DUOUT,DTOUT D FULL^VALM1
    82 ASK     S DIR(0)="FO^5:245^K:X'?3N1""-""1.N X",DIR("A")="WAND BARCODE"
    83         S DIR("?",1)="Wand the barcoded number of the prescription to be processed."
    84         S DIR("?",2)="The number should be of the form NNN-NNNNNN",DIR("?",3)="where the number before the dash is your station number."
    85         S DIR("?")="Enter ""^"", or a RETURN to quit."
    86         D ^DIR I $D(DUOUT)!($D(DTOUT)) S VALMBCK="" G BCREFX
    87         I $G(X)']"",'$G(LST) S VALMBCK="" G BCREFX
    88         I $D(DIRUT),+$G(LST) D  S VALMBCK="R" G BCREFX
    89         .K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT
    90         .S (BCREF,ASK,SPEED,PSOOELSE)=1 D FULL^VALM1 D
    91         ..F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""!($G(PSOREF("QFLG")))  S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52
    92         ...I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Reject!" K DIR D PAUSE^VALM1 Q
    93         ...D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")),! D PAUSE^VALM1 K PSOMSG Q
    94         ...K PSOMSG I $D(RXRP($P(PSOLST(ORN),"^",2))) W $C(7),!!,"A Reprint Label has been requested for Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),! D ULK D PAUSE^VALM1 Q
    95         ...I $D(RXPR($P(PSOLST(ORN),"^",2))) W $C(7),!!,"A Partial has already been requested for Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),! D ULK D PAUSE^VALM1 Q
    96         ...I $D(RXFL($P(PSOLST(ORN),"^",2))) S PTRX=$P(PSOLST(ORN),"^",2) D ^PSOCMOPT I '$G(PSOXFLAG) K PSOXFLAG W $C(7),!!,"A CMOP fill has already been requested for Rx "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^") D ULK D PAUSE^VALM1 Q
    97         ...K PSOXFLAG I $D(RXRS($P(PSOLST(ORN),"^",2))) W $C(7),!!,"Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")_" is being pulled from suspense!" D ULK D PAUSE^VALM1 Q
    98         ...S PSOREF("IRXN")=$P(PSOLST(ORN),"^",2) I ASK D ^PSOREF1 S ASK=0 D:$G(PSOREF("DFLG")) ULK Q:$G(PSOREF("DFLG"))
    99         ...N RXN D FULL^VALM1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0,PSOREF("IRXN")=$P(PSOLST(ORN),"^",2)
    100         ...I PSOREF("DFLG") D EOJ S VALMBCK="R" Q
    101         ...D ^PSOREF0 D ULK
    102         F RX=1:1:PSOCNT I $P(PSOLST(RX),"^",2)=$P(X,"-",2) D  Q
    103         .I $D(PSOBBC(RX)) Q
    104         .S LST=$G(LST)_RX_",",PSOBBC(RX)=1
    105         G ASK
    106 BCREFX  K BCREF,ASK,LST,SPEED,RX,PSOBBC,DIR,DIRUT,PSORXED,PSOREF,PSOFDR,PSOOELSE S PSORXED=1 D ^PSOBUILD,BLD^PSOORUT1
    107         S VALMBCK="R" Q
    108 REFILL(PLACER)  ;passes flag to CPRS for front door refill request
    109         ;PLACER=PHARMACY NUMBER
    110         N PSORFRM,PSOLC,PSODRG,PSODRUG0,RXN,ST,PSODEA
    111         I $G(PLACER)["S"!('$G(PLACER)) Q "-1^Not a Valid Outpatient Medication Order."
    112         S RXN=PLACER I '$D(^PSRX(RXN,0)) Q "-1^Not a Valid Outpatient Medication Order."
    113         S RX0=^PSRX(RXN,0),PSODRG=$P(^PSRX(RXN,0),"^",6),ST=+^("STA"),PSODRUG0=^PSDRUG(PSODRG,0),PSODEA=$P($G(^(0)),"^",3),DIV=$P(^PSRX(RXN,2),"^",9),PSORFRM=$P(RX0,"^",9)
    114         I PSODEA["2" Q "0^Schedule 2 Drug. Order cannot be refilled."
    115         I '$P($G(^PSRX(RXN,"OR1")),"^"),'$P($G(^PSDRUG(PSODRG,2)),"^") Q "0^Cannot Refill. Drug not matched to a Pharmacy Orderable Item."
    116         I '$P($G(^PSRX(RXN,"OR1")),"^"),$P($G(^PSDRUG(PSODRG,2)),"^") S $P(^PSRX(RXN,"OR1"),"^")=$P(^PSDRUG(PSODRG,2),"^")
    117         S CLOZPAT=$S($P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1":1,1:0)
    118         I 'CLOZPAT I PSODEA["A"&(PSODEA'["B")!(PSODEA["F")!(PSODEA[1)!(PSODEA[2) Q "0^"_$S(PSODEA["A":"Narcotic Drug. ",1:"")_"Order Non-Refillable."
    119         K CLOZPAT I DT>$P($G(^PSRX(RXN,2)),"^",6) Q "0^Non-Refillable.  Prescription has Expired."
    120         I $P(^PSRX(RXN,3),"^",2)>$P(^PSRX(RXN,2),"^",6) Q "0^Next Refill Date Past Expiration Date.  New Order Required."
    121         I '$P($G(^PS(59,DIV,1)),"^",11),$G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) Q "0^Inactive Drug, Non Refillable."
    122         I ST Q "0^Prescription is in a Non-Refillable Status."
    123         I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" Q "0^Cannot Refill. Drug No Longer Used by Outpatient Pharmacy."
    124         S PSORFRM=$P(RX0,"^",9) F PSOJ=0:0 S PSOJ=$O(^PSRX(RXN,1,PSOJ)) Q:'PSOJ  S PSORFRM=PSORFRM-1
    125         I PSORFRM<1 Q "0^No Refills remaining. New Med order required."
    126         I $P(^PSRX(RXN,3),"^"),DT=$P(^PSRX(RXN,3),"^") Q "0^Can't Refill, Fill Date already exists for "_$E($P(^PSRX(RXN,3),"^"),4,5)_"/"_$E($P(^PSRX(RXN,3),"^"),6,7)_"/"_$E($P(^PSRX(RXN,3),"^"),2,3)_"."
    127         I $P(^PSRX(RXN,3),"^"),DT<$P(^PSRX(RXN,3),"^") Q "0^Can't Refill, later Refill Date already exists for "_$E($P(^PSRX(RXN,3),"^"),4,5)_"/"_$E($P(^PSRX(RXN,3),"^"),6,7)_"/"_$E($P(^PSRX(RXN,3),"^"),2,3)_"."
    128         I $O(^PS(52.41,"ARF",RXN,0)) Q "0^Pending Refill Request already exists."
    129         Q 1
    130         ;
    131 ULK     D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
    132         Q
     1PSOREF ;BIR/SAB-refill data entry ;1/27/07  13:31
     2 ;;7.0;OUTPATIENT PHARMACY;**1,23,27,36,46,78,130,131,148,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ;External reference to ^PSDRUG supported by DBIA 221
     17 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
     18 ;
     19EOJ ;
     20 K PSOMSG,PSOREF,PSORX("BAR CODE"),PSOLIST,LFD,MAX,MIN,NODE,PS,PSOERR,REF,RF,RXO,RXN,RXP,RXS,SD,VAERR,PSORX("FILL DATE")
     21 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
     22 Q
     23OERR ;single refil
     24 ;
     25 S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
     26 D ^DIC K DIC ;vfah
     27 S PSOZAF=+Y ;vfah
     28 I $P($G(^PSRX(RXN,"OR1")),"^",5)=$G(PSOZAF) S VALMBCK="",VALMSG="Refill option is not available for Autofinshed Rxs" K PSOZAF Q  ;vfah
     29 I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2),,.VALMSG,.VALMBCK) Q
     30 I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!" Q
     31 I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial has already been requested!" Q
     32 I $D(RXRS($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="Rx is being pulled from suspense!" Q
     33 I $D(RXFL($P(PSOLST(ORN),"^",2))) S PTRX=$P(PSOLST(ORN),"^",2) D ^PSOCMOPT I '$G(PSOXFLAG) K PSOXFLAG S VALMBCK="",VALMSG="Fill already requested for CMOP!" Q
     34 K PSOXFLAG
     35 D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG Q
     36 N RXN K PSORX("FILL DATE") D FULL^VALM1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0,PSOREF("IRXN")=$P(PSOLST(ORN),"^",2),PSOREF("QFLG")=0
     37 K PSOID D ^PSOREF1 I PSOREF("DFLG") D EOJ S VALMBCK="R" Q
     38 D ^PSOREF0
     39 W ! K DIR,DIRUT,DTOUT,DUOUT S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DTOUT,DUOUT S PSORXED=1 D ^PSOBUILD,ACT^PSOORNE2 K PSORXED S VALMBCK="Q" D EOJ
     40 Q
     41SPEED ;speed refill
     42 K LST,PSORX("FILL DATE") N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
     43 K DIR,DIRUT S DIR(0)="Y",DIR("B")="NO",DIR("A")="Barcode Refill",DIR("?")="If you want to use a barcode reader to process refills enter 'Y'."
     44 D ^DIR K DIR,DUOUT,DTOUT I $D(DIRUT) S VALMBCK="" Q
     45 G BCREF:Y
     46 K PSOREF,PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" Q
     47 K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +Y S (ASK,SPEED,PSOOELSE)=1 D FULL^VALM1 S LST=Y D  G:$G(PSOREF("DFLG"))!($G(PSOREF("QFLG"))) SPEEDX
     48 .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""!($G(PSOREF("QFLG")))  S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52
     49 ..S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
     50 ..D ^DIC K DIC ;vfah
     51 ..S PSOZAF=+Y ;vfah
     52 ..I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"OR1")),"^",5)=$G(PSOZAF) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" is an Autofinish,Rx and can not be refilled" K PSOZAF D PAUSE^VALM1 Q  ;vfah
     53 ..I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Reject!" K DIR D PAUSE^VALM1 Q
     54 ..D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")),! D PAUSE^VALM1 K PSOMSG Q
     55 ..K PSOMSG I $D(RXRP($P(PSOLST(ORN),"^",2))) W $C(7),!!,"A Reprint Label has been requested!" D ULK D PAUSE^VALM1 Q
     56 ..I $D(RXPR($P(PSOLST(ORN),"^",2))) W $C(7),!!,"A Partial has already been requested!" D ULK D PAUSE^VALM1 Q
     57 ..I $D(RXFL($P(PSOLST(ORN),"^",2))) S PTRX=$P(PSOLST(ORN),"^",2) D ^PSOCMOPT I '$G(PSOXFLAG) K PSOXFLAG W $C(7),!!,"A CMOP fill has already been requested for Rx "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^") D ULK D PAUSE^VALM1 Q
     58 ..K PSOXFLAG I $D(RXRS($P(PSOLST(ORN),"^",2))) W $C(7),!!,"Rx is being pulled from suspense!" D ULK D PAUSE^VALM1 Q
     59 ..I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")=11 D  D ULK Q
     60 ...W $C(7),!!?5,"RX "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^")_" is in an EXPIRED status." W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
     61 ..S PSOREF("IRXN")=$P(PSOLST(ORN),"^",2) I ASK D ^PSOREF1 S ASK=0 D:$G(PSOREF("QFLG")) ULK Q:$G(PSOREF("QFLG"))
     62 ..N RXN D FULL^VALM1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0,PSOREF("IRXN")=$P(PSOLST(ORN),"^",2)
     63 ..I PSOREF("DFLG") D EOJ S VALMBCK="R" Q
     64 ..D ^PSOREF0 D ULK
     65 S:'$G(PSOOELSE) VALMBCK=""
     66 S PSORXED=1 D ^PSOBUILD,BLD^PSOORUT1
     67SPEEDX K PSOREF,PSORX("BAR CODE"),PSOLIST,LFD,MAX,MIN,NODE,PS,PSOERR,REF,RF,RXO,RXN,RXP,RXS,SD,VAERR,PSORX("FILL DATE")
     68 K LST,SPEED,PSORXED,PSOREF,PSOFDR,PSOOELSE,ASK S:'$D(VALMBCK) VALMBCK="R"
     69 K PSORX("FILL DATE"),PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
     70 Q
     71BCREF ;barcode refills
     72 K LST,DIR,DIRUT,DUOUT,DTOUT D FULL^VALM1
     73ASK S DIR(0)="FO^5:245^K:X'?3N1""-""1.N X",DIR("A")="WAND BARCODE"
     74 S DIR("?",1)="Wand the barcoded number of the prescription to be processed."
     75 S DIR("?",2)="The number should be of the form NNN-NNNNNN",DIR("?",3)="where the number before the dash is your station number."
     76 S DIR("?")="Enter ""^"", or a RETURN to quit."
     77 D ^DIR I $D(DUOUT)!($D(DTOUT)) S VALMBCK="" G BCREFX
     78 I $G(X)']"",'$G(LST) S VALMBCK="" G BCREFX
     79 I $D(DIRUT),+$G(LST) D  S VALMBCK="R" G BCREFX
     80 .K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT
     81 .S (BCREF,ASK,SPEED,PSOOELSE)=1 D FULL^VALM1 D
     82 ..F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""!($G(PSOREF("QFLG")))  S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52
     83 ...I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Reject!" K DIR D PAUSE^VALM1 Q
     84 ...D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")),! D PAUSE^VALM1 K PSOMSG Q
     85 ...K PSOMSG I $D(RXRP($P(PSOLST(ORN),"^",2))) W $C(7),!!,"A Reprint Label has been requested for Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),! D ULK D PAUSE^VALM1 Q
     86 ...I $D(RXPR($P(PSOLST(ORN),"^",2))) W $C(7),!!,"A Partial has already been requested for Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),! D ULK D PAUSE^VALM1 Q
     87 ...I $D(RXFL($P(PSOLST(ORN),"^",2))) S PTRX=$P(PSOLST(ORN),"^",2) D ^PSOCMOPT I '$G(PSOXFLAG) K PSOXFLAG W $C(7),!!,"A CMOP fill has already been requested for Rx "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^") D ULK D PAUSE^VALM1 Q
     88 ...K PSOXFLAG I $D(RXRS($P(PSOLST(ORN),"^",2))) W $C(7),!!,"Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")_" is being pulled from suspense!" D ULK D PAUSE^VALM1 Q
     89 ...S PSOREF("IRXN")=$P(PSOLST(ORN),"^",2) I ASK D ^PSOREF1 S ASK=0 D:$G(PSOREF("DFLG")) ULK Q:$G(PSOREF("DFLG"))
     90 ...N RXN D FULL^VALM1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0,PSOREF("IRXN")=$P(PSOLST(ORN),"^",2)
     91 ...I PSOREF("DFLG") D EOJ S VALMBCK="R" Q
     92 ...D ^PSOREF0 D ULK
     93 F RX=1:1:PSOCNT I $P(PSOLST(RX),"^",2)=$P(X,"-",2) D  Q
     94 .I $D(PSOBBC(RX)) Q
     95 .S LST=$G(LST)_RX_",",PSOBBC(RX)=1
     96 G ASK
     97BCREFX K BCREF,ASK,LST,SPEED,RX,PSOBBC,DIR,DIRUT,PSORXED,PSOREF,PSOFDR,PSOOELSE S PSORXED=1 D ^PSOBUILD,BLD^PSOORUT1
     98 S VALMBCK="R" Q
     99REFILL(PLACER) ;passes flag to CPRS for front door refill request
     100 ;PLACER=PHARMACY NUMBER
     101 N PSORFRM,PSOLC,PSODRG,PSODRUG0,RXN,ST,PSODEA
     102 I $G(PLACER)["S"!('$G(PLACER)) Q "-1^Not a Valid Outpatient Medication Order."
     103 S RXN=PLACER I '$D(^PSRX(RXN,0)) Q "-1^Not a Valid Outpatient Medication Order."
     104 S RX0=^PSRX(RXN,0),PSODRG=$P(^PSRX(RXN,0),"^",6),ST=+^("STA"),PSODRUG0=^PSDRUG(PSODRG,0),PSODEA=$P($G(^(0)),"^",3),DIV=$P(^PSRX(RXN,2),"^",9),PSORFRM=$P(RX0,"^",9)
     105 I PSODEA["2" Q "0^Schedule 2 Drug. Order cannot be refilled."
     106 I '$P($G(^PSRX(RXN,"OR1")),"^"),'$P($G(^PSDRUG(PSODRG,2)),"^") Q "0^Cannot Refill. Drug not matched to a Pharmacy Orderable Item."
     107 I '$P($G(^PSRX(RXN,"OR1")),"^"),$P($G(^PSDRUG(PSODRG,2)),"^") S $P(^PSRX(RXN,"OR1"),"^")=$P(^PSDRUG(PSODRG,2),"^")
     108 S CLOZPAT=$S($P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1":1,1:0)
     109 I 'CLOZPAT I PSODEA["A"&(PSODEA'["B")!(PSODEA["F") Q "0^"_$S(PSODEA["F":"",1:"Narcotic Drug. ")_"Order Non-Refillable."
     110 K CLOZPAT I DT>$P($G(^PSRX(RXN,2)),"^",6) Q "0^Non-Refillable.  Prescription has Expired."
     111 I $P(^PSRX(RXN,3),"^",2)>$P(^PSRX(RXN,2),"^",6) Q "0^Next Refill Date Past Expiration Date.  New Order Required."
     112 I '$P($G(^PS(59,DIV,1)),"^",11),$G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) Q "0^Inactive Drug, Non Refillable."
     113 I ST Q "0^Prescription is in a Non-Refillable Status."
     114 I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" Q "0^Cannot Refill. Drug No Longer Used by Outpatient Pharmacy."
     115 S PSORFRM=$P(RX0,"^",9) F PSOJ=0:0 S PSOJ=$O(^PSRX(RXN,1,PSOJ)) Q:'PSOJ  S PSORFRM=PSORFRM-1
     116 I PSORFRM<1 Q "0^No Refills remaining. New Med order required."
     117 I $P(^PSRX(RXN,3),"^"),DT=$P(^PSRX(RXN,3),"^") Q "0^Can't Refill, Fill Date already exists for "_$E($P(^PSRX(RXN,3),"^"),4,5)_"/"_$E($P(^PSRX(RXN,3),"^"),6,7)_"/"_$E($P(^PSRX(RXN,3),"^"),2,3)_"."
     118 I $P(^PSRX(RXN,3),"^"),DT<$P(^PSRX(RXN,3),"^") Q "0^Can't Refill, later Refill Date already exists for "_$E($P(^PSRX(RXN,3),"^"),4,5)_"/"_$E($P(^PSRX(RXN,3),"^"),6,7)_"/"_$E($P(^PSRX(RXN,3),"^"),2,3)_"."
     119 I $O(^PS(52.41,"ARF",RXN,0)) Q "0^Pending Refill Request already exists."
     120 Q 1
     121 ;
     122ULK D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
     123 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREJP1.m

    r613 r623  
    1 PSOREJP1        ;BIRM/MFR - Third Party Reject Display Screen ;04/29/05
    2         ;;7.0;OUTPATIENT PHARMACY;**148,247,260,281**;DEC 1997;Build 41
    3         ;Reference to File 9002313.93 - BPS NCPDP REJECT CODES supported by IA 4720
    4         ;Reference to ^PS(59.7 supported by IA 694
    5         ;Reference to ^PSDRUG("AQ" supported by IA 3165
    6         ;
    7 EN(RX,REJ,CHANGE)       ; Entry point
    8         ;
    9         ; - DO NOT change the IF logic below as both of them might get executed (intentional)
    10         N FILL,LASTLN
    11         S FILL=+$$GET1^DIQ(52.25,REJ_","_RX,5)
    12         I $$CLOSED(RX,REJ) D EN^VALM("PSO REJECT DISPLAY - RESOLVED")
    13         I '$$CLOSED(RX,REJ) D EN^VALM("PSO REJECT DISPLAY")
    14         D FULL^VALM1
    15         Q
    16         ;
    17 HDR          ; - Builds the Header section
    18         N LINE1,LINE2,X
    19         S VALMHDR(1)=$$DVINFO^PSOREJU2(RX,FILL,1),VALMHDR(2)=$$PTINFO^PSOREJU2(RX,1)
    20         S VALMHDR(3)=$$RXINFO(RX,FILL,1),VALMHDR(4)=$$RXINFO(RX,FILL,2)
    21         Q
    22         ;
    23 INIT    ; Builds the Body section
    24         N DATA,LINE
    25         F I=1:1:$G(LASTLN) D RESTORE^VALM10(I)
    26         K ^TMP("PSOREJP1",$J) S VALMCNT=0,LINE=0
    27         D GET^PSOREJU2(RX,FILL,.DATA,REJ,1)
    28         D REJ           ; Display REJECT Info
    29         D OTH           ; Display Other Rejects Info
    30         D COM^PSOREJP3  ; Display Comment
    31         D INS           ; Display Insurance Info
    32         D CLS           ; Display Resolution Info
    33         S VALMCNT=LINE
    34         Q
    35         ;
    36 REJ     ; - DUR Information
    37         N TYPE,PFLDT
    38         D SETLN("REJECT Information",1,1)
    39         S TYPE=$S($G(DATA(REJ,"CODE"))=79:"79 - REFILL TOO SOON",1:"88 - DUR REJECT")
    40         D SETLN("Reject Type    : "_TYPE_" received on "_$$FMTE^XLFDT($G(DATA(REJ,"DATE/TIME"))),,,18)
    41         D SETLN("Reject Status  : "_$G(DATA(REJ,"STATUS")),,,18)
    42         D SET("PAYER MESSAGE",63)
    43         D SET("REASON",63)
    44         S PFLDT=$$FMTE^XLFDT($G(DATA(REJ,"PLAN PREVIOUS FILL DATE")))
    45         D SET("DUR TEXT",63,$S(PFLDT="":1,1:0))
    46         I PFLDT'="" D SETLN("Last Fill Date : "_PFLDT_" (from payer)",,1,18)
    47         Q
    48         ;
    49 OTH     ; - Other Rejects Information
    50         N LST,I,RJC,J,LAST
    51         S LST=$G(DATA(REJ,"OTHER REJECTS")) I LST="" Q
    52         D SETLN()
    53         D SETLN("OTHER REJECTS",1,1)
    54         F I=1:1:$L(LST,",") S RJC=$P(LST,",",I) D
    55         . S LAST=1 F J=(I+1):1:$L(LST,",") I $P(LST,",",J)'="" S LAST=0 Q
    56         . I RJC'="" D SETLN(RJC_" - "_$$EXP(RJC),,$S(LAST:1,1:0),6)
    57         Q
    58         ;
    59 INS     ; - Insurance Information
    60         D SETLN()
    61         D SETLN("INSURANCE Information",1,1)
    62         D SETLN("Insurance      : "_$G(DATA(REJ,"INSURANCE NAME")),,,18)
    63         D SETLN("Contact        : "_$G(DATA(REJ,"PLAN CONTACT")),,,18)
    64         D SETLN("Group Name     : "_$G(DATA(REJ,"GROUP NAME")),,,18)
    65         D SETLN("Group Number   : "_$G(DATA(REJ,"GROUP NUMBER")),,,18)
    66         D SETLN("Cardholder ID  : "_$G(DATA(REJ,"CARDHOLDER ID")),,1,18)
    67         Q
    68         ;
    69 CLS     ; - Resolution Information
    70         N X
    71         I '$$CLOSED(RX,REJ) Q
    72         D SETLN()
    73         D SETLN("RESOLUTION Information",1,1)
    74         D SETLN("Resolved By    : "_$G(DATA(REJ,"CLOSED BY")),,,18)
    75         D SETLN("Date/Time      : "_$G(DATA(REJ,"CLOSED DATE/TIME")),,,18)
    76         I $G(DATA(REJ,"CLOSE COMMENTS"))'="" D SET("CLOSE COMMENTS",63)
    77         I $G(DATA(REJ,"COD1"))'="" D SETLN("Reason for Svc : "_$$OVRX^PSOREJU1(1,$G(DATA(REJ,"COD1"))),,,18)
    78         I $G(DATA(REJ,"COD2"))'="" D SETLN("Profes. Svc    : "_$$OVRX^PSOREJU1(2,$G(DATA(REJ,"COD2"))),,,18)
    79         I $G(DATA(REJ,"COD3"))'="" D SETLN("Result of Svc  : "_$$OVRX^PSOREJU1(3,$G(DATA(REJ,"COD3"))),,,18)
    80         I $G(DATA(REJ,"CLA CODE"))'="" D
    81         . S X=$$GET1^DIQ(52.25,REJ_","_RX,24,"I")_" - "_(DATA(REJ,"CLA CODE"))
    82         . D SETLN("Clarific. Code : "_X,,,18)
    83         I $G(DATA(REJ,"PRIOR AUTH TYPE"))'="" D
    84         . S X=$$GET1^DIQ(52.25,REJ_","_RX,25,"I")_" - "_(DATA(REJ,"PRIOR AUTH TYPE"))
    85         . D SETLN("Prior Auth.Type: "_X,,,18),SETLN("Prior Auth. #  : "_DATA(REJ,"PRIOR AUTH NUMBER"),,,18)
    86         D SETLN("Reason         : "_$G(DATA(REJ,"CLOSE REASON")),,1,18)
    87         Q
    88         ;
    89         ;
    90 SET(FIELD,L,UND)        ; Sets the lines for fields that require text wrapping
    91         N TXT,T
    92         S TXT=DATA(REJ,FIELD) I $L(TXT)'>L D SETLN($$LABEL(FIELD)_TXT,,$S($G(UND):1,1:0),80-L) Q
    93         F I=1:1 Q:TXT=""  D
    94         . I I=1 D SETLN($$LABEL(FIELD)_$E(TXT,1,L),,,80-L) S TXT=$E(TXT,L+1,999) Q
    95         . S T="",$E(T,81-L)=$E(TXT,1,L) D SETLN(T,,$S($E(TXT,L+1,999)=""&$G(UND):1,1:0),80-L) S TXT=$E(TXT,L+1,999)
    96         Q
    97         ;
    98 LABEL(FIELD)    ; Sets the label for the field
    99         I FIELD="REASON" Q "Reason         : "
    100         I FIELD="PAYER MESSAGE" Q "Payer Message  : "
    101         I FIELD="DUR TEXT" Q "DUR Text       : "
    102         I FIELD="CLOSE COMMENTS" Q "Comments       : "
    103         Q ""
    104         ;
    105 VIEW    ; - Rx View hidden action
    106         N VALMCNT,TITLE
    107         I $G(PSOBACK) D  Q
    108         . S VALMSG="Not available through Backdoor!",VALMBCK="R"
    109         S TITLE=VALM("TITLE")
    110         ;
    111         ; - DO structure used to avoid losing variables RX,FILL,REJ,LINE,TITLE
    112         DO
    113         . N PSOVDA,DA,PS
    114         . S (PSOVDA,DA)=RX,PS="REJECT"
    115         . N RX,REJ,FILL,LINE,TITLE D DP^PSORXVW
    116         ;
    117         S VALMBCK="R",VALM("TITLE")=TITLE
    118         Q
    119         ;
    120 EDT     ; - Rx Edit hidden action
    121         N VALMCNT,TITLE
    122         I $G(PSOBACK) D  Q
    123         . S VALMSG="Not available through Backdoor!",VALMBCK="R"
    124         S TITLE=VALM("TITLE")
    125         ;
    126         ; - DO structure used to avoid losing variables RX,FILL,REJ,LINE,TITLE
    127         DO
    128         . N PSOSITE,ORN,PSOPAR,PSOLIST
    129         . S PSOSITE=$$RXSITE^PSOBPSUT(RX,FILL),ORN=RX
    130         . S PSOPAR=$G(^PS(59,PSOSITE,1)),PSOLIST(1)=ORN_","
    131         . N RX,REJ,FILL,LINE,TITLE D EPH^PSORXEDT
    132         ;
    133         K VALMBCK I $$CLOSED(RX,REJ),$D(PSOSTFLT),PSOSTFLT="U" S CHANGE=1 Q
    134         S VALMBCK="R",VALM("TITLE")=TITLE
    135         Q
    136         ;
    137 OVR     ; - Override a REJECT action
    138         I $$CLOSED(RX,REJ,1) Q
    139         N COD1,COD2,COD3
    140         D FULL^VALM1 W !
    141         S COD1=$$OVRCOD^PSOREJU1(1,$$GET1^DIQ(52.25,REJ_","_RX,14)) I COD1="^" S VALMBCK="R" Q
    142         S COD2=$$OVRCOD^PSOREJU1(2) I COD2="^" S VALMBCK="R" Q
    143         S COD3=$$OVRCOD^PSOREJU1(3) I COD3="^" S VALMBCK="R" Q
    144         D OVRDSP^PSOREJU1(COD1_"^"_COD2_"^"_COD3)
    145         D SEND(COD1,COD2,COD3)
    146         Q
    147         ;
    148 RES     ; - Re-submit a claim action
    149         I $$CLOSED(RX,REJ,1) Q
    150         D FULL^VALM1 W !
    151         D SEND()
    152         Q
    153         ;
    154 CLA     ; - Submit Clarification Code
    155         N CLA
    156         I $$CLOSED(RX,REJ,1) Q
    157         D FULL^VALM1 W !
    158         S CLA=$$CLA^PSOREJU1() I CLA="^" S VALMBCK="R" Q
    159         W ! D SEND(,,,CLA)
    160         Q
    161         ;
    162 PA      ; - Submit Prior Authorization
    163         N PA
    164         I $$CLOSED(RX,REJ,1) Q
    165         D FULL^VALM1 W !
    166         S PA=$$PA^PSOREJU2() I PA="^" S VALMBCK="R" Q
    167         W ! D SEND(,,,,PA)
    168         Q
    169         ;
    170 SEND(COD1,COD2,COD3,CLA,PA)     ; - Sends Claim to ECME and closes Reject
    171         N DIR,OVRC,RESP,ALTXT,COM
    172         S DIR(0)="Y",DIR("A")="     Confirm",DIR("B")="YES"
    173         S DIR("A",1)="     When you confirm, a new claim will be submitted for"
    174         S DIR("A",2)="     the prescription and this REJECT will be marked"
    175         S DIR("A",3)="     resolved."
    176         S DIR("A",4)=" "
    177         W ! D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" Q
    178         I $G(COD1)'="" S OVRC=$G(COD2)_"^"_$G(COD1)_"^"_$G(COD3)
    179         S ALTXT="REJECT WORKLIST"
    180         S:$G(OVRC)'="" ALTXT=ALTXT_"-DUR OVERRIDE CODES("_$G(COD1)_"/"_$G(COD2)_"/"_$G(COD3)_")"
    181         S:$G(CLA) ALTXT=ALTXT_"(CLARIF. CODE="_CLA_")"
    182         S:$G(PA) ALTXT=ALTXT_"(PRIOR AUTH.="_$TR(PA,"^","/")_")"
    183         D ECMESND^PSOBPSU1(RX,FILL,,"ED",$$GETNDC^PSONDCUT(RX,FILL),,,$G(OVRC),,.RESP,,ALTXT,$G(CLA),$G(PA))
    184         I $G(RESP) D  Q
    185         . W !!?10,"Claim could not be submitted. Please try again later!"
    186         . W !,?10,"Reason: ",$S($P(RESP,"^",2)="":"UNKNOWN",1:$P(RESP,"^",2)),$C(7) H 2
    187         ;
    188         I $$PTLBL^PSOREJP2(RX,FILL) D PRINT(RX,FILL)
    189         ;
    190         I $D(PSOSTFLT),PSOSTFLT'="B" S CHANGE=1
    191         Q
    192         ;
    193 MP      ; - Patient Medication Profile
    194         I $G(PSOBACK) D  Q
    195         . S VALMSG="Not available through Backdoor!",VALMBCK="R"
    196         N SITE,PATIENT
    197         D FULL^VALM1 W !
    198         S SITE=+$$RXSITE^PSOBPSUT(RX,FILL) S:$G(PSOSITE) SITE=PSOSITE
    199         S PATIENT=+$$GET1^DIQ(52,RX,2,"I")
    200         D LST^PSOPMP0(SITE,PATIENT) S VALMBCK="R"
    201         Q
    202         ;
    203 EXIT    ;
    204         K ^TMP("PSOREJP1",$J)
    205         Q
    206         ;
    207 SETLN(TEXT,REV,UND,HIG) ; Sets a line to be displayed in the Body section
    208         N X
    209         S:$G(TEXT)="" $E(TEXT,80)=""
    210         S:$L(TEXT)>80 TEXT=$E(TEXT,1,80)
    211         S LINE=LINE+1,^TMP("PSOREJP1",$J,LINE,0)=$G(TEXT)
    212         ;
    213         I LINE>$G(LASTLN) D SAVE^VALM10(LINE) S LASTLN=LINE
    214         ;
    215         I $G(REV) D  Q
    216         . D CNTRL^VALM10(LINE,1,$L(TEXT),IORVON,IOINORM)
    217         . I $G(UND) D CNTRL^VALM10(LINE,$L(TEXT)+1,80,IOUON,IOINORM)
    218         I $G(UND) D CNTRL^VALM10(LINE,1,80,IOUON,IOINORM)
    219         I $G(HIG) D
    220         . D CNTRL^VALM10(LINE,HIG,80,IOINHI_$S($G(UND):IOUON,1:""),IOINORM)
    221         Q
    222 HELP    ;
    223         Q
    224         ;
    225 RXINFO(RX,FILL,LINE)    ; Returns header displayable Rx Information
    226         N TXT,RXINFO,LBL,CMOP,DRG
    227         I LINE=1 D
    228         . S RXINFO="Rx#      : "_$$GET1^DIQ(52,RX,.01)_"/"_FILL
    229         . S $E(RXINFO,30)="ECME#: "_$E(10000000+RX,2,8)
    230         . S $E(RXINFO,55)="Fill Date: "_$$FMTE^XLFDT($$RXFLDT^PSOBPSUT(RX,FILL))
    231         I LINE=2 D
    232         . S DRG=$$GET1^DIQ(52,RX,6,"I"),CMOP=$S($D(^PSDRUG("AQ",DRG)):1,1:0)
    233         . S RXINFO=$S(CMOP:"CMOP ",1:"")_"Drug",$E(RXINFO,10)=": "_$E($$GET1^DIQ(52,RX,6),1,43)
    234         . S $E(RXINFO,56)="NDC Code: "_$$GETNDC^PSONDCUT(RX,FILL)
    235         Q $G(RXINFO)
    236         ;
    237 CLOSED(RX,REJ,MSG)      ; Returns whether the REJECT is RESOLVED or NOT
    238         I $$GET1^DIQ(52.25,REJ_","_RX,10,"I") D:$G(MSG)  Q 1
    239         . S VALMSG="This Reject is marked resolved!",VALMBCK="R" W $C(7)
    240         Q 0
    241         ;
    242 REOPN(RX,REJ)   ; Returns whether the REJECT was RE-OPENED or NOT
    243         Q $S($$GET1^DIQ(52.25,REJ_","_RX,23)="":0,1:1)
    244         ;
    245 EXP(CODE)       ; - Returns the explanation field (.02) for a reject code
    246         ;  Input:  (r) CODE - .01 field (Code) value from file 9002313.93
    247         ; Output: .02 field (Explanation) value from file 9002313.93
    248         N DIC,X,Y
    249         S DIC=9002313.93,DIC(0)="Z",X=CODE D ^DIC
    250         Q $P($G(Y(0)),"^",2)
    251         ;
    252 OUT(RX) ; - Supported call by outside PROTOCOLs to act on specific REJECTs
    253         N I,RFL,DATA,REJ,PSOBACK,VALMCNT,RXN
    254         I '$D(^XUSEC("PSORPH",DUZ)) S VALMSG="PSORPH key required to use the REJ action.",VALMBCK="R" Q
    255         I $G(PS)="REJECT" D  Q
    256         . S VALMSG="REJ action is not available at this point.",VALMBCK="R"
    257         S PSOBACK=1
    258         S (RFL,I)=0 F I=1:1 Q:'$D(^PSRX(RX,1,I))  S RFL=I
    259         S X=$$FIND^PSOREJUT(RX,RFL,.DATA) S REJ=$O(DATA(""))
    260         I '$G(REJ) S VALMSG="Invalid selection!",VALMBCK="R" Q
    261         D EN(RX,REJ) S VALMBCK="R"
    262         Q
    263         ;
    264 PRINT(RX,RFL)   ; Print Label for specific Rx/Fill
    265         N PPL,PSOSITE,PSOPAR,PSOSYS,PSOLAP,PSOBARS,PSOBAR0,PSOBAR1,PSOIOS,PSOBFLAG
    266         N POP,DFN,PDUZ,RXFL
    267         ;
    268         S PSOSITE=$$RXSITE^PSOBPSUT(RX,RFL),PSOPAR=^PS(59,PSOSITE,1)
    269         S DFN=$$GET1^DIQ(52,RX,2,"I"),PDUZ=DUZ,PSOSYS=$G(^PS(59.7,1,40.1))
    270         S PPL=RX I RFL S RXFL(RX)=RFL
    271         W ! S PSOBFLAG=1 D LBL^PSOLSET I $G(PSOQUIT) Q
    272         ;
    273         S IOP=PSOLAP D ^%ZIS,DQ^PSOLBL,^%ZISC
    274         Q
     1PSOREJP1 ;BIRM/MFR - Third Party Reject Display Screen ;04/29/05
     2 ;;7.0;OUTPATIENT PHARMACY;**148,247,260**;DEC 1997;Build 84
     3 ;Reference to File 9002313.93 - BPS NCPDP REJECT CODES supported by IA 4720
     4 ;Reference to ^PS(59.7 supported by IA 694
     5 ;Reference to ^PSDRUG("AQ" supported by IA 3165
     6 ;
     7EN(RX,REJ,CHANGE) ; Entry point
     8 ;
     9 ; - DO NOT change the IF logic below as both of them might get executed (intentional)
     10 N FILL,LASTLN
     11 S FILL=+$$GET1^DIQ(52.25,REJ_","_RX,5)
     12 I $$CLOSED(RX,REJ) D EN^VALM("PSO REJECT DISPLAY - RESOLVED")
     13 I '$$CLOSED(RX,REJ) D EN^VALM("PSO REJECT DISPLAY")
     14 D FULL^VALM1
     15 Q
     16 ;
     17HDR      ; - Builds the Header section
     18 N LINE1,LINE2,X
     19 S VALMHDR(1)=$$DVINFO^PSOREJU2(RX,FILL,1),VALMHDR(2)=$$PTINFO^PSOREJU2(RX,1)
     20 S VALMHDR(3)=$$RXINFO(RX,FILL,1),VALMHDR(4)=$$RXINFO(RX,FILL,2)
     21 Q
     22 ;
     23INIT ; Builds the Body section
     24 N DATA,LINE
     25 F I=1:1:$G(LASTLN) D RESTORE^VALM10(I)
     26 K ^TMP("PSOREJP1",$J) S VALMCNT=0,LINE=0
     27 D GET^PSOREJU2(RX,FILL,.DATA,REJ,1)
     28 D REJ                   ; Display the REJECT Information
     29 D OTH                   ; Display the Other Rejects Information
     30 D COM^PSOREJP3          ; Display the Comment
     31 D INS                   ; Display the Insurance Information
     32 D CLS                   ; Display the Resolution Information
     33 S VALMCNT=LINE
     34 Q
     35 ;
     36REJ ; - DUR Information
     37 N TYPE,PFLDT
     38 D SETLN("REJECT Information",1,1)
     39 S TYPE=$S($G(DATA(REJ,"CODE"))=79:"79 - REFILL TOO SOON",1:"88 - DUR REJECT")
     40 D SETLN("Reject Type    : "_TYPE_" received on "_$$FMTE^XLFDT($G(DATA(REJ,"DATE/TIME"))),,,18)
     41 D SETLN("Reject Status  : "_$G(DATA(REJ,"STATUS")),,,18)
     42 D SET("PAYER MESSAGE",63)
     43 D SET("REASON",63)
     44 S PFLDT=$$FMTE^XLFDT($G(DATA(REJ,"PLAN PREVIOUS FILL DATE")))
     45 D SET("DUR TEXT",63,$S(PFLDT="":1,1:0))
     46 I PFLDT'="" D SETLN("Last Fill Date : "_PFLDT_" (from payer)",,1,18)
     47 Q
     48 ;
     49OTH ; - Other Rejects Information
     50 N LST,I,RJC,J,LAST
     51 S LST=$G(DATA(REJ,"OTHER REJECTS")) I LST="" Q
     52 D SETLN()
     53 D SETLN("OTHER REJECTS",1,1)
     54 F I=1:1:$L(LST,",") S RJC=$P(LST,",",I) D
     55 . S LAST=1 F J=(I+1):1:$L(LST,",") I $P(LST,",",J)'="" S LAST=0 Q
     56 . I RJC'="" D SETLN(RJC_" - "_$$EXP(RJC),,$S(LAST:1,1:0),6)
     57 Q
     58 ;
     59INS ; - Insurance Information
     60 D SETLN()
     61 D SETLN("INSURANCE Information",1,1)
     62 D SETLN("Insurance      : "_$G(DATA(REJ,"INSURANCE NAME")),,,18)
     63 D SETLN("Contact        : "_$G(DATA(REJ,"PLAN CONTACT")),,,18)
     64 D SETLN("Group Name     : "_$G(DATA(REJ,"GROUP NAME")),,,18)
     65 D SETLN("Group Number   : "_$G(DATA(REJ,"GROUP NUMBER")),,,18)
     66 D SETLN("Cardholder ID  : "_$G(DATA(REJ,"CARDHOLDER ID")),,1,18)
     67 Q
     68 ;
     69CLS ; - Resolution Information
     70 N X
     71 I '$$CLOSED(RX,REJ) Q
     72 D SETLN()
     73 D SETLN("RESOLUTION Information",1,1)
     74 D SETLN("Resolved By    : "_$G(DATA(REJ,"CLOSED BY")),,,18)
     75 D SETLN("Date/Time      : "_$G(DATA(REJ,"CLOSED DATE/TIME")),,,18)
     76 I $G(DATA(REJ,"CLOSE COMMENTS"))'="" D SET("CLOSE COMMENTS",63)
     77 I $G(DATA(REJ,"COD1"))'="" D SETLN("Reason for Svc : "_$$OVRX^PSOREJU1(1,$G(DATA(REJ,"COD1"))),,,18)
     78 I $G(DATA(REJ,"COD2"))'="" D SETLN("Profes. Svc    : "_$$OVRX^PSOREJU1(2,$G(DATA(REJ,"COD2"))),,,18)
     79 I $G(DATA(REJ,"COD3"))'="" D SETLN("Result of Svc  : "_$$OVRX^PSOREJU1(3,$G(DATA(REJ,"COD3"))),,,18)
     80 I $G(DATA(REJ,"CLA CODE"))'="" D
     81 . S X=$$GET1^DIQ(52.25,REJ_","_RX,24,"I")_" - "_(DATA(REJ,"CLA CODE"))
     82 . D SETLN("Clarific. Code : "_X,,,18)
     83 I $G(DATA(REJ,"PRIOR AUTH TYPE"))'="" D
     84 . S X=$$GET1^DIQ(52.25,REJ_","_RX,25,"I")_" - "_(DATA(REJ,"PRIOR AUTH TYPE"))
     85 . D SETLN("Prior Auth.Type: "_X,,,18),SETLN("Prior Auth. #  : "_DATA(REJ,"PRIOR AUTH NUMBER"),,,18)
     86 D SETLN("Reason         : "_$G(DATA(REJ,"CLOSE REASON")),,1,18)
     87 Q
     88 ;
     89 ;
     90SET(FIELD,L,UND) ; Sets the lines for fields that require text wrapping
     91 N TXT,T
     92 S TXT=DATA(REJ,FIELD) I $L(TXT)'>L D SETLN($$LABEL(FIELD)_TXT,,$S($G(UND):1,1:0),80-L) Q
     93 F I=1:1 Q:TXT=""  D
     94 . I I=1 D SETLN($$LABEL(FIELD)_$E(TXT,1,L),,,80-L) S TXT=$E(TXT,L+1,999) Q
     95 . S T="",$E(T,81-L)=$E(TXT,1,L) D SETLN(T,,$S($E(TXT,L+1,999)=""&$G(UND):1,1:0),80-L) S TXT=$E(TXT,L+1,999)
     96 Q
     97 ;
     98LABEL(FIELD) ; Sets the label for the field
     99 I FIELD="REASON" Q "Reason         : "
     100 I FIELD="PAYER MESSAGE" Q "Payer Message  : "
     101 I FIELD="DUR TEXT" Q "DUR Text       : "
     102 I FIELD="CLOSE COMMENTS" Q "Comments       : "
     103 Q ""
     104 ;
     105VIEW ; - Rx View hidden action
     106 N VALMCNT,TITLE
     107 I $G(PSOBACK) D  Q
     108 . S VALMSG="Not available through Backdoor!",VALMBCK="R"
     109 S TITLE=VALM("TITLE")
     110 ;
     111 ; - DO structure used to avoid losing variables RX,FILL,REJ,LINE,TITLE
     112 DO
     113 . N PSOVDA,DA,PS
     114 . S (PSOVDA,DA)=RX,PS="REJECT"
     115 . N RX,REJ,FILL,LINE,TITLE D DP^PSORXVW
     116 ;
     117 S VALMBCK="R",VALM("TITLE")=TITLE
     118 Q
     119 ;
     120EDT ; - Rx Edit hidden action
     121 N VALMCNT,TITLE
     122 I $G(PSOBACK) D  Q
     123 . S VALMSG="Not available through Backdoor!",VALMBCK="R"
     124 S TITLE=VALM("TITLE")
     125 ;
     126 ; - DO structure used to avoid losing variables RX,FILL,REJ,LINE,TITLE
     127 DO
     128 . N PSOSITE,ORN,PSOPAR,PSOLIST
     129 . S PSOSITE=$$RXSITE^PSOBPSUT(RX,FILL),ORN=RX
     130 . S PSOPAR=$G(^PS(59,PSOSITE,1)),PSOLIST(1)=ORN_","
     131 . N RX,REJ,FILL,LINE,TITLE D EPH^PSORXEDT
     132 ;
     133 K VALMBCK I $$CLOSED(RX,REJ),$D(PSOSTFLT),PSOSTFLT="U" S CHANGE=1 Q
     134 S VALMBCK="R",VALM("TITLE")=TITLE
     135 Q
     136 ;
     137OVR ; - Override a REJECT action
     138 I $$CLOSED(RX,REJ,1) Q
     139 N COD1,COD2,COD3
     140 D FULL^VALM1 W !
     141 S COD1=$$OVRCOD^PSOREJU1(1,$$GET1^DIQ(52.25,REJ_","_RX,14)) I COD1="^" S VALMBCK="R" Q
     142 S COD2=$$OVRCOD^PSOREJU1(2) I COD2="^" S VALMBCK="R" Q
     143 S COD3=$$OVRCOD^PSOREJU1(3) I COD3="^" S VALMBCK="R" Q
     144 D OVRDSP^PSOREJU1(COD1_"^"_COD2_"^"_COD3)
     145 D SEND(COD1,COD2,COD3)
     146 Q
     147 ;
     148RES ; - Re-submit a claim action
     149 I $$CLOSED(RX,REJ,1) Q
     150 D FULL^VALM1 W !
     151 D SEND()
     152 Q
     153 ;
     154CLA ; - Submit Clarification Code
     155 N CLA
     156 I $$CLOSED(RX,REJ,1) Q
     157 D FULL^VALM1 W !
     158 S CLA=$$CLA^PSOREJU1() I CLA="^" S VALMBCK="R" Q
     159 W ! D SEND(,,,CLA)
     160 Q
     161 ;
     162PA ; - Submit Prior Authorization
     163 N PA
     164 I $$CLOSED(RX,REJ,1) Q
     165 D FULL^VALM1 W !
     166 S PA=$$PA^PSOREJU2() I PA="^" S VALMBCK="R" Q
     167 W ! D SEND(,,,,PA)
     168 Q
     169 ;
     170SEND(COD1,COD2,COD3,CLA,PA) ; - Sends Claim to ECME and closes Reject
     171 N DIR,OVRC,RESP,ALTXT,COM
     172 S DIR(0)="Y",DIR("A")="     Confirm",DIR("B")="YES"
     173 S DIR("A",1)="     When you confirm, a new claim will be submitted for"
     174 S DIR("A",2)="     the prescription and this REJECT will be marked"
     175 S DIR("A",3)="     resolved."
     176 S DIR("A",4)=" "
     177 W ! D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" Q
     178 I $G(COD1)'="" S OVRC=$G(COD2)_"^"_$G(COD1)_"^"_$G(COD3)
     179 S ALTXT="REJECT WORKLIST"
     180 S:$G(OVRC)'="" ALTXT=ALTXT_"-DUR OVERRIDE CODES("_$G(COD1)_"/"_$G(COD2)_"/"_$G(COD3)_")"
     181 S:$G(CLA) ALTXT=ALTXT_"(CLARIF. CODE="_CLA_")"
     182 S:$G(PA) ALTXT=ALTXT_"(PRIOR AUTH.="_$TR(PA,"^","/")_")"
     183 D ECMESND^PSOBPSU1(RX,FILL,,"ED",$$GETNDC^PSONDCUT(RX,FILL),,,$G(OVRC),,.RESP,,ALTXT,$G(CLA),$G(PA))
     184 I $G(RESP) D  Q
     185 . W !!?10,"Claim could not be submitted. Please try again later!"
     186 . W !,?10,"Reason: ",$S($P(RESP,"^",2)="":"UNKNOWN",1:$P(RESP,"^",2)),$C(7) H 2
     187 ;
     188 I $$PTLBL^PSOREJP2(RX,FILL) D PRINT(RX,FILL)
     189 ;
     190 I $D(PSOSTFLT),PSOSTFLT'="B" S CHANGE=1
     191 Q
     192 ;
     193MP ; - Patient Medication Profile
     194 I $G(PSOBACK) D  Q
     195 . S VALMSG="Not available through Backdoor!",VALMBCK="R"
     196 N SITE,PATIENT
     197 D FULL^VALM1 W !
     198 S SITE=+$$RXSITE^PSOBPSUT(RX,FILL) S:$G(PSOSITE) SITE=PSOSITE
     199 S PATIENT=+$$GET1^DIQ(52,RX,2,"I")
     200 D LST^PSOPMP0(SITE,PATIENT) S VALMBCK="R"
     201 Q
     202 ;
     203EXIT ;
     204 K ^TMP("PSOREJP1",$J)
     205 Q
     206 ;
     207SETLN(TEXT,REV,UND,HIG) ; Sets a line to be displayed in the Body section
     208 N X
     209 S:$G(TEXT)="" $E(TEXT,80)=""
     210 S:$L(TEXT)>80 TEXT=$E(TEXT,1,80)
     211 S LINE=LINE+1,^TMP("PSOREJP1",$J,LINE,0)=$G(TEXT)
     212 ;
     213 I LINE>$G(LASTLN) D SAVE^VALM10(LINE) S LASTLN=LINE
     214 ;
     215 I $G(REV) D  Q
     216 . D CNTRL^VALM10(LINE,1,$L(TEXT),IORVON,IOINORM)
     217 . I $G(UND) D CNTRL^VALM10(LINE,$L(TEXT)+1,80,IOUON,IOINORM)
     218 I $G(UND) D CNTRL^VALM10(LINE,1,80,IOUON,IOINORM)
     219 I $G(HIG) D
     220 . D CNTRL^VALM10(LINE,HIG,80,IOINHI_$S($G(UND):IOUON,1:""),IOINORM)
     221 Q
     222HELP ;
     223 Q
     224 ;
     225RXINFO(RX,FILL,LINE) ; Returns header displayable Rx Information
     226 N TXT,RXINFO,LBL,CMOP,DRG
     227 I LINE=1 D
     228 . S RXINFO="Rx#      : "_$$GET1^DIQ(52,RX,.01)_"/"_FILL
     229 . S $E(RXINFO,30)="ECME#: "_$E(10000000+RX,2,8)
     230 . S $E(RXINFO,55)="Fill Date: "_$$FMTE^XLFDT($$RXFLDT^PSOBPSUT(RX,FILL))
     231 I LINE=2 D
     232 . S DRG=$$GET1^DIQ(52,RX,6,"I"),CMOP=$S($D(^PSDRUG("AQ",DRG)):1,1:0)
     233 . S RXINFO=$S(CMOP:"CMOP ",1:"")_"Drug",$E(RXINFO,10)=": "_$E($$GET1^DIQ(52,RX,6),1,43)
     234 . S $E(RXINFO,56)="NDC Code: "_$$GETNDC^PSONDCUT(RX,FILL)
     235 Q $G(RXINFO)
     236 ;
     237CLOSED(RX,REJ,MSG) ; Returns whether the REJECT is RESOLVED or NOT
     238 I $$GET1^DIQ(52.25,REJ_","_RX,10,"I") D:$G(MSG)  Q 1
     239 . S VALMSG="This Reject is marked resolved!",VALMBCK="R" W $C(7)
     240 Q 0
     241 ;
     242REOPN(RX,REJ) ; Returns whether the REJECT was RE-OPENED or NOT
     243 Q $S($$GET1^DIQ(52.25,REJ_","_RX,23)="":0,1:1)
     244 ;
     245EXP(CODE) ; - Returns the explanation field (.02) for a reject code
     246 ;  Input:  (r) CODE - .01 field (Code) value from file 9002313.93
     247 ; Output: .02 field (Explanation) value from file 9002313.93
     248 N DIC,X,Y
     249 S DIC=9002313.93,DIC(0)="Z",X=CODE D ^DIC
     250 Q $P($G(Y(0)),"^",2)
     251 ;
     252OUT(RX) ; - Supported call by outside PROTOCOLs to act on specific REJECTs
     253 N I,RFL,DATA,REJ,PSOBACK,VALMCNT
     254 S PSOBACK=1
     255 S (RFL,I)=0 F I=1:1 Q:'$D(^PSRX(RX,1,I))  S RFL=I
     256 S X=$$FIND^PSOREJUT(RX,RFL,.DATA) S REJ=$O(DATA(""))
     257 I '$G(REJ) S VALMSG="Invalid selection!",VALMBCK="R" Q
     258 D EN(RX,REJ) S VALMBCK="R"
     259 Q
     260 ;
     261PRINT(RX,RFL) ; Print Label for specific Rx/Fill
     262 N PPL,PSOSITE,PSOPAR,PSOSYS,PSOLAP,PSOBARS,PSOBAR0,PSOBAR1,PSOIOS,PSOBFLAG
     263 N POP,DFN,PDUZ,RXFL
     264 ;
     265 S PSOSITE=$$RXSITE^PSOBPSUT(RX,RFL),PSOPAR=^PS(59,PSOSITE,1)
     266 S DFN=$$GET1^DIQ(52,RX,2,"I"),PDUZ=DUZ,PSOSYS=$G(^PS(59.7,1,40.1))
     267 S PPL=RX I RFL S RXFL(RX)=RFL
     268 W ! S PSOBFLAG=1 D LBL^PSOLSET I $G(PSOQUIT) Q
     269 ;
     270 S IOP=PSOLAP D ^%ZIS,DQ^PSOLBL,^%ZISC
     271 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW.m

    r613 r623  
    1 PSORENW ;BIR/SAB-renew main driver ;4/25/07 8:42am
    2         ;;7.0;OUTPATIENT PHARMACY;**11,27,30,46,71,96,100,130,148,206**;DEC 1997;Build 39
    3         ;External reference to ^PSDRUG supported by DBIA 221
    4         ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
    5         ;External reference to LK^ORX2 and ULK^ORX2 supported by DBIA 867
    6         ;External reference to ^PS(50.7 supported by DBIA 2223
    7         ;External reference to MAIN^TIUEDIT supported by DBIA 2410
    8         ;
    9 ASK     ;
    10         K PSORENW("FILL DATE") D FILLDT^PSODIR2(.PSORENW) S:$G(PSORENW("DFLG")) VALMSG="Renew Rx request canceled",VALMBCK="R"
    11         I PSORENW("DFLG")!('$D(PSORENW("FILL DATE"))) S PSORENW("QFLG")=1,PSORENW("DFLG")=0 G ASKX
    12         S PSORNW("FILL DATE")=PSORENW("FILL DATE")
    13         D MW^PSOCMOPA(.PSORENW)
    14         I PSORENW("DFLG") S PSORENW("QFLG")=1,PSORENW("DFLG")=0 G ASKX
    15         S PSORNW("MAIL/WINDOW")=PSORENW("MAIL/WINDOW") S PSORX("MAIL/WINDOW")=$S(PSORENW("MAIL/WINDOW")="M":"MAIL",1:"WINDOW")
    16         D NOORE^PSONEW(.PSORENW) S:$G(PSORENW("DFLG")) VALMSG="Renew Rx request canceled",VALMBCK="R"
    17         I PSORENW("DFLG")!('$D(PSORENW("FILL DATE"))) S PSORENW("QFLG")=1,PSORENW("DFLG")=0
    18 ASKX    Q
    19         ;
    20 EOJ     ;
    21         K VERB,RTE,DRET,PSOMSG,PSORNW,PSOLIST,PSORENW,PSORX("BAR CODE"),PSORX("FILL DATE"),PSODIR,PSOID,PSONOOR,PSOCOU,PSOCOUU,PSOID,PSOFDMX,PSODRUG,COPY,PSOBCKDR
    22         S RXN=$O(^TMP("PSORXN",$J,0)) I RXN D
    23         .S RXN1=^TMP("PSORXN",$J,RXN) D EN^PSOHLSN1(RXN,$P(RXN1,"^"),$P(RXN1,"^",2),"",$P(RXN1,"^",3))
    24         .I $P(^PSRX(RXN,"STA"),"^")=5 D EN^PSOHLSN1(RXN,"SC","ZS",$P(RXN1,"^",4))
    25         K RXN,RXN1,^TMP("PSORXN",$J)
    26         I $G(PSONOTE) D MAIN^TIUEDIT(3,.TIUDA,PSODFN,"","","","",1)
    27         K PSONOTE
    28         Q
    29 OERR    ;entry for renew backdoor
    30         I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2),,.VALMSG,.VALMBCK) Q
    31         S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
    32         K PSOPLCK S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" D UL^PSSLOCK(PSODFN) Q
    33         K PSOID,PSOFDMX,PSORX("FILL DATE"),PSORENW("FILL DATE"),PSORX("QS"),PSORENW("QS"),PSOBARCD,COPY
    34         D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D ULPAT Q
    35         S PSOBCKDR=1,PSOFROM="NEW",PSORENW("OIRXN")=$P(PSOLST(ORN),"^",2),PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"),PSORX("DFLG"))=0
    36         S PSONEW("DAYS SUPPLY")=$P(^PSRX(PSORENW("OIRXN"),0),"^",8),PSONEW("# OF REFILLS")=$P(^(0),"^",9)
    37         D FULL^VALM1,ASK D:PSORENW("QFLG") KLIB^PSORENW1 D:PSORENW("QFLG") ULPAT D:PSORENW("QFLG") PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) G:PSORENW("QFLG") EOJ D ^PSORENW0
    38         D ULPAT,EOJ,KLIB^PSORENW1 K PSOOPT,PSONEW,PSORX("DFLG")
    39         Q
    40 ULPAT   K PSOMSG D UL^PSSLOCK(PSODFN) S X=PSODFN_";DPT(" D ULK^ORX2
    41         Q
    42 RENEW(PLACER,PSOCPDRG)  ;passes flag to CPRS for front door renews
    43         ;-1=couldn't find order, 0=unable to renew, 1=renewable
    44         ;Placer=Pharmacy number
    45         N PSOSURX,PSORFRM,PSOLC,PSODRG,PSODRUG0,RXN,ST,PSONEWOI,PSOOLDOI,PSOIFLAG,PSOINA
    46         I $G(PLACER)["S"!('$G(PLACER)) Q "-1^Not a Valid Outpatient Medication Order."
    47         S RXN=PLACER I '$D(^PSRX(RXN,0)) Q "-1^Not a Valid Outpatient Medication Order."
    48         S RX0=^PSRX(RXN,0),PSODRG=+$P(^PSRX(RXN,0),"^",6),ST=+^("STA"),PSODRUG0=^PSDRUG(PSODRG,0)
    49         S PSOIFLAG=0,PSOOLDOI=+$P($G(^PSRX(RXN,"OR1")),"^"),PSONEWOI=+$P($G(^PSDRUG(+$G(PSODRG),2)),"^") I PSONEWOI,PSONEWOI'=PSOOLDOI S PSOIFLAG=1
    50         S PSOINA=$P($G(^PS(50.7,PSONEWOI,0)),"^",4)
    51         I PSOINA,DT>PSOINA Q "0^This Orderable Item has been Inactivated."
    52         I ST=5 S PSOSURX=$O(^PS(52.5,"B",RXN,0)) I PSOSURX,$P($G(^PS(52.5,PSOSURX,0)),"^",7)="L" Q "0^Rx loading into a CMOP Transmission."
    53         S X1=DT,X2=-120 D C^%DTC I $P($G(^PSRX(RXN,2)),"^",6)<X Q "0^Prescription Expired more than 120 Days."
    54         S X1=DT,X2=-120 D C^%DTC I $P($G(^PSRX(RXN,3)),"^",5),$P($G(^(3)),"^",5)<X,$P(^("STA"),"^")=12 Q "0^Prescription Discontinued more than 120 Days."
    55         I $G(PSOCPDRG),$G(PSOCPDRG)'=$G(PSODRG) Q "0^Drug Mismatch, Non-Renewable."
    56         N PSOOCPRX,PSOOLPF,PSOOLPD,PSONOSIG S PSOOCPRX=RXN D CDOSE^PSORENW0 I PSOOLPF Q "0^Non-Renewable, invalid Dosage of "_$G(PSOOLPD)
    57         I PSONOSIG Q "0^Non-Renewable, missing Sig."
    58         I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" Q "0^Drug is No longer used by Outpatient Pharmacy."
    59         I $G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) Q "0^This Drug has been Inactivated."
    60         I ($P(PSODRUG0,"^",3)[1)!($P(PSODRUG0,"^",3)[2)!($P(PSODRUG0,"^",3)["W") Q "0^Non-Renewable "_$S($P(PSODRUG0,"^",3)["A":"Drug Narcotic.",1:"Drug.")
    61         I $D(^PS(53,+$P(RX0,"^",3),0)),'$P(^(0),"^",5) Q "0^Non-Renewable Prescription."
    62         S PSOLC=$P(RX0,"^"),PSOLC=$E(PSOLC,$L(PSOLC)) I $A(PSOLC)'<90 Q "0^Max number of renewals (26) has been reached."
    63         I ST,ST'=2,ST'=5,ST'=6,ST'=11,ST'=12,ST'=14 Q "0^Prescritpion is in a Non-Renewable Status."
    64         I $P($G(^PSRX(RXN,"OR1")),"^",4) Q "0^Duplicate Rx Renewal Request."
    65         I $O(^PS(52.41,"AQ",RXN,0)) Q "0^Duplicate Rx Renewal Request."
    66         K PSORFRM,PSOLC,PSODRG,PSODRUG0,RXN,ST
    67         Q 1_$S($G(PSOIFLAG):"^"_$G(PSONEWOI),1:"")
    68         ;
    69 INST1   ;Set Pharmacy Instructions array
    70         N PSOTZ
    71         I $O(^PSRX(RXN,"PI",0)) S PHI=$G(^PSRX(RXN,"PI",0)),PSOTZ=0 D
    72         .F  S PSOTZ=$O(^PSRX(RXN,"PI",PSOTZ)) Q:PSOTZ=""  S PHI(PSOTZ)=$G(^PSRX(RXN,"PI",PSOTZ,0))
    73         Q
    74 INST2   ;Set Instructions and Comments
    75         I '$G(PSORENW("OIRXN")) Q
    76         I $G(PSOFDR) Q
    77         N PSOPHL,PSOPRL
    78         I $O(^PSRX(PSORENW("OIRXN"),"PI",0)) K PHI S PHI=$G(^PSRX(PSORENW("OIRXN"),"PI",0)),PSOPHL="" D
    79         .F  S PSOPHL=$O(^PSRX(PSORENW("OIRXN"),"PI",PSOPHL)) Q:PSOPHL=""  S PHI(PSOPHL)=$G(^PSRX(PSORENW("OIRXN"),"PI",PSOPHL,0))
    80         I $O(^PSRX(PSORENW("OIRXN"),"PRC",0)) K PRC S PRC=$G(^PSRX(PSORENW("OIRXN"),"PRC",0)),PSOPRL="" D
    81         .F  S PSOPRL=$O(^PSRX(PSORENW("OIRXN"),"PRC",PSOPRL)) Q:PSOPRL=""  S PRC(PSOPRL)=$G(^PSRX(PSORENW("OIRXN"),"PRC",PSOPRL,0))
    82         Q
     1PSORENW ;BIR/SAB-renew main driver ;07/07/96
     2 ;;7.0;OUTPATIENT PHARMACY;**11,27,30,46,71,96,100,130,148**;DEC 1997
     3 ;External reference to ^PSDRUG supported by DBIA 221
     4 ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
     5 ;External reference to LK^ORX2 and ULK^ORX2 supported by DBIA 867
     6 ;External reference to ^PS(50.7 supported by DBIA 2223
     7 ;External reference to MAIN^TIUEDIT supported by DBIA 2410
     8 ;
     9ASK ;
     10 K PSORENW("FILL DATE") D FILLDT^PSODIR2(.PSORENW) S:$G(PSORENW("DFLG")) VALMSG="Renew Rx request canceled",VALMBCK="R"
     11 I PSORENW("DFLG")!('$D(PSORENW("FILL DATE"))) S PSORENW("QFLG")=1,PSORENW("DFLG")=0 G ASKX
     12 S PSORNW("FILL DATE")=PSORENW("FILL DATE")
     13 D MW^PSOCMOPA(.PSORENW)
     14 I PSORENW("DFLG") S PSORENW("QFLG")=1,PSORENW("DFLG")=0 G ASKX
     15 S PSORNW("MAIL/WINDOW")=PSORENW("MAIL/WINDOW") S PSORX("MAIL/WINDOW")=$S(PSORENW("MAIL/WINDOW")="M":"MAIL",1:"WINDOW")
     16 D NOORE^PSONEW(.PSORENW) S:$G(PSORENW("DFLG")) VALMSG="Renew Rx request canceled",VALMBCK="R"
     17 I PSORENW("DFLG")!('$D(PSORENW("FILL DATE"))) S PSORENW("QFLG")=1,PSORENW("DFLG")=0
     18ASKX Q
     19 ;
     20EOJ ;
     21 K VERB,RTE,DRET,PSOMSG,PSORNW,PSOLIST,PSORENW,PSORX("BAR CODE"),PSORX("FILL DATE"),PSODIR,PSOID,PSONOOR,PSOCOU,PSOCOUU,PSOID,PSOFDMX,PSODRUG,COPY,PSOBCKDR
     22 S RXN=$O(^TMP("PSORXN",$J,0)) I RXN D
     23 .S RXN1=^TMP("PSORXN",$J,RXN) D EN^PSOHLSN1(RXN,$P(RXN1,"^"),$P(RXN1,"^",2),"",$P(RXN1,"^",3))
     24 .I $P(^PSRX(RXN,"STA"),"^")=5 D EN^PSOHLSN1(RXN,"SC","ZS",$P(RXN1,"^",4))
     25 K RXN,RXN1,^TMP("PSORXN",$J)
     26 I $G(PSONOTE) D MAIN^TIUEDIT(3,.TIUDA,PSODFN,"","","","",1)
     27 K PSONOTE
     28 Q
     29OERR ;entry for renew backdoor
     30 I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2),,.VALMSG,.VALMBCK) Q
     31 S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
     32 K PSOPLCK S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" D UL^PSSLOCK(PSODFN) Q
     33 K PSOID,PSOFDMX,PSORX("FILL DATE"),PSORENW("FILL DATE"),PSORX("QS"),PSORENW("QS"),PSOBARCD,COPY
     34 D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D ULPAT Q
     35 S PSOBCKDR=1,PSOFROM="NEW",PSORENW("OIRXN")=$P(PSOLST(ORN),"^",2),PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"),PSORX("DFLG"))=0
     36 S PSONEW("DAYS SUPPLY")=$P(^PSRX(PSORENW("OIRXN"),0),"^",8),PSONEW("# OF REFILLS")=$P(^(0),"^",9)
     37 D FULL^VALM1,ASK D:PSORENW("QFLG") KLIB^PSORENW1 D:PSORENW("QFLG") ULPAT D:PSORENW("QFLG") PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) G:PSORENW("QFLG") EOJ D ^PSORENW0
     38 D ULPAT,EOJ,KLIB^PSORENW1 K PSOOPT,PSONEW,PSORX("DFLG")
     39 Q
     40ULPAT K PSOMSG D UL^PSSLOCK(PSODFN) S X=PSODFN_";DPT(" D ULK^ORX2
     41 Q
     42RENEW(PLACER,PSOCPDRG) ;passes flag to CPRS for front door renews
     43 ;-1=couldn't find order, 0=unable to renew, 1=renewable
     44 ;Placer=Pharmacy number
     45 N PSOSURX,PSORFRM,PSOLC,PSODRG,PSODRUG0,RXN,ST,PSONEWOI,PSOOLDOI,PSOIFLAG,PSOINA
     46 I $G(PLACER)["S"!('$G(PLACER)) Q "-1^Not a Valid Outpatient Medication Order."
     47 S RXN=PLACER I '$D(^PSRX(RXN,0)) Q "-1^Not a Valid Outpatient Medication Order."
     48 S RX0=^PSRX(RXN,0),PSODRG=+$P(^PSRX(RXN,0),"^",6),ST=+^("STA"),PSODRUG0=^PSDRUG(PSODRG,0)
     49 S PSOIFLAG=0,PSOOLDOI=+$P($G(^PSRX(RXN,"OR1")),"^"),PSONEWOI=+$P($G(^PSDRUG(+$G(PSODRG),2)),"^") I PSONEWOI,PSONEWOI'=PSOOLDOI S PSOIFLAG=1
     50 S PSOINA=$P($G(^PS(50.7,PSONEWOI,0)),"^",4)
     51 I PSOINA,DT>PSOINA Q "0^This Orderable Item has been Inactivated."
     52 I ST=5 S PSOSURX=$O(^PS(52.5,"B",RXN,0)) I PSOSURX,$P($G(^PS(52.5,PSOSURX,0)),"^",7)="L" Q "0^Rx loading into a CMOP Transmission."
     53 S X1=DT,X2=-120 D C^%DTC I $P($G(^PSRX(RXN,2)),"^",6)<X Q "0^Prescription Expired more than 120 Days."
     54 S X1=DT,X2=-120 D C^%DTC I $P($G(^PSRX(RXN,3)),"^",5),$P($G(^(3)),"^",5)<X,$P(^("STA"),"^")=12 Q "0^Prescription Discontinued more than 120 Days."
     55 I $G(PSOCPDRG),$G(PSOCPDRG)'=$G(PSODRG) Q "0^Drug Mismatch, Non-Renewable."
     56 N PSOOCPRX,PSOOLPF,PSOOLPD,PSONOSIG S PSOOCPRX=RXN D CDOSE^PSORENW0 I PSOOLPF Q "0^Non-Renewable, invalid Dosage of "_$G(PSOOLPD)
     57 I PSONOSIG Q "0^Non-Renewable, missing Sig."
     58 I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" Q "0^Drug is No longer used by Outpatient Pharmacy."
     59 I $G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) Q "0^This Drug has been Inactivated."
     60 I $P(PSODRUG0,"^",3)["A",$P(PSODRUG0,"^",3)'["B" Q "0^Non-Renewable Drug Narcotic."
     61 I $P(PSODRUG0,"^",3)["W" Q "0^Non-Renewable Drug."
     62 I $D(^PS(53,+$P(RX0,"^",3),0)),'$P(^(0),"^",5) Q "0^Non-Renewable Prescription."
     63 S PSOLC=$P(RX0,"^"),PSOLC=$E(PSOLC,$L(PSOLC)) I $A(PSOLC)'<90 Q "0^Max number of renewals (26) has been reached."
     64 I ST,ST'=2,ST'=5,ST'=6,ST'=11,ST'=12,ST'=14 Q "0^Prescritpion is in a Non-Renewable Status."
     65 I $P($G(^PSRX(RXN,"OR1")),"^",4) Q "0^Duplicate Rx Renewal Request."
     66 I $O(^PS(52.41,"AQ",RXN,0)) Q "0^Duplicate Rx Renewal Request."
     67 K PSORFRM,PSOLC,PSODRG,PSODRUG0,RXN,ST
     68 Q 1_$S($G(PSOIFLAG):"^"_$G(PSONEWOI),1:"")
     69 ;
     70INST1 ;Set Pharmacy Instructions array
     71 N PSOTZ
     72 I $O(^PSRX(RXN,"PI",0)) S PHI=$G(^PSRX(RXN,"PI",0)),PSOTZ=0 D
     73 .F  S PSOTZ=$O(^PSRX(RXN,"PI",PSOTZ)) Q:PSOTZ=""  S PHI(PSOTZ)=$G(^PSRX(RXN,"PI",PSOTZ,0))
     74 Q
     75INST2 ;Set Instructions and Comments
     76 I '$G(PSORENW("OIRXN")) Q
     77 I $G(PSOFDR) Q
     78 N PSOPHL,PSOPRL
     79 I $O(^PSRX(PSORENW("OIRXN"),"PI",0)) K PHI S PHI=$G(^PSRX(PSORENW("OIRXN"),"PI",0)),PSOPHL="" D
     80 .F  S PSOPHL=$O(^PSRX(PSORENW("OIRXN"),"PI",PSOPHL)) Q:PSOPHL=""  S PHI(PSOPHL)=$G(^PSRX(PSORENW("OIRXN"),"PI",PSOPHL,0))
     81 I $O(^PSRX(PSORENW("OIRXN"),"PRC",0)) K PRC S PRC=$G(^PSRX(PSORENW("OIRXN"),"PRC",0)),PSOPRL="" D
     82 .F  S PSOPRL=$O(^PSRX(PSORENW("OIRXN"),"PRC",PSOPRL)) Q:PSOPRL=""  S PRC(PSOPRL)=$G(^PSRX(PSORENW("OIRXN"),"PRC",PSOPRL,0))
     83 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW0.m

    r613 r623  
    1 PSORENW0        ;IHS/DSD/JCM-renew main driver continuation ;4/24/07 9:05am
    2         ;;7.0;OUTPATIENT PHARMACY;**11,27,32,59,64,46,71,96,100,130,237,206**;DEC 1997;Build 39
    3         ;External reference to ^PS(50.7 supported by DBIA 2223
    4         ;External reference to ^PSDRUG supported by DBIA 221
    5         ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
    6         ;
    7         ;PSO*237 was not adding to Clozapine Override file, fix
    8 PROCESS ;
    9         D ^PSORENW1
    10         D INST2^PSORENW
    11         I $D(PSORX("BAR CODE")),PSODFN'=PSORENW("PSODFN") D NEWPT
    12         S PSORENW("DFLG")=0,PSORENW("FILL DATE")=PSORNW("FILL DATE")
    13         I $G(PSORNW("MAIL/WINDOW"))]"" S PSORENW("MAIL/WINDOW")=PSORNW("MAIL/WINDOW")
    14         W !!,"Now Renewing Rx # "_PSORENW("ORX #")_"   Drug: "_$P($G(^PSDRUG(+$G(PSORENW("DRUG IEN")),0)),"^"),!
    15         D CHECK G:PSORENW("DFLG") PROCESSX
    16         D FILDATE
    17         D DRUG G:PSORENW("DFLG")!PSORX("DFLG") PROCESSX
    18         D RXN G:PSORENW("DFLG") PROCESSX
    19         D STOP^PSORENW1,OERR^PSORENW1:$G(PSOFDR)
    20 DSPL    K PSOEDT,PSOLM D DSPLY^PSORENW3 G:PSORENW("DFLG") PROCESSX
    21         S PSORENW("QFLG")=0 D:'$G(PSOFDR) EDIT
    22         G:PSORENW("DFLG")!$G(PSORX("FN")) PROCESSX
    23         G:'$G(PSORX("FN"))&('$G(PSORENW("QFLG"))) DSPL
    24         D:$D(^XUSEC("PSORPH",DUZ))!('$P(PSOPAR,"^",2)) VER1^PSOORNE4(.PSORENW) I PSORENW("DFLG")=1 G PROCESSX
    25         I $G(NEWDOSE),PSORENW("ENT")>0 K NEWDOSE G DSPL
    26         D EN^PSORN52(.PSORENW)
    27         D RNPSOSD^PSOUTIL
    28         D CAN,DCORD^PSONEW2
    29         S BBRN="",BBRN1=$O(^PSRX("B",PSORENW("NRX #"),BBRN)) I $P($G(^PSRX(BBRN1,0)),"^",11)["W" S BINGCRT="Y",BINGRTE="W"
    30         ;PSO*237 add to Clozapine Override file
    31 ANQ     I $G(ANQDATA)]"" D NOW^%DTC G:$D(^PS(52.52,"B",%)) ANQ D
    32         . K DD,DO S DIC="^PS(52.52,",DIC(0)="L",DLAYGO=52.52,X=%
    33         . D FILE^DICN K DIC,DLAYGO,DD,DO,DA,DR
    34         . N PS52 S (PS52,DA)=+Y,DIE="^PS(52.52,",DR="1////"_PSORENW("IRXN")
    35         . D ^DIE K DIE,DA,DR
    36         . S $P(^PS(52.52,PS52,0),"^",3,6)=ANQDATA
    37         . K ANQDATA,X,Y,%,ANQREM
    38         ;
    39 PROCESSX        I PSORENW("DFLG")!$G(PSRX("DFLG")) S PSOBBCLK=1 W:'$G(POERR) !,$C(7),"RENEWED RX DELETED",! D:$P($G(PSOLST(+$G(ORN))),"^",2) PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) S POERR("DFLG")=1 D CLEAN^PSOVER1
    40         D:$G(PSORENW("OLD FILL DATE"))]"" SUSDATEK^PSOUTIL(.PSORENW)
    41         K PRC,PHI,PSOQUIT,BBRN,BBRN1,PSORENW,PSODRUG,PSORX("PROVIDER NAME"),PSORX("CLINIC"),PSORX("FN")
    42         K PSOEDT,PSOLM S:$G(PSORENW("FROM"))="" (PSORENW("DFLG"),PSORENW("QFLG"))=0
    43         D CLEAN^PSOVER1
    44         Q
    45         ;
    46 CHECK   ;
    47         I '$D(PSORX("BAR CODE")),PSORENW("PSODFN")'=PSODFN D  G CHECKX
    48         .W !!,?5,$C(7),"Can't renew Rx # "_$P(PSORENW("RX0"),"^")_", it is not for this patient." S PSORENW("DFLG")=1
    49         .S:$G(POERR) VALMSG="Can't renew Rx # "_$P(PSORENW("RX0"),"^")_", not for this patient.",VALMBCK="R"
    50         ;Invalid dosage check
    51         N PSOOCPRX,PSOOLPF,PSOOLPD,PSONOSIG S PSOOCPRX=PSORENW("OIRXN") D CDOSE
    52         I PSOOLPF!(PSONOSIG) D  G CHECKX
    53         .S PSORENW("DFLG")=1
    54         .W !!,$C(7),"Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_$S(PSOOLPF:", invalid dosage of "_$G(PSOOLPD),1:", Missing Sig")
    55         .S:$G(POERR) VALMSG="Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_$S(PSOOLPF:", invalid Dosage of "_$G(PSOOLPD),1:", Missing Sig") S VALMBCK="R"
    56         .I '$G(PSORNSPD) W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
    57         .I $G(PSORNSPD) W !
    58         ;
    59         S (PSOS,PSOX,PSOY)="" K ACOM,DIR,DIRUT,DIRUT,DUOUT
    60         I $G(PSOSD) F  S PSOS=$O(PSOSD(PSOS)) Q:PSOS=""  F  S PSOX=$O(PSOSD(PSOS,PSOX)) Q:PSOX']""!(PSORENW("DFLG"))  I PSORENW("OIRXN")=+PSOSD(PSOS,PSOX) S PSOY=PSOSD(PSOS,PSOX) I $TR($P(PSOY,"^",3),"B")]"" D  K ACOM,DIR,DIRUT,DIRUT,DUOUT
    61         . S PSORENW("DFLG")=1
    62         . W !,$C(7),"Cannot renew Rx # ",$P(PSORENW("RX0"),"^")
    63         . S PSOREA=$P(PSOY,"^",3),PSOSTAT=+PSORENW("STA")
    64         . D STATUS^PSOUTIL(PSOREA,PSOSTAT) K PSOREA,PSOSTAT
    65         .I $G(ACOM)]"" D
    66         ..S DRG=$P(^PSDRUG($P(^PSRX(PSORENW("OIRXN"),0),"^",6),0),"^")
    67         ..W ! S DIR(0)="Y",DIR("A",1)="Do you want to Discontinue this Pending Order",DIR("A")="for "_DRG,DIR("B")="No"
    68         ..D ^DIR I 'Y!($D(DIRUT)) Q
    69         ..D NOOR^PSOCAN4 Q:$D(DIRUT)  D DE^PSOORFI2
    70         .Q
    71         I PSOY="",'$G(PSOORRNW) D
    72         .W !,$C(7),"Cannot renew Rx # ",$P(PSORENW("RX0"),"^")," later Rx exists." S PSORENW("DFLG")=1
    73         .S:$G(POERR) VALMSG="Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_" later Rx exists.",VALMBCK="R"
    74         K PSOX,PSOY G:PSORENW("DFLG") CHECKX
    75         ;
    76         I $A($E(PSORENW("ORX #"),$L(PSORENW("ORX #"))))'<90 D  Q
    77         . W !,$C(7),"Cannot renew Rx # "_PSORENW("ORX #")_", Max number of renewals reached."
    78         .S:$G(POERR)!('$G(SPEED)) (ACOM,VALMSG)="Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached.",VALMBCK="R"
    79         . S PSORENW("DFLG")=1
    80         .I $G(OR0)]"" D
    81         ..S DRG=$P(^PSDRUG($P(^PSRX(PSORENW("OIRXN"),0),"^",6),0),"^")
    82         ..W ! S DIR(0)="Y",DIR("A",1)="Do you want to Discontinue this Pending Order",DIR("A")="for "_DRG,DIR("B")="No"
    83         ..D ^DIR I 'Y!($D(DIRUT)) Q
    84         ..D NOOR^PSOCAN4 Q:$D(DIRUT)  D DE^PSOORFI2
    85         .K ACOM Q
    86         D CHKDIV G:PSORENW("DFLG") CHECKX
    87         ;
    88         D CHKPRV^PSOUTIL
    89 CHECKX  Q
    90         ;
    91 CHKDIV  ;
    92         G:$P(PSORENW("RX2"),"^",9)=+PSOSITE CHKDIVX
    93         W !?5,$C(7),"RX # ",$P(PSORENW("RX0"),"^")," is for (",$P(^PS(59,$P(PSORENW("RX2"),"^",9),0),"^"),") division."
    94         I '$P($G(PSOSYS),"^",2) S PSORENW("DFLG")=1 G CHKDIVX
    95         D:$P($G(PSOSYS),"^",3) DIR
    96 CHKDIVX Q
    97         ;
    98 DRUG    ;
    99         K PSOY
    100         S PSOY=PSORENW("DRUG IEN"),PSOY(0)=^PSDRUG(PSOY,0)
    101         I '$P($G(^PSDRUG(PSOY,2)),"^") D  Q:$G(PSORX("DFLG"))
    102         .I $P($G(^PSRX(PSORENW("OIRXN"),"OR1")),"^") S PSODRUG("OI")=$P(^PSRX(PSORENW("OIRXN"),"OR1"),"^"),PSODRUG("OIN")=$P(^PS(50.7,+^("OR1"),0),"^") Q
    103         .W !!,"Cannot Renew!!  No Pharmacy Orderable Item!" S VALMSG="Cannot Renew!!  No Pharmacy Orderable Item!",PSORX("DFLG")=1
    104         D SET^PSODRG
    105         D POST^PSODRG S:PSORX("DFLG") PSORENW("DFLG")=1 ;remove order checks for v7. do allergy checks only
    106         ;D ^PSODRDUP Q:$G(PSORX("DFLG"))  ; Set PSORX("DFLG")=1 if process to stop
    107         S PSONOOR=PSORENW("NOO")
    108         ;I $G(PSODRUG("NDF")) S NDF=$P(PSODRUG("NDF"),"A"),VAP=$P(PSODRUG("NDF"),"A",2),PTR=NDF_"."_VAP D CHK^PSODGAL(PSODFN,"DR",PTR) K NDF,VAP,PTR
    109         ;I '$G(PSODRUG("NDF")) D CHK1^PSODGAL(PSODFN)
    110         K PSORX("INTERVENE")
    111         S:$D(PSONEW("STATUS")) PSORENW("STATUS")=PSONEW("STATUS")
    112         K PSOY,PSONEW("STATUS")
    113         Q
    114         ;
    115 RXN     ;
    116         K PSOX
    117         S PSOX=$E(PSORENW("ORX #"),$L(PSORENW("ORX #")))
    118         S PSORENW("NRX #")=$S(PSOX?1N:PSORENW("ORX #")_"A",1:$E(PSORENW("ORX #"),1,$L(PSORENW("ORX #"))-1)_$C($A(PSOX)+1))
    119 RETRY   I $O(^PSRX("B",PSORENW("NRX #"),0)) D  G:'$G(PSORENW("DFLG")) RETRY
    120         .W:$A($E(PSORENW("NRX #"),$L(PSORENW("ORX #"))))'=90 !,"Rx # "_PSORENW("NRX #")_" is already on file."
    121         .S:$G(PSOFDR) VALMSG="Rx # "_PSORENW("NRX #")_" is already on file."
    122         .I $A($E(PSORENW("NRX #"),$L(PSORENW("ORX #"))))=90 D
    123         ..W !,"Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"_PSORENW("ORX #")_".",!,"A new Rx must be entered.",!
    124         ..S:$G(PSOFDR) VALMSG="Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"_PSORENW("ORX #")_". A new Rx must be entered."
    125         ..K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
    126         ..S:$G(POERR)!($G(PSOFDR)) VALMSG="Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached.",VALMBCK="R" S PSORENW("DFLG")=1
    127         .S PSOX=$E(PSORENW("NRX #"),$L(PSORENW("NRX #")))
    128         .S PSORENW("NRX #")=$S(PSOX?1N:PSORENW("NRX #")_"A",1:$E(PSORENW("NRX #"),1,$L(PSORENW("NRX #"))-1)_$C($A(PSOX)+1))
    129 RXNX    K PSOX
    130         Q
    131         ;
    132 FILDATE ;
    133         S PSORENW("IRXN")=PSORENW("OIRXN")
    134         D NEXT^PSOUTIL(.PSORENW)
    135         I PSORENW("FILL DATE")<$P(PSORENW("RX3"),"^",2) D
    136         .D RENFDT^PSOUTIL(.PSORENW)
    137         .I PSORENW("FILL DATE")<DT,PSORENW("FILL DATE")<PSORNW("FILL DATE") S (Y,PSORENW("FILL DATE"))=DT X ^DD("DD") S PSORX("FILL DATE")=Y K Y
    138         K PSORENW("IRXN")
    139         Q
    140         ;
    141 EDIT    ;
    142         K DIR,X,Y
    143         S DIR(0)="Y",DIR("B")=$S($G(DUZ("AG"))'="I":"Y",$G(PSEXDT):"Y",1:"N")
    144         S DIR("A")="Edit renewed Rx ",DIR("?")="Answer YES to edit the renewed Rx, NO not to."
    145         D ^DIR K DIR S:$D(DIRUT) PSORENW("DFLG")=1
    146         G:PSORENW("DFLG") EDITX
    147         K PSOQUIT,PSORX("FN") I Y D INIT^PSORENW3,EN^PSOORNE4(.PSORENW) S:$G(PSOQUIT) PSORENW("DFLG")=1 I '$G(PSORX("FN")) D FULL^VALM1 Q
    148         Q:$G(PSORX("FN"))
    149 EDITX   S PSOEDT=1,VALMBCK="Q" K X,Y,DIRUT,DTOUT,DUOUT S PSORENW("QFLG")=1
    150         Q
    151         ;
    152 DELETE  ;
    153         K DA,DIK
    154         S DA=$O(^PS(52.5,"B",PSORENW("OIRXN"),0)),DIK="^PS(52.5,"
    155         D ^DIK K DIK,DIC
    156         Q
    157         ;
    158 CAN     ;
    159         K REA,DA,MSG
    160         S REA="C",DA=PSORENW("OIRXN")
    161         S MSG="Renewed"_$S($G(PSOFDR):" from CPRS",1:"")
    162         S PSCAN(PSORENW("ORX #"))=DA_"^C"
    163         D CAN^PSOCAN
    164         K REA,DA,MSG,PSCAN
    165         Q
    166         ;
    167 DIR     ;
    168         S DIR(0)="Y",DIR("A")="CONTINUE ",DIR("B")="N"
    169         S DIR("?")="Answer YES to Continue, NO to bypass"
    170         D ^DIR K DIR
    171         S:$D(DIRUT)!('Y) PSORENW("DFLG")=1
    172 DIRX    K DIRUT,DTOUT,DUOUT,X,Y
    173         Q
    174 NEWPT   ;
    175         S PSOQFLG=0
    176         S PSODFN=PSORENW("PSODFN")
    177         D ^PSOPTPST I PSOQFLG S PSORENW("DFLG")=1,PSOQFLG=0 G NEWPTX
    178         D PROFILE^PSOREF1
    179 NEWPTX  Q
    180         ;
    181 EN(PSORENW)            ; Entry Point for Batch Barcode Option
    182         S PSORENRX=$G(PSOBBC("OIRXN"))
    183         I $G(PSORENRX) D PSOL^PSSLOCK(PSORENRX) I '$G(PSOMSG) D  K DIR,PSOMSG W ! S DIR("A")="Press Return to continue",DIR(0)="E" D ^DIR K DIR W ! Q
    184         .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P(PSOMSG,"^",2) Q
    185         .W $C(7),!!,"Another person is editing Rx "_$P($G(^PSRX(PSORENRX,0)),"^")
    186         K PSOMSG,PSOBBCLK S PSOBARCD=1 D PROCESS K PSOBARCD
    187         D KLIB^PSORENW1
    188         I $G(PSORENRX),$G(PSOBBCLK) D PSOUL^PSSLOCK(PSORENRX)
    189         K PSORENRX,PSOBBCLK
    190         Q
    191 CDOSE   ;Validate Dosage field on Renewel, Copy, Edit
    192         ;PSOOCPRX must be set to internal Rx number
    193         Q:'$G(PSOOCPRX)
    194         N PSOOLP,PSOOKZ
    195         S PSOOLP="",(PSOOLPF,PSONOSIG)=0 F  S PSOOLP=$O(^PSRX(PSOOCPRX,6,PSOOLP)) Q:PSOOLP=""!(PSOOLPF)  I $P($G(^PSRX(PSOOCPRX,6,PSOOLP,0)),"^")["0.." S PSOOLPD=$P($G(^(0)),"^"),PSOOLPF=1
    196         Q:PSOOLPF
    197         S PSOOKZ=0
    198         I $P($G(^PSRX(PSOOCPRX,"SIG")),"^",2) S PSOOLP="" F  S PSOOLP=$O(^PSRX(PSOOCPRX,"SIG1",PSOOLP)) Q:PSOOLP=""!(PSOOKZ)  I $G(^PSRX(PSOOCPRX,"SIG1",PSOOLP,0))'="" S PSOOKZ=1
    199         I '$P($G(^PSRX(PSOOCPRX,"SIG")),"^",2),$P($G(^("SIG")),"^")'="" S PSOOKZ=1
    200         I 'PSOOKZ S PSONOSIG=1
    201         Q
     1PSORENW0 ;IHS/DSD/JCM-renew main driver continuation ;2/8/06 8:40am
     2 ;;7.0;OUTPATIENT PHARMACY;**11,27,32,59,64,46,71,96,100,130,237**;DEC 1997
     3 ;External reference to ^PS(50.7 supported by DBIA 2223
     4 ;External reference to ^PSDRUG supported by DBIA 221
     5 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
     6 ;
     7 ;PSO*237 was not adding to Clozapine Override file, fix
     8PROCESS ;
     9 D ^PSORENW1
     10 D INST2^PSORENW
     11 I $D(PSORX("BAR CODE")),PSODFN'=PSORENW("PSODFN") D NEWPT
     12 S PSORENW("DFLG")=0,PSORENW("FILL DATE")=PSORNW("FILL DATE")
     13 I $G(PSORNW("MAIL/WINDOW"))]"" S PSORENW("MAIL/WINDOW")=PSORNW("MAIL/WINDOW")
     14 W !!,"Now Renewing Rx # "_PSORENW("ORX #")_"   Drug: "_$P($G(^PSDRUG(+$G(PSORENW("DRUG IEN")),0)),"^"),!
     15 D CHECK G:PSORENW("DFLG") PROCESSX
     16 D FILDATE
     17 D DRUG G:PSORENW("DFLG")!PSORX("DFLG") PROCESSX
     18 D RXN G:PSORENW("DFLG") PROCESSX
     19 D STOP^PSORENW1,OERR^PSORENW1:$G(PSOFDR)
     20DSPL K PSOEDT,PSOLM D DSPLY^PSORENW3 G:PSORENW("DFLG") PROCESSX
     21 S PSORENW("QFLG")=0 D:'$G(PSOFDR) EDIT
     22 G:PSORENW("DFLG")!$G(PSORX("FN")) PROCESSX
     23 G:'$G(PSORX("FN"))&('$G(PSORENW("QFLG"))) DSPL
     24 D:$D(^XUSEC("PSORPH",DUZ))!('$P(PSOPAR,"^",2)) VER1^PSOORNE4(.PSORENW) I PSORENW("DFLG")=1 G PROCESSX
     25 I $G(NEWDOSE),PSORENW("ENT")>0 K NEWDOSE G DSPL
     26 D EN^PSORN52(.PSORENW)
     27 D RNPSOSD^PSOUTIL
     28 D CAN,DCORD^PSONEW2
     29 S BBRN="",BBRN1=$O(^PSRX("B",PSORENW("NRX #"),BBRN)) I $P($G(^PSRX(BBRN1,0)),"^",11)["W" S BINGCRT="Y",BINGRTE="W"
     30 ;PSO*237 add to Clozapine Override file
     31ANQ I $G(ANQDATA)]"" D NOW^%DTC G:$D(^PS(52.52,"B",%)) ANQ D
     32 . K DD,DO S DIC="^PS(52.52,",DIC(0)="L",DLAYGO=52.52,X=%
     33 . D FILE^DICN K DIC,DLAYGO,DD,DO,DA,DR
     34 . N PS52 S (PS52,DA)=+Y,DIE="^PS(52.52,",DR="1////"_PSORENW("IRXN")
     35 . D ^DIE K DIE,DA,DR
     36 . S $P(^PS(52.52,PS52,0),"^",3,6)=ANQDATA
     37 . K ANQDATA,X,Y,%,ANQREM
     38 ;
     39PROCESSX I PSORENW("DFLG")!$G(PSRX("DFLG")) S PSOBBCLK=1 W:'$G(POERR) !,$C(7),"RENEWED RX DELETED",! D:$P($G(PSOLST(+$G(ORN))),"^",2) PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) S POERR("DFLG")=1 D CLEAN^PSOVER1
     40 D:$G(PSORENW("OLD FILL DATE"))]"" SUSDATEK^PSOUTIL(.PSORENW)
     41 K PRC,PHI,PSOQUIT,BBRN,BBRN1,PSORENW,PSODRUG,PSORX("PROVIDER NAME"),PSORX("CLINIC"),PSORX("FN")
     42 K PSOEDT,PSOLM S:$G(PSORENW("FROM"))="" (PSORENW("DFLG"),PSORENW("QFLG"))=0
     43 D CLEAN^PSOVER1
     44 Q
     45 ;
     46CHECK ;
     47 I '$D(PSORX("BAR CODE")),PSORENW("PSODFN")'=PSODFN D  G CHECKX
     48 .W !!,?5,$C(7),"Can't renew Rx # "_$P(PSORENW("RX0"),"^")_", it is not for this patient." S PSORENW("DFLG")=1
     49 .S:$G(POERR) VALMSG="Can't renew Rx # "_$P(PSORENW("RX0"),"^")_", not for this patient.",VALMBCK="R"
     50 ;Invalid dosage check
     51 N PSOOCPRX,PSOOLPF,PSOOLPD,PSONOSIG S PSOOCPRX=PSORENW("OIRXN") D CDOSE
     52 I PSOOLPF!(PSONOSIG) D  G CHECKX
     53 .S PSORENW("DFLG")=1
     54 .W !!,$C(7),"Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_$S(PSOOLPF:", invalid dosage of "_$G(PSOOLPD),1:", Missing Sig")
     55 .S:$G(POERR) VALMSG="Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_$S(PSOOLPF:", invalid Dosage of "_$G(PSOOLPD),1:", Missing Sig") S VALMBCK="R"
     56 .I '$G(PSORNSPD) W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
     57 .I $G(PSORNSPD) W !
     58 ;
     59 S (PSOS,PSOX,PSOY)="" K ACOM,DIR,DIRUT,DIRUT,DUOUT
     60 I $G(PSOSD) F  S PSOS=$O(PSOSD(PSOS)) Q:PSOS=""  F  S PSOX=$O(PSOSD(PSOS,PSOX)) Q:PSOX']""!(PSORENW("DFLG"))  I PSORENW("OIRXN")=+PSOSD(PSOS,PSOX) S PSOY=PSOSD(PSOS,PSOX) I $P(PSOY,"^",3)]"" D  K ACOM,DIR,DIRUT,DIRUT,DUOUT
     61 . S PSORENW("DFLG")=1
     62 . W !,$C(7),"Cannot renew Rx # ",$P(PSORENW("RX0"),"^")
     63 . S PSOREA=$P(PSOY,"^",3),PSOSTAT=+PSORENW("STA")
     64 . D STATUS^PSOUTIL(PSOREA,PSOSTAT) K PSOREA,PSOSTAT
     65 .I $G(ACOM)]"" D
     66 ..S DRG=$P(^PSDRUG($P(^PSRX(PSORENW("OIRXN"),0),"^",6),0),"^")
     67 ..W ! S DIR(0)="Y",DIR("A",1)="Do you want to Discontinue this Pending Order",DIR("A")="for "_DRG,DIR("B")="No"
     68 ..D ^DIR I 'Y!($D(DIRUT)) Q
     69 ..D NOOR^PSOCAN4 Q:$D(DIRUT)  D DE^PSOORFI2
     70 .Q
     71 I PSOY="",'$G(PSOORRNW) D
     72 .W !,$C(7),"Cannot renew Rx # ",$P(PSORENW("RX0"),"^")," later Rx exists." S PSORENW("DFLG")=1
     73 .S:$G(POERR) VALMSG="Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_" later Rx exists.",VALMBCK="R"
     74 K PSOX,PSOY G:PSORENW("DFLG") CHECKX
     75 ;
     76 I $A($E(PSORENW("ORX #"),$L(PSORENW("ORX #"))))'<90 D  Q
     77 . W !,$C(7),"Cannot renew Rx # "_PSORENW("ORX #")_", Max number of renewals reached."
     78 .S:$G(POERR)!('$G(SPEED)) (ACOM,VALMSG)="Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached.",VALMBCK="R"
     79 . S PSORENW("DFLG")=1
     80 .I $G(OR0)]"" D
     81 ..S DRG=$P(^PSDRUG($P(^PSRX(PSORENW("OIRXN"),0),"^",6),0),"^")
     82 ..W ! S DIR(0)="Y",DIR("A",1)="Do you want to Discontinue this Pending Order",DIR("A")="for "_DRG,DIR("B")="No"
     83 ..D ^DIR I 'Y!($D(DIRUT)) Q
     84 ..D NOOR^PSOCAN4 Q:$D(DIRUT)  D DE^PSOORFI2
     85 .K ACOM Q
     86 D CHKDIV G:PSORENW("DFLG") CHECKX
     87 ;
     88 D CHKPRV^PSOUTIL
     89CHECKX Q
     90 ;
     91CHKDIV ;
     92 G:$P(PSORENW("RX2"),"^",9)=+PSOSITE CHKDIVX
     93 W !?5,$C(7),"RX # ",$P(PSORENW("RX0"),"^")," is for (",$P(^PS(59,$P(PSORENW("RX2"),"^",9),0),"^"),") division."
     94 I '$P($G(PSOSYS),"^",2) S PSORENW("DFLG")=1 G CHKDIVX
     95 D:$P($G(PSOSYS),"^",3) DIR
     96CHKDIVX Q
     97 ;
     98DRUG ;
     99 K PSOY
     100 S PSOY=PSORENW("DRUG IEN"),PSOY(0)=^PSDRUG(PSOY,0)
     101 I '$P($G(^PSDRUG(PSOY,2)),"^") D  Q:$G(PSORX("DFLG"))
     102 .I $P($G(^PSRX(PSORENW("OIRXN"),"OR1")),"^") S PSODRUG("OI")=$P(^PSRX(PSORENW("OIRXN"),"OR1"),"^"),PSODRUG("OIN")=$P(^PS(50.7,+^("OR1"),0),"^") Q
     103 .W !!,"Cannot Renew!!  No Pharmacy Orderable Item!" S VALMSG="Cannot Renew!!  No Pharmacy Orderable Item!",PSORX("DFLG")=1
     104 D SET^PSODRG
     105 D POST^PSODRG S:PSORX("DFLG") PSORENW("DFLG")=1 ;remove order checks for v7. do allergy checks only
     106 ;D ^PSODRDUP Q:$G(PSORX("DFLG"))  ; Set PSORX("DFLG")=1 if process to stop
     107 S PSONOOR=PSORENW("NOO")
     108 ;I $G(PSODRUG("NDF")) S NDF=$P(PSODRUG("NDF"),"A"),VAP=$P(PSODRUG("NDF"),"A",2),PTR=NDF_"."_VAP D CHK^PSODGAL(PSODFN,"DR",PTR) K NDF,VAP,PTR
     109 ;I '$G(PSODRUG("NDF")) D CHK1^PSODGAL(PSODFN)
     110 K PSORX("INTERVENE")
     111 S:$D(PSONEW("STATUS")) PSORENW("STATUS")=PSONEW("STATUS")
     112 K PSOY,PSONEW("STATUS")
     113 Q
     114 ;
     115RXN ;
     116 K PSOX
     117 S PSOX=$E(PSORENW("ORX #"),$L(PSORENW("ORX #")))
     118 S PSORENW("NRX #")=$S(PSOX?1N:PSORENW("ORX #")_"A",1:$E(PSORENW("ORX #"),1,$L(PSORENW("ORX #"))-1)_$C($A(PSOX)+1))
     119RETRY I $O(^PSRX("B",PSORENW("NRX #"),0)) D  G:'$G(PSORENW("DFLG")) RETRY
     120 .W:$A($E(PSORENW("NRX #"),$L(PSORENW("ORX #"))))'=90 !,"Rx # "_PSORENW("NRX #")_" is already on file."
     121 .S:$G(PSOFDR) VALMSG="Rx # "_PSORENW("NRX #")_" is already on file."
     122 .I $A($E(PSORENW("NRX #"),$L(PSORENW("ORX #"))))=90 D
     123 ..W !,"Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"_PSORENW("ORX #")_".",!,"A new Rx must be entered.",!
     124 ..S:$G(PSOFDR) VALMSG="Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"_PSORENW("ORX #")_". A new Rx must be entered."
     125 ..K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
     126 ..S:$G(POERR)!($G(PSOFDR)) VALMSG="Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached.",VALMBCK="R" S PSORENW("DFLG")=1
     127 .S PSOX=$E(PSORENW("NRX #"),$L(PSORENW("NRX #")))
     128 .S PSORENW("NRX #")=$S(PSOX?1N:PSORENW("NRX #")_"A",1:$E(PSORENW("NRX #"),1,$L(PSORENW("NRX #"))-1)_$C($A(PSOX)+1))
     129RXNX K PSOX
     130 Q
     131 ;
     132FILDATE ;
     133 S PSORENW("IRXN")=PSORENW("OIRXN")
     134 D NEXT^PSOUTIL(.PSORENW)
     135 I PSORENW("FILL DATE")<$P(PSORENW("RX3"),"^",2) D
     136 .D RENFDT^PSOUTIL(.PSORENW)
     137 .I PSORENW("FILL DATE")<DT,PSORENW("FILL DATE")<PSORNW("FILL DATE") S (Y,PSORENW("FILL DATE"))=DT X ^DD("DD") S PSORX("FILL DATE")=Y K Y
     138 K PSORENW("IRXN")
     139 Q
     140 ;
     141EDIT ;
     142 K DIR,X,Y
     143 S DIR(0)="Y",DIR("B")=$S($G(DUZ("AG"))'="I":"Y",$G(PSEXDT):"Y",1:"N")
     144 S DIR("A")="Edit renewed Rx ",DIR("?")="Answer YES to edit the renewed Rx, NO not to."
     145 D ^DIR K DIR S:$D(DIRUT) PSORENW("DFLG")=1
     146 G:PSORENW("DFLG") EDITX
     147 K PSOQUIT,PSORX("FN") I Y D INIT^PSORENW3,EN^PSOORNE4(.PSORENW) S:$G(PSOQUIT) PSORENW("DFLG")=1 I '$G(PSORX("FN")) D FULL^VALM1 Q
     148 Q:$G(PSORX("FN"))
     149EDITX S PSOEDT=1,VALMBCK="Q" K X,Y,DIRUT,DTOUT,DUOUT S PSORENW("QFLG")=1
     150 Q
     151 ;
     152DELETE ;
     153 K DA,DIK
     154 S DA=$O(^PS(52.5,"B",PSORENW("OIRXN"),0)),DIK="^PS(52.5,"
     155 D ^DIK K DIK,DIC
     156 Q
     157 ;
     158CAN ;
     159 K REA,DA,MSG
     160 S REA="C",DA=PSORENW("OIRXN")
     161 S MSG="Renewed"_$S($G(PSOFDR):" from CPRS",1:"")
     162 S PSCAN(PSORENW("ORX #"))=DA_"^C"
     163 D CAN^PSOCAN
     164 K REA,DA,MSG,PSCAN
     165 Q
     166 ;
     167DIR ;
     168 S DIR(0)="Y",DIR("A")="CONTINUE ",DIR("B")="N"
     169 S DIR("?")="Answer YES to Continue, NO to bypass"
     170 D ^DIR K DIR
     171 S:$D(DIRUT)!('Y) PSORENW("DFLG")=1
     172DIRX K DIRUT,DTOUT,DUOUT,X,Y
     173 Q
     174NEWPT ;
     175 S PSOQFLG=0
     176 S PSODFN=PSORENW("PSODFN")
     177 D ^PSOPTPST I PSOQFLG S PSORENW("DFLG")=1,PSOQFLG=0 G NEWPTX
     178 D PROFILE^PSOREF1
     179NEWPTX Q
     180 ;
     181EN(PSORENW)        ; Entry Point for Batch Barcode Option
     182 S PSORENRX=$G(PSOBBC("OIRXN"))
     183 I $G(PSORENRX) D PSOL^PSSLOCK(PSORENRX) I '$G(PSOMSG) D  K DIR,PSOMSG W ! S DIR("A")="Press Return to continue",DIR(0)="E" D ^DIR K DIR W ! Q
     184 .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P(PSOMSG,"^",2) Q
     185 .W $C(7),!!,"Another person is editing Rx "_$P($G(^PSRX(PSORENRX,0)),"^")
     186 K PSOMSG,PSOBBCLK S PSOBARCD=1 D PROCESS K PSOBARCD
     187 D KLIB^PSORENW1
     188 I $G(PSORENRX),$G(PSOBBCLK) D PSOUL^PSSLOCK(PSORENRX)
     189 K PSORENRX,PSOBBCLK
     190 Q
     191CDOSE ;Validate Dosage field on Renewel, Copy, Edit
     192 ;PSOOCPRX must be set to internal Rx number
     193 Q:'$G(PSOOCPRX)
     194 N PSOOLP,PSOOKZ
     195 S PSOOLP="",(PSOOLPF,PSONOSIG)=0 F  S PSOOLP=$O(^PSRX(PSOOCPRX,6,PSOOLP)) Q:PSOOLP=""!(PSOOLPF)  I $P($G(^PSRX(PSOOCPRX,6,PSOOLP,0)),"^")["0.." S PSOOLPD=$P($G(^(0)),"^"),PSOOLPF=1
     196 Q:PSOOLPF
     197 S PSOOKZ=0
     198 I $P($G(^PSRX(PSOOCPRX,"SIG")),"^",2) S PSOOLP="" F  S PSOOLP=$O(^PSRX(PSOOCPRX,"SIG1",PSOOLP)) Q:PSOOLP=""!(PSOOKZ)  I $G(^PSRX(PSOOCPRX,"SIG1",PSOOLP,0))'="" S PSOOKZ=1
     199 I '$P($G(^PSRX(PSOOCPRX,"SIG")),"^",2),$P($G(^("SIG")),"^")'="" S PSOOKZ=1
     200 I 'PSOOKZ S PSONOSIG=1
     201 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW1.m

    r613 r623  
    1 PSORENW1        ;BIR/DSD - Renew Main Driver Continuation ;03/29/93
    2         ;;7.0;OUTPATIENT PHARMACY;**20,37,51,46,71,117,157,143,219,239,225**;DEC 1997;Build 29
    3         ;External reference ^VA(200 supported by DBIA 10060
    4         ;
    5 START   ;
    6         S PSORENW("RX0")=^PSRX(PSORENW("OIRXN"),0),PSORENW("RX2")=^(2),PSORENW("RX3")=^(3),PSORENW("STA")=^("STA"),PSORENW("TN")=$G(^("TN")),SIGOK=+$P($G(^("SIG")),"^",2)
    7         S PSOIBOLD=$G(PSORENW("OIRXN"))
    8         D SETIB
    9         S PSORENW("PROVIDER")=$P(PSORENW("RX0"),"^",4)
    10         S PSORX("PROVIDER NAME")=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^")
    11         S PSORENW("CLINIC")=$P(PSORENW("RX0"),"^",5),PSORENW("COPIES")=$P(PSORENW("RX0"),"^",18)
    12         I $G(PSOFDR),$P($G(OR0),"^",13) S PSORENW("CLINIC")=$P($G(OR0),"^",13)
    13         S PSORENW("REMARKS")="RENEWED FROM RX # "_$P(PSORENW("RX0"),"^")
    14         S PSORENW("SIG")=$P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^")
    15         S:$P(PSORENW("RX3"),"^",3) PSORENW("COSIGNING PROVIDER")=$P(PSORENW("RX3"),"^",3)
    16         S (PSODFN,PSORENW("PSODFN"))=$P(PSORENW("RX0"),"^",2)
    17         S PSORENW("ORX #")=$P(PSORENW("RX0"),"^")
    18         S PSORENW("DRUG IEN")=$P(PSORENW("RX0"),"^",6)
    19         S PSORENW("INS")=$S($G(PSORENW("INS"))]"":PSORENW("INS"),1:$G(^PSRX(PSORENW("OIRXN"),"INS")))
    20         S D=0 F  S D=$O(^PSRX(PSORENW("OIRXN"),"INS1",D)) Q:'D  S PSORENW("SIG",D)=^PSRX(PSORENW("OIRXN"),"INS1",D,0)
    21         I '$O(PSORENW("SIG",0)),$G(PSORENW("INS"))]"" S PSORENW("SIG",1)=PSORENW("INS")
    22         G:$G(PSORENW("ENT")) FDR
    23         I $G(PSORENW("ENT"))'>0,'$O(^PSRX(PSORENW("OIRXN"),6,0)) S PSORENW("ENT")=0 G FDR
    24         F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),6,I)) Q:'I  S DOSE=^PSRX(PSORENW("OIRXN"),6,I,0) D
    25         .S PSORENW("ENT")=$G(PSORENW("ENT"))+1,PSORENW("DOSE",PSORENW("ENT"))=$P(DOSE,"^")
    26         .S PSORENW("UNITS",PSORENW("ENT"))=$P(DOSE,"^",3),PSORENW("DOSE ORDERED",PSORENW("ENT"))=$P(DOSE,"^",2),PSORENW("ROUTE",PSORENW("ENT"))=$P(DOSE,"^",7)
    27         .S PSORENW("SCHEDULE",PSORENW("ENT"))=$P(DOSE,"^",8),PSORENW("DURATION",PSORENW("ENT"))=$P(DOSE,"^",5),PSORENW("CONJUNCTION",PSORENW("ENT"))=$P(DOSE,"^",6)
    28         .S PSORENW("NOUN",PSORENW("ENT"))=$P(DOSE,"^",4),PSORENW("VERB",PSORENW("ENT"))=$P(DOSE,"^",9)
    29         .I $G(^PSRX(PSORENW("OIRXN"),6,I,1))]"" S PSORENW("ODOSE",PSORENW("ENT"))=^PSRX(PSORENW("OIRXN"),6,I,1)
    30         .K DOSE
    31 FDR     I $G(PSOFDR) D
    32         .F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),6,I)) Q:'I  I $G(^PSRX(PSORENW("OIRXN"),6,I,1))]"" S PSORENW("ODOSE",I)=^PSRX(PSORENW("OIRXN"),6,I,1)
    33         .S $P(PSORENW("RX0"),"^",7)=$P(OR0,"^",10),$P(PSORENW("RX0"),"^",11)=$P(OR0,"^",17)
    34         .S (PSORX("PROVIDER NAME"),PSORENW("PROVIDER NAME"))=$P(^VA(200,$P(OR0,"^",5),0),"^"),PSORENW("PROVIDER")=$P(OR0,"^",5)
    35         .K PSORENW("COSIGNING PROVIDER")
    36         .I $G(PSORENW("PROVIDER")),$P($G(^VA(200,PSORENW("PROVIDER"),"PS")),"^",7),$P($G(^("PS")),"^",8) S PSORENW("COSIGNING PROVIDER")=$P($G(^("PS")),"^",8)
    37         .S (PSDY,PSORENW("DAYS SUPPLY"))=$P(PSORENW("RX0"),"^",8)
    38         .S POERR=1,DREN=$P(PSORENW("RX0"),"^",6) D DRG^PSOORDRG K POERR S PSODIR("CS")=0
    39         .F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S PSODIR("CS")=1
    40         .I PSODIR("CS") S RFMX=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0)
    41         .E  S RFMX=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0)
    42         .S $P(PSORENW("RX0"),"^",9)=$S($P(OR0,"^",11)'>RFMX:$P(OR0,"^",11),1:RFMX),$P(OR0,"^",11)=$P(PSORENW("RX0"),"^",9)
    43         .K RFMX,PSODIR("CS"),PSDY
    44 END     Q
    45 STOP    K PSEXDT,X,%DT S PSON52("QFLG")=0,DAYS=$S($G(PSORENW("DAYS SUPPLY")):PSORENW("DAYS SUPPLY"),1:$P(PSORENW("RX0"),"^",8))
    46         S DEA("CS")=0 K DIR,DIC
    47         F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S DEA("CS")=1
    48         S X1=$S($G(PSORENW("ISSUE DATE")):$G(PSORENW("ISSUE DATE")),1:DT),X2=DAYS*($P(PSORENW("RX0"),"^",9)+1)\1
    49         S X2=$S(DAYS=X2&('DEA("CS")):X2,DEA("CS"):184,1:366) D C^%DTC
    50         I PSORENW("FILL DATE")>$P(X,".") S PSEXDT=1_"^"_$P(X,".")
    51         K X1,X2,X,%DT
    52         Q
    53 OERR    ;renewal finish from oe/rr
    54         S PSORENW("RX0")=^PSRX(PSORENW("OIRXN"),0),PSORENW("RX2")=^(2),PSORENW("RX3")=^(3),PSORENW("STA")=^("STA"),PSORENW("TN")=$G(^("TN"))
    55         S $P(PSORENW("RX0"),"^",4)=$P(OR0,"^",5)
    56         S PSORENW("PROVIDER")=$P(OR0,"^",5)
    57         S PSORX("PROVIDER NAME")=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^")
    58         S $P(PSORENW("RX0"),"^",5)=$P(OR0,"^",13)
    59         S PSORENW("CLINIC")=$P(OR0,"^",13)
    60         S PSORENW("REMARKS")="RENEWED FROM RX # "_$P(PSORENW("RX0"),"^")_"."_$S($P(OR0,"^",17)="C":" Administered in Clinic.",1:"")
    61         S PSORENW("SIG")=$P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^"),SIGOK=$P(^("SIG"),"^",2) I SIGOK D
    62         .F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),"SIG1",I)) Q:'I  S SIG(I)=^PSRX(PSORENW("OIRXN"),"SIG1",I,0)
    63         S:$P(PSORENW("RX3"),"^",3) PSORENW("COSIGNING PROVIDER")=$P(PSORENW("RX3"),"^",3)
    64         S PSORENW("PSODFN")=$P(PSORENW("RX0"),"^",2)
    65         S PSORENW("ORX #")=$P(PSORENW("RX0"),"^")
    66         S PSORENW("DRUG IEN")=$P(PSORENW("RX0"),"^",6),$P(PSORENW("RX0"),"^",11)=$P(OR0,"^",17)
    67         S PSORENW("INS")=$S($G(PSORENW("INS"))]"":PSORENW("INS"),1:$G(^PSRX(PSORENW("OIRXN"),"INS")))
    68         Q:$G(PSORENW("ENT"))>0
    69         F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),6,I)) Q:'I  S DOSE=^PSRX(PSORENW("OIRXN"),6,I,0) D
    70         .S PSORENW("ENT")=PSORENW("ENT")+1,PSORENW("DOSE",PSORENW("ENT"))=$P(DOSE,"^")
    71         .S PSORENW("UNITS",PSORENW("ENT"))=$P(DOSE,"^",3),PSORENW("DOSE ORDERED",PSORENW("ENT"))=$P(DOSE,"^",2),PSORENW("ROUTE",PSORENW("ENT"))=$P(DOSE,"^",7)
    72         .S PSORENW("SCHEDULE",PSORENW("ENT"))=$P(DOSE,"^",8),PSORENW("DURATION",PSORENW("ENT"))=$P(DOSE,"^",5),PSORENW("CONJUNCTION",PSORENW("ENT"))=$P(DOSE,"^",6)
    73         .S PSORENW("NOUN",PSORENW("ENT"))=$P(DOSE,"^",4),PSORENW("VERB",PSORENW("ENT"))=$P(DOSE,"^",9)
    74         .I $G(^PSRX(PSORENW("OIRXN"),6,I,1))]"" S PSORENW("ODOSE",PSORENW("ENT"))=^PSRX(PSORENW("OIRXN"),6,I,1)
    75         .K DOSE
    76         Q
    77         ;
    78 SETIB   ;Set defaults on Renewals with Copay information
    79         ;If answer is in Pending File, use that, else look in Prescription file
    80         N PSOOICD,JJJ
    81         K PSOSCP,PSOANSQ("SC>50") D SCP^PSORN52D S PSOANSQ("SC>50")="" K PSOSCA
    82         I '$G(PSOIBOLD) Q
    83         I $G(PSOFDR),$G(ORD) D SETIBP Q
    84         ;I '$$DT^PSOMLLDT Q
    85         I $G(PSORX(PSOIBOLD,"SC"))'=0,$G(PSORX(PSOIBOLD,"SC"))'=1 S PSORX(PSOIBOLD,"SC")=$S($P($G(^PSRX(PSOIBOLD,"IBQ")),"^")'="":$P($G(^("IBQ")),"^"),$P($G(^PSRX(PSOIBOLD,"IB")),"^"):0,1:"")
    86         I $G(PSORX(PSOIBOLD,"SC"))="" K PSORX(PSOIBOLD,"SC")
    87         I '$$DT^PSOMLLDT Q
    88         I $G(PSORX(PSOIBOLD,"MST"))'=0,$G(PSORX(PSOIBOLD,"MST"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",2)'="" S PSORX(PSOIBOLD,"MST")=$P($G(^("IBQ")),"^",2)
    89         I $G(PSORX(PSOIBOLD,"VEH"))'=0,$G(PSORX(PSOIBOLD,"VEH"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",3)'="" S PSORX(PSOIBOLD,"VEH")=$P($G(^("IBQ")),"^",3)
    90         I $G(PSORX(PSOIBOLD,"RAD"))'=0,$G(PSORX(PSOIBOLD,"RAD"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",4)'="" S PSORX(PSOIBOLD,"RAD")=$P($G(^("IBQ")),"^",4)
    91         I $G(PSORX(PSOIBOLD,"PGW"))'=0,$G(PSORX(PSOIBOLD,"PGW"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",5)'="" S PSORX(PSOIBOLD,"PGW")=$P($G(^("IBQ")),"^",5)
    92         I $G(PSORX(PSOIBOLD,"HNC"))'=0,$G(PSORX(PSOIBOLD,"HNC"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",6)'="" S PSORX(PSOIBOLD,"HNC")=$P($G(^("IBQ")),"^",6)
    93         I $G(PSORX(PSOIBOLD,"CV"))'=0,$G(PSORX(PSOIBOLD,"CV"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",7)'="" S PSORX(PSOIBOLD,"CV")=$P($G(^("IBQ")),"^",7)
    94         I $G(PSORX(PSOIBOLD,"SHAD"))'=0,$G(PSORX(PSOIBOLD,"SHAD"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",8)'="" S PSORX(PSOIBOLD,"SHAD")=$P($G(^("IBQ")),"^",8)
    95         ;
    96 SET2    ;for when patient status is exempt or SC>50
    97         I $TR($G(^PSRX(PSOIBOLD,"IBQ")),"^")="" S PSOOICD=$G(^PSRX(PSOIBOLD,"ICD",1,0)) D SET3:PSOOICD'=""
    98         ;
    99 ICD     I $D(^PSRX(PSORENW("OIRXN"),"ICD",0)) D
    100         . N JJ,ICD,II,FLD,RXN S RXN=PSOIBOLD
    101         . S II=0 F  S II=$O(^PSRX(PSORENW("OIRXN"),"ICD",II)) Q:II=""!(II'?1N.N)  D
    102         .. S ICD=^PSRX(PSORENW("OIRXN"),"ICD",II,0),FLD=$P(ICD,U) D ICD^PSONEWF
    103         Q
    104 SET3    ;for when patient status is exempt or SC>50
    105         D SET3^PSORN52D
    106         Q
    107         ;
    108 SETIBP  ;
    109         I $P($G(^PS(52.41,ORD,0)),"^",16)="SC"!($P($G(^(0)),"^",16)="NSC") S PSORX(PSOIBOLD,"SC")=$S($P($G(^(0)),"^",16)="SC":1,1:0)
    110         I $G(PSORX(PSOIBOLD,"SC"))="" K PSORX(PSOIBOLD,"SC")
    111         I '$$DT^PSOMLLDT Q
    112         N PSOIBQFN S PSOIBQFN=$G(^PS(52.41,ORD,"IBQ"))
    113         I $P(PSOIBQFN,"^",1)=0!($P(PSOIBQFN,"^",1)=1) S PSORX(PSOIBOLD,"MST")=$P(PSOIBQFN,"^")
    114         I $P(PSOIBQFN,"^",2)=0!($P(PSOIBQFN,"^",2)=1) S PSORX(PSOIBOLD,"VEH")=$P(PSOIBQFN,"^",2)
    115         I $P(PSOIBQFN,"^",3)=0!($P(PSOIBQFN,"^",3)=1) S PSORX(PSOIBOLD,"RAD")=$P(PSOIBQFN,"^",3)
    116         I $P(PSOIBQFN,"^",4)=0!($P(PSOIBQFN,"^",4)=1) S PSORX(PSOIBOLD,"PGW")=$P(PSOIBQFN,"^",4)
    117         I $P(PSOIBQFN,"^",5)=0!($P(PSOIBQFN,"^",5)=1) S PSORX(PSOIBOLD,"HNC")=$P(PSOIBQFN,"^",5)
    118         I $P(PSOIBQFN,"^",6)=0!($P(PSOIBQFN,"^",6)=1) S PSORX(PSOIBOLD,"CV")=$P(PSOIBQFN,"^",6)
    119         I $P(PSOIBQFN,"^",7)=0!($P(PSOIBQFN,"^",7)=1) S PSORX(PSOIBOLD,"SHAD")=$P(PSOIBQFN,"^",7)
    120         ;for when patient status is exempt, null IBQ node was set for exempts or SC>50 - data is in ICD node
    121         I $TR($G(^PS(52.41,ORD,"IBQ")),"^")="" S PSOOICD=$G(^PS(52.41,ORD,"ICD",1,0)) D SET3:PSOOICD'=""
    122         ;
    123 ICD2    ;
    124         I $D(^PS(52.41,ORD,"ICD",0)) D
    125         . N JJ,ICD,II,FLD,RXN S RXN=ORD
    126         . S II=0 F  S II=$O(^PS(52.41,ORD,"ICD",II)) Q:II=""!(II'?1N.N)  D
    127         .. S ICD="",ICD=^PS(52.41,ORD,"ICD",II,0)
    128         .. I $G(PSOSCP)>49&(II=1) S PSORX(PSOIBOLD,"SC>50")=$P(ICD,"^",4)
    129         .. S JJ="" F JJ=1:1:9 S FLD=$P(ICD,U,JJ) D ICD^PSONEWF
    130         K PSOIBQFN
    131         Q
    132 KLIB    ;Kill renewal IB array
    133         I '$G(PSOIBOLD) Q
    134         K PSORX(PSOIBOLD,"SC"),PSORX(PSOIBOLD,"MST"),PSORX(PSOIBOLD,"VEH"),PSORX(PSOIBOLD,"RAD"),PSORX(PSOIBOLD,"PGW"),PSORX(PSOIBOLD,"HNC"),PSORX(PSOIBOLD,"CV"),PSORX(PSOIBOLD,"SHAD")
    135         K PSOIBOLD
    136         Q
     1PSORENW1 ;BIR/DSD - Renew Main Driver Continuation ;03/29/93
     2 ;;7.0;OUTPATIENT PHARMACY;**20,37,51,46,71,117,157,143,219,239**;DEC 1997
     3 ;External reference ^VA(200 supported by DBIA 10060
     4 ;
     5START ;
     6 S PSORENW("RX0")=^PSRX(PSORENW("OIRXN"),0),PSORENW("RX2")=^(2),PSORENW("RX3")=^(3),PSORENW("STA")=^("STA"),PSORENW("TN")=$G(^("TN")),SIGOK=+$P($G(^("SIG")),"^",2)
     7 S PSOIBOLD=$G(PSORENW("OIRXN"))
     8 D SETIB
     9 S PSORENW("PROVIDER")=$P(PSORENW("RX0"),"^",4)
     10 S PSORX("PROVIDER NAME")=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^")
     11 S PSORENW("CLINIC")=$P(PSORENW("RX0"),"^",5),PSORENW("COPIES")=$P(PSORENW("RX0"),"^",18)
     12 I $G(PSOFDR),$P($G(OR0),"^",13) S PSORENW("CLINIC")=$P($G(OR0),"^",13)
     13 S PSORENW("REMARKS")="RENEWED FROM RX # "_$P(PSORENW("RX0"),"^")
     14 S PSORENW("SIG")=$P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^")
     15 S:$P(PSORENW("RX3"),"^",3) PSORENW("COSIGNING PROVIDER")=$P(PSORENW("RX3"),"^",3)
     16 S (PSODFN,PSORENW("PSODFN"))=$P(PSORENW("RX0"),"^",2)
     17 S PSORENW("ORX #")=$P(PSORENW("RX0"),"^")
     18 S PSORENW("DRUG IEN")=$P(PSORENW("RX0"),"^",6)
     19 S PSORENW("INS")=$S($G(PSORENW("INS"))]"":PSORENW("INS"),1:$G(^PSRX(PSORENW("OIRXN"),"INS")))
     20 S D=0 F  S D=$O(^PSRX(PSORENW("OIRXN"),"INS1",D)) Q:'D  S PSORENW("SIG",D)=^PSRX(PSORENW("OIRXN"),"INS1",D,0)
     21 I '$O(PSORENW("SIG",0)),$G(PSORENW("INS"))]"" S PSORENW("SIG",1)=PSORENW("INS")
     22 G:$G(PSORENW("ENT")) FDR
     23 I $G(PSORENW("ENT"))'>0,'$O(^PSRX(PSORENW("OIRXN"),6,0)) S PSORENW("ENT")=0 G FDR
     24 F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),6,I)) Q:'I  S DOSE=^PSRX(PSORENW("OIRXN"),6,I,0) D
     25 .S PSORENW("ENT")=$G(PSORENW("ENT"))+1,PSORENW("DOSE",PSORENW("ENT"))=$P(DOSE,"^")
     26 .S PSORENW("UNITS",PSORENW("ENT"))=$P(DOSE,"^",3),PSORENW("DOSE ORDERED",PSORENW("ENT"))=$P(DOSE,"^",2),PSORENW("ROUTE",PSORENW("ENT"))=$P(DOSE,"^",7)
     27 .S PSORENW("SCHEDULE",PSORENW("ENT"))=$P(DOSE,"^",8),PSORENW("DURATION",PSORENW("ENT"))=$P(DOSE,"^",5),PSORENW("CONJUNCTION",PSORENW("ENT"))=$P(DOSE,"^",6)
     28 .S PSORENW("NOUN",PSORENW("ENT"))=$P(DOSE,"^",4),PSORENW("VERB",PSORENW("ENT"))=$P(DOSE,"^",9)
     29 .I $G(^PSRX(PSORENW("OIRXN"),6,I,1))]"" S PSORENW("ODOSE",PSORENW("ENT"))=^PSRX(PSORENW("OIRXN"),6,I,1)
     30 .K DOSE
     31FDR I $G(PSOFDR) D
     32 .F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),6,I)) Q:'I  I $G(^PSRX(PSORENW("OIRXN"),6,I,1))]"" S PSORENW("ODOSE",I)=^PSRX(PSORENW("OIRXN"),6,I,1)
     33 .S $P(PSORENW("RX0"),"^",7)=$P(OR0,"^",10),$P(PSORENW("RX0"),"^",11)=$P(OR0,"^",17)
     34 .S (PSORX("PROVIDER NAME"),PSORENW("PROVIDER NAME"))=$P(^VA(200,$P(OR0,"^",5),0),"^"),PSORENW("PROVIDER")=$P(OR0,"^",5)
     35 .K PSORENW("COSIGNING PROVIDER")
     36 .I $G(PSORENW("PROVIDER")),$P($G(^VA(200,PSORENW("PROVIDER"),"PS")),"^",7),$P($G(^("PS")),"^",8) S PSORENW("COSIGNING PROVIDER")=$P($G(^("PS")),"^",8)
     37 .S (PSDY,PSORENW("DAYS SUPPLY"))=$P(PSORENW("RX0"),"^",8)
     38 .S POERR=1,DREN=$P(PSORENW("RX0"),"^",6) D DRG^PSOORDRG K POERR S PSODIR("CS")=0
     39 .F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S PSODIR("CS")=1
     40 .I PSODIR("CS") S RFMX=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0)
     41 .E  S RFMX=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0)
     42 .S $P(PSORENW("RX0"),"^",9)=$S($P(OR0,"^",11)'>RFMX:$P(OR0,"^",11),1:RFMX),$P(OR0,"^",11)=$P(PSORENW("RX0"),"^",9)
     43 .K RFMX,PSODIR("CS"),PSDY
     44END Q
     45STOP K PSEXDT,X,%DT S PSON52("QFLG")=0,DAYS=$S($G(PSORENW("DAYS SUPPLY")):PSORENW("DAYS SUPPLY"),1:$P(PSORENW("RX0"),"^",8))
     46 S DEA("CS")=0 K DIR,DIC
     47 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S DEA("CS")=1
     48 S X1=$S($G(PSORENW("ISSUE DATE")):$G(PSORENW("ISSUE DATE")),1:DT),X2=DAYS*($P(PSORENW("RX0"),"^",9)+1)\1
     49 S X2=$S(DAYS=X2&('DEA("CS")):X2,DEA("CS"):184,1:366) D C^%DTC
     50 I PSORENW("FILL DATE")>$P(X,".") S PSEXDT=1_"^"_$P(X,".")
     51 K X1,X2,X,%DT
     52 Q
     53OERR ;renewal finish from oe/rr
     54 S PSORENW("RX0")=^PSRX(PSORENW("OIRXN"),0),PSORENW("RX2")=^(2),PSORENW("RX3")=^(3),PSORENW("STA")=^("STA"),PSORENW("TN")=$G(^("TN"))
     55 S $P(PSORENW("RX0"),"^",4)=$P(OR0,"^",5)
     56 S PSORENW("PROVIDER")=$P(OR0,"^",5)
     57 S PSORX("PROVIDER NAME")=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^")
     58 S $P(PSORENW("RX0"),"^",5)=$P(OR0,"^",13)
     59 S PSORENW("CLINIC")=$P(OR0,"^",13)
     60 S PSORENW("REMARKS")="RENEWED FROM RX # "_$P(PSORENW("RX0"),"^")_"."_$S($P(OR0,"^",17)="C":" Administered in Clinic.",1:"")
     61 S PSORENW("SIG")=$P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^"),SIGOK=$P(^("SIG"),"^",2) I SIGOK D
     62 .F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),"SIG1",I)) Q:'I  S SIG(I)=^PSRX(PSORENW("OIRXN"),"SIG1",I,0)
     63 S:$P(PSORENW("RX3"),"^",3) PSORENW("COSIGNING PROVIDER")=$P(PSORENW("RX3"),"^",3)
     64 S PSORENW("PSODFN")=$P(PSORENW("RX0"),"^",2)
     65 S PSORENW("ORX #")=$P(PSORENW("RX0"),"^")
     66 S PSORENW("DRUG IEN")=$P(PSORENW("RX0"),"^",6),$P(PSORENW("RX0"),"^",11)=$P(OR0,"^",17)
     67 S PSORENW("INS")=$S($G(PSORENW("INS"))]"":PSORENW("INS"),1:$G(^PSRX(PSORENW("OIRXN"),"INS")))
     68 Q:$G(PSORENW("ENT"))>0
     69 F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),6,I)) Q:'I  S DOSE=^PSRX(PSORENW("OIRXN"),6,I,0) D
     70 .S PSORENW("ENT")=PSORENW("ENT")+1,PSORENW("DOSE",PSORENW("ENT"))=$P(DOSE,"^")
     71 .S PSORENW("UNITS",PSORENW("ENT"))=$P(DOSE,"^",3),PSORENW("DOSE ORDERED",PSORENW("ENT"))=$P(DOSE,"^",2),PSORENW("ROUTE",PSORENW("ENT"))=$P(DOSE,"^",7)
     72 .S PSORENW("SCHEDULE",PSORENW("ENT"))=$P(DOSE,"^",8),PSORENW("DURATION",PSORENW("ENT"))=$P(DOSE,"^",5),PSORENW("CONJUNCTION",PSORENW("ENT"))=$P(DOSE,"^",6)
     73 .S PSORENW("NOUN",PSORENW("ENT"))=$P(DOSE,"^",4),PSORENW("VERB",PSORENW("ENT"))=$P(DOSE,"^",9)
     74 .I $G(^PSRX(PSORENW("OIRXN"),6,I,1))]"" S PSORENW("ODOSE",PSORENW("ENT"))=^PSRX(PSORENW("OIRXN"),6,I,1)
     75 .K DOSE
     76 Q
     77SETIB ;Set defaults on Renewals with Copay information
     78 ;If answer is in Pending File, use that, else look in Prescription file
     79 N PSOOICD,JJJ
     80 K PSOSCP,PSOANSQ("SC>50") D SCP^PSORN52D S PSOANSQ("SC>50")="" K PSOSCA
     81 I '$G(PSOIBOLD) Q
     82 I $G(PSOFDR),$G(ORD) D SETIBP Q
     83 ;I '$$DT^PSOMLLDT Q
     84 I $G(PSORX(PSOIBOLD,"SC"))'=0,$G(PSORX(PSOIBOLD,"SC"))'=1 S PSORX(PSOIBOLD,"SC")=$S($P($G(^PSRX(PSOIBOLD,"IBQ")),"^")'="":$P($G(^("IBQ")),"^"),$P($G(^PSRX(PSOIBOLD,"IB")),"^"):0,1:"")
     85 I $G(PSORX(PSOIBOLD,"SC"))="" K PSORX(PSOIBOLD,"SC")
     86 I '$$DT^PSOMLLDT Q
     87 I $G(PSORX(PSOIBOLD,"MST"))'=0,$G(PSORX(PSOIBOLD,"MST"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",2)'="" S PSORX(PSOIBOLD,"MST")=$P($G(^("IBQ")),"^",2)
     88 I $G(PSORX(PSOIBOLD,"VEH"))'=0,$G(PSORX(PSOIBOLD,"VEH"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",3)'="" S PSORX(PSOIBOLD,"VEH")=$P($G(^("IBQ")),"^",3)
     89 I $G(PSORX(PSOIBOLD,"RAD"))'=0,$G(PSORX(PSOIBOLD,"RAD"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",4)'="" S PSORX(PSOIBOLD,"RAD")=$P($G(^("IBQ")),"^",4)
     90 I $G(PSORX(PSOIBOLD,"PGW"))'=0,$G(PSORX(PSOIBOLD,"PGW"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",5)'="" S PSORX(PSOIBOLD,"PGW")=$P($G(^("IBQ")),"^",5)
     91 I $G(PSORX(PSOIBOLD,"HNC"))'=0,$G(PSORX(PSOIBOLD,"HNC"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",6)'="" S PSORX(PSOIBOLD,"HNC")=$P($G(^("IBQ")),"^",6)
     92 I $G(PSORX(PSOIBOLD,"CV"))'=0,$G(PSORX(PSOIBOLD,"CV"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",7)'="" S PSORX(PSOIBOLD,"CV")=$P($G(^("IBQ")),"^",7)
     93 ;
     94SET2 ;for when patient status is exempt or SC>50
     95 I $TR($G(^PSRX(PSOIBOLD,"IBQ")),"^")="" S PSOOICD=$G(^PSRX(PSOIBOLD,"ICD",1,0)) D SET3:PSOOICD'=""
     96 ;
     97ICD I $D(^PSRX(PSORENW("OIRXN"),"ICD",0)) D
     98 . N JJ,ICD,II,FLD,RXN S RXN=PSOIBOLD
     99 . S II=0 F  S II=$O(^PSRX(PSORENW("OIRXN"),"ICD",II)) Q:II=""!(II'?1N.N)  D
     100 .. S ICD=^PSRX(PSORENW("OIRXN"),"ICD",II,0),FLD=$P(ICD,U) D ICD^PSONEWF
     101 Q
     102SET3 ;for when patient status is exempt or SC>50
     103 N PSOPATST S PSOPATST=PSORX("PATIENT STATUS")
     104 I PSORX("PATIENT STATUS")'?1N.N S PSOPATST="",PSOPATST=$O(^PS(53,"B",PSORX("PATIENT STATUS"),PSOPATST))
     105 F JJJ=2:1:8 I $P(PSOOICD,"^",JJJ)=0!($P(PSOOICD,"^",JJJ)=1) D
     106 . I JJJ=2 S PSORX(PSOIBOLD,"VEH")=$P(PSOOICD,"^",JJJ)
     107 . I JJJ=3 S PSORX(PSOIBOLD,"RAD")=$P(PSOOICD,"^",JJJ)
     108 . I JJJ=4 D
     109 .. S:PSOSCP<50 PSORX(PSOIBOLD,"SC")=$P(PSOOICD,"^",JJJ)
     110 .. S:PSOSCP>49!($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)=1) PSORX(PSOIBOLD,"SC>50")=$P(PSOOICD,"^",JJJ)
     111 . I JJJ=5 S PSORX(PSOIBOLD,"PGW")=$P(PSOOICD,"^",JJJ)
     112 . I JJJ=6 S PSORX(PSOIBOLD,"MST")=$P(PSOOICD,"^",JJJ)
     113 . I JJJ=7 S PSORX(PSOIBOLD,"HNC")=$P(PSOOICD,"^",JJJ)
     114 . I JJJ=8 S PSORX(PSOIBOLD,"CV")=$P(PSOOICD,"^",JJJ)
     115 K JJJ,PSOOICD
     116 Q
     117SETIBP ;
     118 I $P($G(^PS(52.41,ORD,0)),"^",16)="SC"!($P($G(^(0)),"^",16)="NSC") S PSORX(PSOIBOLD,"SC")=$S($P($G(^(0)),"^",16)="SC":1,1:0)
     119 I $G(PSORX(PSOIBOLD,"SC"))="" K PSORX(PSOIBOLD,"SC")
     120 I '$$DT^PSOMLLDT Q
     121 N PSOIBQFN S PSOIBQFN=$G(^PS(52.41,ORD,"IBQ"))
     122 I $P(PSOIBQFN,"^",1)=0!($P(PSOIBQFN,"^",1)=1) S PSORX(PSOIBOLD,"MST")=$P(PSOIBQFN,"^")
     123 I $P(PSOIBQFN,"^",2)=0!($P(PSOIBQFN,"^",2)=1) S PSORX(PSOIBOLD,"VEH")=$P(PSOIBQFN,"^",2)
     124 I $P(PSOIBQFN,"^",3)=0!($P(PSOIBQFN,"^",3)=1) S PSORX(PSOIBOLD,"RAD")=$P(PSOIBQFN,"^",3)
     125 I $P(PSOIBQFN,"^",4)=0!($P(PSOIBQFN,"^",4)=1) S PSORX(PSOIBOLD,"PGW")=$P(PSOIBQFN,"^",4)
     126 I $P(PSOIBQFN,"^",5)=0!($P(PSOIBQFN,"^",5)=1) S PSORX(PSOIBOLD,"HNC")=$P(PSOIBQFN,"^",5)
     127 I $P(PSOIBQFN,"^",6)=0!($P(PSOIBQFN,"^",6)=1) S PSORX(PSOIBOLD,"CV")=$P(PSOIBQFN,"^",6)
     128 ;for when patient status is exempt, null IBQ node was set for exempts or SC>50 - data is in ICD node
     129 I $TR($G(^PS(52.41,ORD,"IBQ")),"^")="" S PSOOICD=$G(^PS(52.41,ORD,"ICD",1,0)) D SET3:PSOOICD'=""
     130 ;
     131ICD2 ;
     132 I $D(^PS(52.41,ORD,"ICD",0)) D
     133 . N JJ,ICD,II,FLD,RXN S RXN=ORD
     134 . S II=0 F  S II=$O(^PS(52.41,ORD,"ICD",II)) Q:II=""!(II'?1N.N)  D
     135 .. S ICD="",ICD=^PS(52.41,ORD,"ICD",II,0)
     136 .. I $G(PSOSCP)>49&(II=1) S PSORX(PSOIBOLD,"SC>50")=$P(ICD,"^",4)
     137 .. S JJ="" F JJ=1:1:8 S FLD=$P(ICD,U,JJ) D ICD^PSONEWF
     138 ;
     139 K PSOIBQFN
     140 Q
     141KLIB ;Kill renewal IB array
     142 I '$G(PSOIBOLD) Q
     143 K PSORX(PSOIBOLD,"SC"),PSORX(PSOIBOLD,"MST"),PSORX(PSOIBOLD,"VEH"),PSORX(PSOIBOLD,"RAD"),PSORX(PSOIBOLD,"PGW"),PSORX(PSOIBOLD,"HNC"),PSORX(PSOIBOLD,"CV")
     144 K PSOIBOLD
     145 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW4.m

    r613 r623  
    1 PSORENW4        ;BIR/SAB - rx speed renew ;03/06/95
    2         ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,37,64,46,75,71,100,130,117,152,148,264,225**;DEC 1997;Build 29
    3         ;External reference to ^PSDRUG supported by DBIA 221
    4         ;External reference to ^PS(50.7 supported by DBIA 2223
    5         ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
    6         ;External reference to LK^ORX2 and ULK^ORX2 supported by DBIA 867
    7 SEL     I $P(PSOPAR,"^",4)=0 S VALMSG="Renewing is NOT Allowed. Check Site Parameters!",VALMBCK="" Q
    8         N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!",VALMBCK="" Q
    9         S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
    10         K PSOPLCK S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" D UL^PSSLOCK(PSODFN) Q
    11         K PRC,PHI,PSORX("EDIT"),PSOFDR,DIR,DUOUT,DIRUT,PSORNSPD S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" G SELQ
    12         K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +Y S (SPEED,PSOOELSE,PSORNSPD)=1 D FULL^VALM1 S LST=Y D
    13         .S (PSODIR("DFLG"),PSODIR("FIELD"))=0,PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"),PSORX("DFLG"))=0 D INIT Q:PSORENW("DFLG")
    14         .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""  S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52 PROCESS S PSORENW("DFLG")=0
    15         I '$G(PSOOELSE) S VALMBCK="" G SELQ
    16         S VALMBCK="R"
    17         D ^PSOBUILD,BLD^PSOORUT1 K DIR,DIRUT,DTOUT,DUOUT,LST,ORD,IEN,ORN,RPH,ST,REFL,REF,PSOACT,ORSV,PSORNW,PSORENW,PSONO,PSOCO,PSOCU,PSODIR,DSMSG,SPEED,PSORENW,PSOOELSE,PSOOPT,PSORX("FILL DATE"),PSORX("ISSUE DATE"),PSOID,PSOMSG,PSORX("DFLG"),PSOQTY
    18 SELQ    K PSORNSPD,RTE,DRET,PRC,PHI S X=PSODFN_";DPT(" D ULK^ORX2,UL^PSSLOCK(PSODFN),CLEAN^PSOVER1
    19         Q
    20         ;
    21 PROCESS ; Process one order at a time
    22         I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Rejects!" K DIR,PSOMSG D PAUSE^VALM1 Q
    23         D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")),! K DIR,PSOMSG D PAUSE^VALM1 Q
    24         K RET,DRET,PRC,PHI S PSORENW("OIRXN")=$P(PSOLST(ORN),"^",2),PSOFROM="NEW"
    25         S PSORENW("RX0")=^PSRX(PSORENW("OIRXN"),0),PSORENW("RX2")=^(2),PSORENW("RX3")=^(3),PSORENW("STA")=^("STA"),PSORENW("TN")=$G(^("TN")),SIGOK=$P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^",2)
    26         I SIGOK F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),"SIG1",I)) Q:'I  S SIG(I)=^PSRX(PSORENW("OIRXN"),"SIG1",I,0)
    27         S PSOIBOLD=$G(PSORENW("OIRXN")) D SETIB^PSORENW1
    28         I '$G(PSORENW("PROVIDER")) D
    29         .S PSORENW("PROVIDER")=$P(PSORENW("RX0"),"^",4)
    30         .S:$P(PSORENW("RX3"),"^",3) PSORENW("COSIGNING PROVIDER")=$P(PSORENW("RX3"),"^",3)
    31         S PSORX("PROVIDER NAME")=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^")
    32         I '$G(PSORENW("CLINIC")) S PSORENW("CLINIC")=$P(PSORENW("RX0"),"^",5)
    33         S PSORENW("REMARKS")="RENEWED FROM RX # "_$P(PSORENW("RX0"),"^")
    34         S PSORENW("SIG")=$P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^")
    35         S PSORENW("PSODFN")=$P(PSORENW("RX0"),"^",2)
    36         S PSORENW("ORX #")=$P(PSORENW("RX0"),"^")
    37         S PSORENW("DRUG IEN")=$P(PSORENW("RX0"),"^",6)
    38         S PSORENW("QTY")=$P(PSORENW("RX0"),"^",7)
    39         ;S PSORENW("DAYS SUPPLY")=$P(PSORENW("RX0"),"^",8)
    40         ;S PSORENW("# OF REFILLS")=$P(PSORENW("RX0"),"^",9)
    41         S PSORENW("INS")=$S($G(PSORENW("ENT"))]"":PSORENW("ENT"),1:$G(^PSRX(PSORENW("OIRXN"),"INS")))
    42         S:$G(PSORENW("ENT"))']"" PSORENW("ENT")=0
    43         F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),6,I)) Q:'I  S DOSE=^PSRX(PSORENW("OIRXN"),6,I,0) D
    44         .S PSORENW("ENT")=PSORENW("ENT")+1,PSORENW("DOSE",PSORENW("ENT"))=$P(DOSE,"^")
    45         .S PSORENW("UNITS",PSORENW("ENT"))=$P(DOSE,"^",3),PSORENW("DOSE ORDERED",PSORENW("ENT"))=$P(DOSE,"^",2),PSORENW("ROUTE",PSORENW("ENT"))=$P(DOSE,"^",7)
    46         .S PSORENW("SCHEDULE",PSORENW("ENT"))=$P(DOSE,"^",8),PSORENW("DURATION",PSORENW("ENT"))=$P(DOSE,"^",5),PSORENW("CONJUNCTION",PSORENW("ENT"))=$P(DOSE,"^",6)
    47         .S PSORENW("NOUN",PSORENW("ENT"))=$P(DOSE,"^",4),PSORENW("VERB",PSORENW("ENT"))=$P(DOSE,"^",9)
    48         .I $G(^PSRX(PSORENW("OIRXN"),6,I,1))]"" S PSORENW("ODOSE",PSORENW("ENT"))=^PSRX(PSORENW("OIRXN"),6,I,1)
    49         .K DOSE
    50         I $P($G(^PSDRUG(PSORENW("DRUG IEN"),"CLOZ1")),"^")="PSOCLO1" N PSON S PSON=0 D  I PSON K PSON D POZ,KLIB^PSORENW1 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q
    51         . I '$L($P(^VA(200,PSORENW("PROVIDER"),"PS"),"^",2)),'$L($P(^VA(200,PSORENW("PROVIDER"),"PS"),"^",3)) D  Q
    52         . . S PSON=1 W $C(7),!!,"Only providers with DEA# or a VA# can write prescriptions for clozapine.",!
    53         . I '$D(^XUSEC("YSCL AUTHORIZED",PSORENW("PROVIDER"))) D
    54         . . S PSON=1 W $C(7),!!,"Provider must hold YSCL AUTHORIZED key to write prescriptions for clozapine.",!
    55         I $G(PSORNW("MAIL/WINDOW"))]"" S PSORENW("MAIL/WINDOW")=PSORNW("MAIL/WINDOW")
    56         I $O(^PSRX(PSORENW("OIRXN"),"PI",0)) D  K T
    57         .S PHI=^PSRX(PSORENW("OIRXN"),"PI",0),T=0
    58         .F  S T=$O(^PSRX(PSORENW("OIRXN"),"PI",T)) Q:'T  S PHI(T)=^PSRX(PSORENW("OIRXN"),"PI",T,0)
    59         ;I $O(^PSRX(PSORENW("OIRXN"),"PRC",0)) D  K T
    60         ;.S PRC=^PSRX(PSORENW("OIRXN"),"PRC",0),T=0
    61         ;.F  S T=$O(^PSRX(PSORENW("OIRXN"),"PRC",T)) Q:'T  S PRC(T)=^PSRX(PSORENW("OIRXN"),"PRC",T,0)
    62         W !!,"Now Renewing Rx # "_PSORENW("ORX #")_"   Drug: "_$P($G(^PSDRUG(+$G(PSORENW("DRUG IEN")),0)),"^"),!
    63         I '$P($G(^PSDRUG($P(PSORENW("RX0"),"^",6),2)),"^") D  G:$G(PSORENW("DFLG")) PROCESSX
    64         .I $P($G(^PSRX(PSORENW("OIRXN"),"OR1")),"^") S PSODRUG("OI")=$P(^PSRX(PSORENW("OIRXN"),"OR1"),"^"),PSODRUG("OIN")=$P(^PS(50.7,+^("OR1"),0),"^") Q
    65         .W !!,"Cannot Renew!!  No Pharmacy Orderable Item!" S VALMSG="Cannot Renew!!  No Pharmacy Orderable Item!",PSORX("DFLG")=1
    66         D CHECK^PSORENW0 G:PSORENW("DFLG") PROCESSX
    67         D FILDATE^PSORENW0
    68         D DRUG^PSORENW0 G:PSORENW("DFLG") PROCESSX
    69         D RXN^PSORENW0 G:PSORENW("DFLG") PROCESSX
    70         D STOP^PSORENW1
    71 DSPL    K PSOEDT,PSOLM S PSDY=PSORENW("DAYS SUPPLY"),PSRF=PSORENW("# OF REFILLS")
    72         F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S PSODIR("CS")=1
    73         I $G(PSODIR("CS")) D
    74         .S PSORENW("# OF REFILLS")=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0)
    75         .I PSORENW("# OF REFILLS")>PSRF S PSORENW("# OF REFILLS")=PSRF
    76         D DSPLY^PSORENW3 G:PSORENW("DFLG") PROCESSX
    77         D:$D(^XUSEC("PSORPH",DUZ))!('$P(PSOPAR,"^",2)) VER1^PSOORNE4(.PSORENW) G:PSORENW("DFLG")=1 PROCESSX
    78         I $G(PSOQTY) D QTY^PSODIR1(.PSORENW) G:PSORENW("DFLG")=1 PROCESSX
    79         D EN^PSORN52(.PSORENW)
    80         D RNPSOSD^PSOUTIL
    81         D CAN^PSORENW0,DCORD^PSONEW2
    82         S PSORENW("# OF REFILLS")=PSRF K PSDY,PSRF,PSODIR("CS"),DEA,PSORENW("ENT")
    83         S BBRN="",BBRN1=$O(^PSRX("B",PSORENW("NRX #"),BBRN)) I $P($G(^PSRX(BBRN1,0)),"^",11)["W" S BINGCRT="Y",BINGRTE="W",BBFLG=1,BBRX(1)=$G(BBRX(1))_BBRN1_","
    84 PROCESSX        I PSORENW("DFLG") D  W:'$G(POERR) !,$C(7),"Rx NOT RENEWED. RENEWED RX DELETED",! S POERR("DFLG")=1 D CLEAN^PSOVER1
    85         .K PHI,PRC,PSODRUG,SIG,PSORXED,SIGOK
    86         .K PSORENW("DOSE"),PSORENW("DURATION"),PSORENW("DRUG IEN"),PSORENW("ENT"),PSORENW("INS"),PSORENW("NOUN"),PSORENW("ROUTE"),PSORENW("SCHEDULE"),PSORENW("SIG"),PSORENW("VERB"),PSORENW("UNITS")
    87         .D POZ
    88         K PSORDLOK I PSORENW("DFLG") S PSORDLOK=1
    89         D:$G(PSORENW("OLD FILL DATE"))]"" SUSDATEK^PSOUTIL(.PSORENW)
    90         K BBRN,BBRN1,PSODRUG,PSORX("PROVIDER NAME"),PSORX("CLINIC")
    91         K PSOEDT,PSOLM S:$G(PSORENW("FROM"))="" (PSORENW("DFLG"),PSORENW("QFLG"))=0
    92         I $G(PSORDLOK) D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
    93         D KLIB^PSORENW1
    94         K PSORDLOK
    95         S RXN=$O(^TMP("PSORXN",$J,0)) I RXN D
    96         .S RXN1=^TMP("PSORXN",$J,RXN) D EN^PSOHLSN1(RXN,$P(RXN1,"^"),$P(RXN1,"^",2),"",$P(RXN1,"^",3))
    97         .I $P(^PSRX(RXN,"STA"),"^")=5 D EN^PSOHLSN1(RXN,"SC","ZS",$P(RXN1,"^",4))
    98         K RXN,RXN1,^TMP("PSORXN",$J)
    99         Q
    100 INIT    ;
    101         D ASK Q:PSORENW("DFLG")
    102         D NOORE^PSONEW(.PSORENW) Q:PSORENW("DFLG")
    103         Q
    104 ASK     ;upfront questions
    105         W !! D ISSDT^PSODIR2(.PSORENW) Q:PSORENW("DFLG")  S PSORENW("ISSUE DATE")=PSOID
    106         D FILLDT^PSODIR2(.PSORENW) K PSONEW("DAYS SUPPLY"),PSONEW("# OF REFILLS") Q:PSORENW("DFLG")
    107         S PSORNW("FILL DATE")=PSORENW("FILL DATE")
    108         D MW^PSODIR2(.PSORENW) Q:PSORENW("DFLG")
    109         D PTSTAT^PSODIR1(.PSORENW) Q:PSORENW("DFLG")
    110         D DAYS^PSODIR1(.PSORENW) Q:PSORENW("DFLG")
    111         S PSODRUG("DEA")=0 D REFILL^PSODIR1(.PSORENW) K PSODRUG("DEA") Q:PSORENW("DFLG")
    112         K DIR,DIRUT S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to edit Renewed Rx(s) QTY " D ^DIR I $D(DIRUT) S PSORENW("DFLG")=1 K DIR,DIRUT Q
    113         S PSOQTY=Y K DIR,DIRUT
    114         D CLINIC^PSODIR2(.PSORENW) Q:PSORENW("DFLG")
    115         D PROV^PSODIR(.PSORENW) S:PSORENW("DFLG") PSORENW("DFLG")=0
    116         Q
    117         ;
    118 POZ     ;
    119         K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DTOUT
    120         Q
     1PSORENW4 ;BIR/SAB - rx speed renew ;03/06/95
     2 ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,37,64,46,75,71,100,130,117,152,148,264**;DEC 1997;Build 19
     3 ;External reference to ^PSDRUG supported by DBIA 221
     4 ;External reference to ^PS(50.7 supported by DBIA 2223
     5 ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
     6 ;External reference to LK^ORX2 and ULK^ORX2 supported by DBIA 867
     7SEL I $P(PSOPAR,"^",4)=0 S VALMSG="Renewing is NOT Allowed. Check Site Parameters!",VALMBCK="" Q
     8 N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!",VALMBCK="" Q
     9 S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
     10 K PSOPLCK S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" D UL^PSSLOCK(PSODFN) Q
     11 K PRC,PHI,PSORX("EDIT"),PSOFDR,DIR,DUOUT,DIRUT,PSORNSPD S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" G SELQ
     12 K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +Y S (SPEED,PSOOELSE,PSORNSPD)=1 D FULL^VALM1 S LST=Y D
     13 .S (PSODIR("DFLG"),PSODIR("FIELD"))=0,PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"),PSORX("DFLG"))=0 D INIT Q:PSORENW("DFLG")
     14 .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""  S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52 PROCESS S PSORENW("DFLG")=0
     15 I '$G(PSOOELSE) S VALMBCK="" G SELQ
     16 S VALMBCK="R"
     17 D ^PSOBUILD,BLD^PSOORUT1 K DIR,DIRUT,DTOUT,DUOUT,LST,ORD,IEN,ORN,RPH,ST,REFL,REF,PSOACT,ORSV,PSORNW,PSORENW,PSONO,PSOCO,PSOCU,PSODIR,DSMSG,SPEED,PSORENW,PSOOELSE,PSOOPT,PSORX("FILL DATE"),PSORX("ISSUE DATE"),PSOID,PSOMSG,PSORX("DFLG"),PSOQTY
     18SELQ K PSORNSPD,RTE,DRET,PRC,PHI S X=PSODFN_";DPT(" D ULK^ORX2,UL^PSSLOCK(PSODFN),CLEAN^PSOVER1
     19 Q
     20 ;
     21PROCESS ; Process one order at a time
     22 I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Rejects!" K DIR,PSOMSG D PAUSE^VALM1 Q
     23 D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")),! K DIR,PSOMSG D PAUSE^VALM1 Q
     24 K RET,DRET,PRC,PHI S PSORENW("OIRXN")=$P(PSOLST(ORN),"^",2),PSOFROM="NEW"
     25 S PSORENW("RX0")=^PSRX(PSORENW("OIRXN"),0),PSORENW("RX2")=^(2),PSORENW("RX3")=^(3),PSORENW("STA")=^("STA"),PSORENW("TN")=$G(^("TN")),SIGOK=$P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^",2)
     26 I SIGOK F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),"SIG1",I)) Q:'I  S SIG(I)=^PSRX(PSORENW("OIRXN"),"SIG1",I,0)
     27 S PSOIBOLD=$G(PSORENW("OIRXN")) D SETIB^PSORENW1
     28 I '$G(PSORENW("PROVIDER")) D
     29 .S PSORENW("PROVIDER")=$P(PSORENW("RX0"),"^",4)
     30 .S:$P(PSORENW("RX3"),"^",3) PSORENW("COSIGNING PROVIDER")=$P(PSORENW("RX3"),"^",3)
     31 S PSORX("PROVIDER NAME")=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^")
     32 I '$G(PSORENW("CLINIC")) S PSORENW("CLINIC")=$P(PSORENW("RX0"),"^",5)
     33 S PSORENW("REMARKS")="RENEWED FROM RX # "_$P(PSORENW("RX0"),"^")
     34 S PSORENW("SIG")=$P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^")
     35 S PSORENW("PSODFN")=$P(PSORENW("RX0"),"^",2)
     36 S PSORENW("ORX #")=$P(PSORENW("RX0"),"^")
     37 S PSORENW("DRUG IEN")=$P(PSORENW("RX0"),"^",6)
     38 S PSORENW("QTY")=$P(PSORENW("RX0"),"^",7)
     39 ;S PSORENW("DAYS SUPPLY")=$P(PSORENW("RX0"),"^",8)
     40 ;S PSORENW("# OF REFILLS")=$P(PSORENW("RX0"),"^",9)
     41 S PSORENW("INS")=$S($G(PSORENW("ENT"))]"":PSORENW("ENT"),1:$G(^PSRX(PSORENW("OIRXN"),"INS")))
     42 S:$G(PSORENW("ENT"))']"" PSORENW("ENT")=0
     43 F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),6,I)) Q:'I  S DOSE=^PSRX(PSORENW("OIRXN"),6,I,0) D
     44 .S PSORENW("ENT")=PSORENW("ENT")+1,PSORENW("DOSE",PSORENW("ENT"))=$P(DOSE,"^")
     45 .S PSORENW("UNITS",PSORENW("ENT"))=$P(DOSE,"^",3),PSORENW("DOSE ORDERED",PSORENW("ENT"))=$P(DOSE,"^",2),PSORENW("ROUTE",PSORENW("ENT"))=$P(DOSE,"^",7)
     46 .S PSORENW("SCHEDULE",PSORENW("ENT"))=$P(DOSE,"^",8),PSORENW("DURATION",PSORENW("ENT"))=$P(DOSE,"^",5),PSORENW("CONJUNCTION",PSORENW("ENT"))=$P(DOSE,"^",6)
     47 .S PSORENW("NOUN",PSORENW("ENT"))=$P(DOSE,"^",4),PSORENW("VERB",PSORENW("ENT"))=$P(DOSE,"^",9)
     48 .I $G(^PSRX(PSORENW("OIRXN"),6,I,1))]"" S PSORENW("ODOSE",PSORENW("ENT"))=^PSRX(PSORENW("OIRXN"),6,I,1)
     49 .K DOSE
     50 I $P($G(^PSDRUG(PSORENW("DRUG IEN"),"CLOZ1")),"^")="PSOCLO1" N PSON S PSON=0 D  I PSON K PSON D POZ,KLIB^PSORENW1 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q
     51 . I '$L($P(^VA(200,PSORENW("PROVIDER"),"PS"),"^",2)),'$L($P(^VA(200,PSORENW("PROVIDER"),"PS"),"^",3)) D  Q
     52 . . S PSON=1 W $C(7),!!,"Only providers with DEA# or a VA# can write prescriptions for clozapine.",!
     53 . I '$D(^XUSEC("YSCL AUTHORIZED",PSORENW("PROVIDER"))) D
     54 . . S PSON=1 W $C(7),!!,"Provider must hold YSCL AUTHORIZED key to write prescriptions for clozapine.",!
     55 I $G(PSORNW("MAIL/WINDOW"))]"" S PSORENW("MAIL/WINDOW")=PSORNW("MAIL/WINDOW")
     56 I $O(^PSRX(PSORENW("OIRXN"),"PI",0)) D  K T
     57 .S PHI=^PSRX(PSORENW("OIRXN"),"PI",0),T=0
     58 .F  S T=$O(^PSRX(PSORENW("OIRXN"),"PI",T)) Q:'T  S PHI(T)=^PSRX(PSORENW("OIRXN"),"PI",T,0)
     59 I $O(^PSRX(PSORENW("OIRXN"),"PRC",0)) D  K T
     60 .S PRC=^PSRX(PSORENW("OIRXN"),"PRC",0),T=0
     61 .F  S T=$O(^PSRX(PSORENW("OIRXN"),"PRC",T)) Q:'T  S PRC(T)=^PSRX(PSORENW("OIRXN"),"PRC",T,0)
     62 W !!,"Now Renewing Rx # "_PSORENW("ORX #")_"   Drug: "_$P($G(^PSDRUG(+$G(PSORENW("DRUG IEN")),0)),"^"),!
     63 I '$P($G(^PSDRUG($P(PSORENW("RX0"),"^",6),2)),"^") D  G:$G(PSORENW("DFLG")) PROCESSX
     64 .I $P($G(^PSRX(PSORENW("OIRXN"),"OR1")),"^") S PSODRUG("OI")=$P(^PSRX(PSORENW("OIRXN"),"OR1"),"^"),PSODRUG("OIN")=$P(^PS(50.7,+^("OR1"),0),"^") Q
     65 .W !!,"Cannot Renew!!  No Pharmacy Orderable Item!" S VALMSG="Cannot Renew!!  No Pharmacy Orderable Item!",PSORX("DFLG")=1
     66 D CHECK^PSORENW0 G:PSORENW("DFLG") PROCESSX
     67 D FILDATE^PSORENW0
     68 D DRUG^PSORENW0 G:PSORENW("DFLG") PROCESSX
     69 D RXN^PSORENW0 G:PSORENW("DFLG") PROCESSX
     70 D STOP^PSORENW1
     71DSPL K PSOEDT,PSOLM S PSDY=PSORENW("DAYS SUPPLY"),PSRF=PSORENW("# OF REFILLS")
     72 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S PSODIR("CS")=1
     73 I $G(PSODIR("CS")) D
     74 .S PSORENW("# OF REFILLS")=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0)
     75 .I PSORENW("# OF REFILLS")>PSRF S PSORENW("# OF REFILLS")=PSRF
     76 D DSPLY^PSORENW3 G:PSORENW("DFLG") PROCESSX
     77 D:$D(^XUSEC("PSORPH",DUZ))!('$P(PSOPAR,"^",2)) VER1^PSOORNE4(.PSORENW) G:PSORENW("DFLG")=1 PROCESSX
     78 I $G(PSOQTY) D QTY^PSODIR1(.PSORENW) G:PSORENW("DFLG")=1 PROCESSX
     79 D EN^PSORN52(.PSORENW)
     80 D RNPSOSD^PSOUTIL
     81 D CAN^PSORENW0,DCORD^PSONEW2
     82 S PSORENW("# OF REFILLS")=PSRF K PSDY,PSRF,PSODIR("CS"),DEA,PSORENW("ENT")
     83 S BBRN="",BBRN1=$O(^PSRX("B",PSORENW("NRX #"),BBRN)) I $P($G(^PSRX(BBRN1,0)),"^",11)["W" S BINGCRT="Y",BINGRTE="W",BBFLG=1,BBRX(1)=$G(BBRX(1))_BBRN1_","
     84PROCESSX I PSORENW("DFLG") D  W:'$G(POERR) !,$C(7),"Rx NOT RENEWED. RENEWED RX DELETED",! S POERR("DFLG")=1 D CLEAN^PSOVER1
     85 .K PHI,PRC,PSODRUG,SIG,PSORXED,SIGOK
     86 .K PSORENW("DOSE"),PSORENW("DURATION"),PSORENW("DRUG IEN"),PSORENW("ENT"),PSORENW("INS"),PSORENW("NOUN"),PSORENW("ROUTE"),PSORENW("SCHEDULE"),PSORENW("SIG"),PSORENW("VERB"),PSORENW("UNITS")
     87 .D POZ
     88 K PSORDLOK I PSORENW("DFLG") S PSORDLOK=1
     89 D:$G(PSORENW("OLD FILL DATE"))]"" SUSDATEK^PSOUTIL(.PSORENW)
     90 K BBRN,BBRN1,PSODRUG,PSORX("PROVIDER NAME"),PSORX("CLINIC")
     91 K PSOEDT,PSOLM S:$G(PSORENW("FROM"))="" (PSORENW("DFLG"),PSORENW("QFLG"))=0
     92 I $G(PSORDLOK) D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
     93 D KLIB^PSORENW1
     94 K PSORDLOK
     95 S RXN=$O(^TMP("PSORXN",$J,0)) I RXN D
     96 .S RXN1=^TMP("PSORXN",$J,RXN) D EN^PSOHLSN1(RXN,$P(RXN1,"^"),$P(RXN1,"^",2),"",$P(RXN1,"^",3))
     97 .I $P(^PSRX(RXN,"STA"),"^")=5 D EN^PSOHLSN1(RXN,"SC","ZS",$P(RXN1,"^",4))
     98 K RXN,RXN1,^TMP("PSORXN",$J)
     99 Q
     100INIT ;
     101 D ASK Q:PSORENW("DFLG")
     102 D NOORE^PSONEW(.PSORENW) Q:PSORENW("DFLG")
     103 Q
     104ASK ;upfront questions
     105 W !! D ISSDT^PSODIR2(.PSORENW) Q:PSORENW("DFLG")  S PSORENW("ISSUE DATE")=PSOID
     106 D FILLDT^PSODIR2(.PSORENW) K PSONEW("DAYS SUPPLY"),PSONEW("# OF REFILLS") Q:PSORENW("DFLG")
     107 S PSORNW("FILL DATE")=PSORENW("FILL DATE")
     108 D MW^PSODIR2(.PSORENW) Q:PSORENW("DFLG")
     109 D PTSTAT^PSODIR1(.PSORENW) Q:PSORENW("DFLG")
     110 D DAYS^PSODIR1(.PSORENW) Q:PSORENW("DFLG")
     111 S PSODRUG("DEA")=0 D REFILL^PSODIR1(.PSORENW) K PSODRUG("DEA") Q:PSORENW("DFLG")
     112 K DIR,DIRUT S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to edit Renewed Rx(s) QTY " D ^DIR I $D(DIRUT) S PSORENW("DFLG")=1 K DIR,DIRUT Q
     113 S PSOQTY=Y K DIR,DIRUT
     114 D CLINIC^PSODIR2(.PSORENW) Q:PSORENW("DFLG")
     115 D PROV^PSODIR(.PSORENW) S:PSORENW("DFLG") PSORENW("DFLG")=0
     116 Q
     117 ;
     118POZ ;
     119 K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DTOUT
     120 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52.m

    r613 r623  
    1 PSORN52 ;BIR/DSD - files renewal entries in prescription file ;08/09/93
    2         ;;7.0;OUTPATIENT PHARMACY;**1,11,27,37,46,79,71,100,117,157,143,219,148,239,201,225**;DEC 1997;Build 29
    3         ;Ext ref to ^PS(55 sup by DBIA 2228
    4         ;Ext ref to PSOUL^PSSLOCK sup by DBIA 2789
    5         ;Ext ref to ^VA(200 sup by DBIA 10060
    6         ;Ext ref to SWSTAT^IBBAPI sup by DBIA 4663
    7 EN(PSOX)        ;EP
    8 START   ;
    9         D:$D(XRTL) T0^%ZOSV ; Start RT Mon
    10         N PSOIBHLD,PSOSCOTH,PSOSCOTX S (PSOSCOTH,PSOSCOTX)=0 S PSOIBHLD="" I $G(PSOFDR),$G(ORD) D
    11         .S PSOIBHLD=$S($P($G(^PS(52.41,ORD,0)),"^",16)="SC":1,$P($G(^(0)),"^",16)="NSC":0,1:"")
    12         .I '$$DT^PSOMLLDT Q
    13         .N PSOIBHLX S PSOIBHLX=$G(^PS(52.41,ORD,"IBQ"))
    14         .S PSOIBHLD=PSOIBHLD_"^"_$S($P(PSOIBHLX,"^")=1:1,$P(PSOIBHLX,"^")=0:0,1:"")_"^"_$S($P(PSOIBHLX,"^",2)=1:1,$P(PSOIBHLX,"^",2)=0:0,1:"")_"^"_$S($P(PSOIBHLX,"^",3)=1:1,$P(PSOIBHLX,"^",3)=0:0,1:"")
    15         .S PSOIBHLD=PSOIBHLD_"^"_$S($P(PSOIBHLX,"^",4)=1:1,$P(PSOIBHLX,"^",4)=0:0,1:"")_"^"_$S($P(PSOIBHLX,"^",5)=1:1,$P(PSOIBHLX,"^",5)=0:0,1:"")_"^"_$S($P(PSOIBHLX,"^",6)=1:1,$P(PSOIBHLX,"^",6)=0:0,1:"")
    16         .S PSOIBHLD=PSOIBHLD_"^"_$S($P(PSOIBHLX,"^",7)=1:1,$P(PSOIBHLX,"^",7)=0:0,1:"")
    17         .I $P(PSOIBHLX,"^")=1!($P(PSOIBHLX,"^",2)=1)!($P(PSOIBHLX,"^",3)=1)!($P(PSOIBHLX,"^",4)=1)!($P(PSOIBHLX,"^",5)=1)!($P(PSOIBHLX,"^",6)=1)!($P(PSOIBHLX,"^",7)=1) S PSOSCOTH=1
    18         I $G(PSOSCOTH)!($G(PSORX("SC"))="SC")!($G(PSORX("SC"))="NSC") S PSOSCOTX=1
    19         S PSOANSQ("SC>50")="" D SCP^PSORN52D
    20         I $G(PSOFDR),$G(ORD) I $D(^PS(52.41,ORD,"ICD")) S FILE=52.41 D GET^PSORN52D
    21         ;Set ans to renew from Rx, only if no ans from Pend file
    22         I $G(PSORENW("OIRXN")) D
    23         .N PSOLDIBQ S PSOLDIBQ=$G(^PSRX(PSORENW("OIRXN"),"IBQ"))
    24         .I $P(PSOIBHLD,"^")="" D
    25         ..I $P($G(^PSRX(PSORENW("OIRXN"),"IB")),"^")=2 S $P(PSOIBHLD,"^")=0
    26         .I '$$DT^PSOMLLDT Q
    27         .I PSOLDIBQ="" Q
    28         .D IBHLD^PSORN52A
    29         D INIT G:PSORN52("QFLG") END D FILE^PSORN52A
    30         S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; Stop RT Mon
    31         K PSOANSQ,PSOANSQD,PSONEWFF
    32         I $G(PSOIBHLD)'="" D
    33         .;Set answers based on Pend Renew, prior to Phar call
    34         .Q:'$G(PSOX("IRXN"))
    35         .I $P(PSOIBHLD,"^")=1!($P(PSOIBHLD,"^")=0) S PSOANSQ("SC")=$P(PSOIBHLD,"^")
    36         .I '$$DT^PSOMLLDT Q
    37         .I $P(PSOIBHLD,"^",2)=1!($P(PSOIBHLD,"^",2)=0) S PSOANSQ(PSOX("IRXN"),"MST")=$P(PSOIBHLD,"^",2)
    38         .I $P(PSOIBHLD,"^",3)=1!($P(PSOIBHLD,"^",3)=0) S PSOANSQ(PSOX("IRXN"),"VEH")=$P(PSOIBHLD,"^",3)
    39         .I $P(PSOIBHLD,"^",4)=1!($P(PSOIBHLD,"^",4)=0) S PSOANSQ(PSOX("IRXN"),"RAD")=$P(PSOIBHLD,"^",4)
    40         .I $P(PSOIBHLD,"^",5)=1!($P(PSOIBHLD,"^",5)=0) S PSOANSQ(PSOX("IRXN"),"PGW")=$P(PSOIBHLD,"^",5)
    41         .I $P(PSOIBHLD,"^",6)=1!($P(PSOIBHLD,"^",6)=0) S PSOANSQ(PSOX("IRXN"),"HNC")=$P(PSOIBHLD,"^",6)
    42         .I $P(PSOIBHLD,"^",7)=1!($P(PSOIBHLD,"^",7)=0) S PSOANSQ(PSOX("IRXN"),"CV")=$P(PSOIBHLD,"^",7)
    43         .I $P(PSOIBHLD,"^",8)=1!($P(PSOIBHLD,"^",8)=0) S PSOANSQ(PSOX("IRXN"),"SHAD")=$P(PSOIBHLD,"^",8)
    44         K PSOIBHLD
    45         I '$G(PSOFDR) I $G(PSORENW("OIRXN")) S FILE=52 D GET^PSORN52D
    46         S PSONEW("NEWCOPAY")=""
    47         I (PSOSCP<50&('$P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7))),$G(DUZ("AG"))="V" S PSOFLAG=0 D COPAY^PSOCPB
    48         ;I PSOSCP>49!($P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)=1) S PSOFLAG=0 D SC^PSOMLLD2
    49         I PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)=1)) S PSOFLAG=0 D SC^PSOMLLD2
    50         I $$DT^PSOMLLDT D
    51         .I $D(PSOIBQS(PSODFN,"CV")) D MESS D CV^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"CV")) K PSONEW("NEWCOPAY")
    52         .I $D(PSOIBQS(PSODFN,"VEH")) D MESS D VEH^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"VEH")) K PSONEW("NEWCOPAY")
    53         .I $D(PSOIBQS(PSODFN,"RAD")) D MESS D RAD^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"RAD")) K PSONEW("NEWCOPAY")
    54         .I $D(PSOIBQS(PSODFN,"PGW")) D MESS D PGW^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"PGW")) K PSONEW("NEWCOPAY")
    55         .I $D(PSOIBQS(PSODFN,"SHAD")) D MESS D SHAD^PSOMLLD2 I $G(PSOANSQ(PSOX("IRXN"),"SHAD")) K PSONEW("NEWCOPAY")
    56         .I $D(PSOIBQS(PSODFN,"MST")) D MESS D MST^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"MST")) K PSONEW("NEWCOPAY")
    57         .I $D(PSOIBQS(PSODFN,"HNC")) D MESS D HNC^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"HNC")) K PSONEW("NEWCOPAY")
    58         K PSOSCOTH,PSOSCOTX
    59         I $G(PSONEW("NEWCOPAY")) S ^PSRX(PSOX("IRXN"),"IB")=PSONEW("NEWCOPAY")
    60         ;
    61         D FINISH,ACP^PSOUTIL
    62         ;
    63         N PSOSCFLD S PSOSCFLD=$S(PSOSCP'="":$G(PSOANSQ("SC")),1:"")_"^"_$G(PSOANSQ(PSOX("IRXN"),"MST"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"VEH"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"RAD"))
    64         S PSOSCFLD=PSOSCFLD_"^"_$G(PSOANSQ(PSOX("IRXN"),"PGW"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"HNC"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"CV"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"SHAD"))
    65         I PSOSCP<50&($TR(PSOSCFLD,"^")'="")&('$P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)) S ^PSRX(PSOX("IRXN"),"IBQ")=PSOSCFLD K PSOSCFLD
    66         ;
    67         D FILE2^PSORN52D
    68         D:$$SWSTAT^IBBAPI() GACT^PSOPFSU0(PSOX("IRXN"),0)
    69         K PSONEW("NEWCOPAY"),PSOANSQ
    70 END     D EOJ
    71         Q
    72 INIT    S PSORN52("QFLG")=0 S:'$D(PSOX("DAYS SUPPLY")) PSOX("DAYS SUPPLY")=$P(PSOX("RX0"),"^",8)
    73         S:'$D(PSOX("# OF REFILLS")) PSOX("# OF REFILLS")=$P(PSOX("RX0"),"^",9) S:'$D(PSOX("ISSUE DATE")) PSOX("ISSUE DATE")=DT
    74         D INIT^PSON52 K PSON52
    75         Q
    76         ;
    77 FINISH  ;
    78         G:PSOX("STATUS")=4 FINISHP
    79         I $D(PSORX("VERIFY")) D  G FINISHX
    80         .K DIC,DLAYGO,DINUM,DIADD,X,DD,DO S DIC="^PS(52.4,",DLAYGO=52.4,DINUM=PSOX("IRXN"),DIC(0)="ML"
    81         .S X=PSOX("IRXN") D FILE^DICN K DD,DO,DIC,DLAYGO,DINUM,X
    82         .S ^PS(52.4,PSOX("IRXN"),0)=PSOX("IRXN")_"^"_$P(PSOX("NRX0"),"^",2)_"^"_DUZ_"^"_$G(PSOX("OIRXN"))_"^"_$E(PSOX("LOGIN DATE"),1,7)_"^"_PSOX("IRXN")_"^"_PSOX("STOP DATE")
    83         .K DIK,DA S DIK="^PS(52.4,",DA=PSOX("IRXN") D IX^DIK K DIK,DA
    84         ;
    85         I $G(PSOX("QS"))="S",$G(PSOBARCD) S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=0 D SUS^PSORXL K DA G FINISHX
    86         ;
    87         I PSOX("FILL DATE")>DT,$P(PSOPAR,"^",6) S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=0 D SUS^PSORXL K DA G FINISHX
    88         ;
    89         ; - Submitting Rx to ECME for 3rd Party Billing
    90         N ACTION
    91         I $$SUBMIT^PSOBPSUT(PSOX("IRXN"),0) D  I ACTION="Q"!(ACTION="^") Q
    92         . S ACTION="" D ECMESND^PSOBPSU1(PSOX("IRXN"),0,PSOX("FILL DATE"),"RN")
    93         . I $$FIND^PSOREJUT(PSOX("IRXN"),0) D
    94         . . S ACTION=$$HDLG^PSOREJU1(PSOX("IRXN"),0,"79,88","RN","IOQ","I")
    95         ;
    96         I $G(PSOX("QS"))="Q",$G(PSOBARCD) D  G FINISHX
    97         . N PSOFROM S PSOFROM="BATCH" I $G(PPL),$L(PPL_PSOX("IRXN")_",")>240 D TRI^PSOBBC D Q^PSORXL K PPL,RXFL
    98         .S RXFL(PSOX("IRXN"))=0
    99         . I $G(PPL) S PPL=PPL_PSOX("IRXN")_","
    100         . E  S PPL=PSOX("IRXN")_","
    101         . Q
    102 FINISHP I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSOX("IRXN")_",",RXFL(PSOX("IRXN"))=0 G FINISHX
    103         F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
    104         I $L(PSORX("PSOL",PSOX2))+$L(PSOX("IRXN"))<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSOX("IRXN")_","
    105         E  S PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_","
    106         S RXFL(PSOX("IRXN"))=0
    107 FINISHX ;
    108         ;call to build bingo board Rx array
    109         S:'$G(PSORX("MAIL/WINDOW")) PSORX("MAIL/WINDOW")=$P(PSORENW("NRX0"),"^",11)
    110         I $G(PSORX("MAIL/WINDOW"))["W" S BINGCRT=1,BINGRTE="W",BBFLG=1 D BBRX^PSORN52C
    111         K PSOX1,PSOX2
    112         Q
    113 EOJ     ;
    114         L -^PSRX("B",PSOX("IRXN")) K PSORN52,PSOX("INS"),PSORENW("INS"),PSORXED("INS"),PSONEW("ENT"),PSORXED("ENT"),OLENT,PSOIBHLD,PSOX("SINS"),PSORENW("SINS"),PSORXED("SINS"),FILE
    115         D PSOUL^PSSLOCK(PSOX("IRXN")) D PSOUL^PSSLOCK(PSOX("OIRXN"))
    116         Q
    117 MESS    ;
    118         I $G(PSOSCOTX)=1&(PSOSCP<50) W:$G(PSODRUG("DEA"))'["S"&($G(PSODRUG("DEA"))'["I") !!,"This Rx has been flagged by the provider as: "_$S($G(PSOSCOTH):"NO COPAY",$G(PSORX("SC"))="SC":"NO COPAY",1:"COPAY"),! S PSOSCOTX=2
    119         Q
     1PSORN52 ;BIR/DSD - files renewal entries in prescription file ; 3/11/07 4:42pm
     2 ;;7.0;OUTPATIENT PHARMACY;**1,11,27,37,46,79,71,100,117,157,143,219,148,239,201,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VistA
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 ;Ext ref to ^PS(55 sup by DBIA 2228
     20 ;Ext ref to PSOUL^PSSLOCK sup by DBIA 2789
     21 ;Ext ref to ^VA(200 sup by DBIA 10060
     22 ;Ext ref to SWSTAT^IBBAPI sup by DBIA 4663
     23EN(PSOX) ;EP
     24START ;
     25 D:$D(XRTL) T0^%ZOSV ; Start RT Mon
     26 N PSOIBHLD,PSOSCOTH,PSOSCOTX S (PSOSCOTH,PSOSCOTX)=0 S PSOIBHLD="" I $G(PSOFDR),$G(ORD) D
     27 .S PSOIBHLD=$S($P($G(^PS(52.41,ORD,0)),"^",16)="SC":1,$P($G(^(0)),"^",16)="NSC":0,1:"")
     28 .I '$$DT^PSOMLLDT Q
     29 .N PSOIBHLX S PSOIBHLX=$G(^PS(52.41,ORD,"IBQ"))
     30 .S PSOIBHLD=PSOIBHLD_"^"_$S($P(PSOIBHLX,"^")=1:1,$P(PSOIBHLX,"^")=0:0,1:"")_"^"_$S($P(PSOIBHLX,"^",2)=1:1,$P(PSOIBHLX,"^",2)=0:0,1:"")_"^"_$S($P(PSOIBHLX,"^",3)=1:1,$P(PSOIBHLX,"^",3)=0:0,1:"")
     31 .S PSOIBHLD=PSOIBHLD_"^"_$S($P(PSOIBHLX,"^",4)=1:1,$P(PSOIBHLX,"^",4)=0:0,1:"")_"^"_$S($P(PSOIBHLX,"^",5)=1:1,$P(PSOIBHLX,"^",5)=0:0,1:"")_"^"_$S($P(PSOIBHLX,"^",6)=1:1,$P(PSOIBHLX,"^",6)=0:0,1:"")
     32 .I $P(PSOIBHLX,"^")=1!($P(PSOIBHLX,"^",2)=1)!($P(PSOIBHLX,"^",3)=1)!($P(PSOIBHLX,"^",4)=1)!($P(PSOIBHLX,"^",5)=1)!($P(PSOIBHLX,"^",6)=1) S PSOSCOTH=1
     33 I $G(PSOSCOTH)!($G(PSORX("SC"))="SC")!($G(PSORX("SC"))="NSC") S PSOSCOTX=1
     34 S PSOANSQ("SC>50")="" D SCP^PSORN52D
     35 I $G(PSOFDR),$G(ORD) I $D(^PS(52.41,ORD,"ICD")) S FILE=52.41 D GET^PSORN52D
     36 ;Set ans to renew from Rx, only if no ans from Pend file
     37 I $G(PSORENW("OIRXN")) D
     38 .N PSOLDIBQ S PSOLDIBQ=$G(^PSRX(PSORENW("OIRXN"),"IBQ"))
     39 .I $P(PSOIBHLD,"^")="" D
     40 ..I $P($G(^PSRX(PSORENW("OIRXN"),"IB")),"^")=2 S $P(PSOIBHLD,"^")=0
     41 .I '$$DT^PSOMLLDT Q
     42 .I PSOLDIBQ="" Q
     43 .D IBHLD^PSORN52A
     44 D INIT G:PSORN52("QFLG") END D FILE^PSORN52A
     45 S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; Stop RT Mon
     46 K PSOANSQ,PSOANSQD,PSONEWFF
     47 I $G(PSOIBHLD)'="" D
     48 .;Set answers based on Pend Renew, prior to Phar call
     49 .Q:'$G(PSOX("IRXN"))
     50 .I $P(PSOIBHLD,"^")=1!($P(PSOIBHLD,"^")=0) S PSOANSQ("SC")=$P(PSOIBHLD,"^")
     51 .I '$$DT^PSOMLLDT Q
     52 .I $P(PSOIBHLD,"^",2)=1!($P(PSOIBHLD,"^",2)=0) S PSOANSQ(PSOX("IRXN"),"MST")=$P(PSOIBHLD,"^",2)
     53 .I $P(PSOIBHLD,"^",3)=1!($P(PSOIBHLD,"^",3)=0) S PSOANSQ(PSOX("IRXN"),"VEH")=$P(PSOIBHLD,"^",3)
     54 .I $P(PSOIBHLD,"^",4)=1!($P(PSOIBHLD,"^",4)=0) S PSOANSQ(PSOX("IRXN"),"RAD")=$P(PSOIBHLD,"^",4)
     55 .I $P(PSOIBHLD,"^",5)=1!($P(PSOIBHLD,"^",5)=0) S PSOANSQ(PSOX("IRXN"),"PGW")=$P(PSOIBHLD,"^",5)
     56 .I $P(PSOIBHLD,"^",6)=1!($P(PSOIBHLD,"^",6)=0) S PSOANSQ(PSOX("IRXN"),"HNC")=$P(PSOIBHLD,"^",6)
     57 .I $P(PSOIBHLD,"^",7)=1!($P(PSOIBHLD,"^",7)=0) S PSOANSQ(PSOX("IRXN"),"CV")=$P(PSOIBHLD,"^",7)
     58 K PSOIBHLD
     59 I '$G(PSOFDR) I $G(PSORENW("OIRXN")) S FILE=52 D GET^PSORN52D
     60 S PSONEW("NEWCOPAY")=""
     61 I (PSOSCP<50&('$P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7))),$G(DUZ("AG"))="V" S PSOFLAG=0 D COPAY^PSOCPB
     62 ;I PSOSCP>49!($P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)=1) S PSOFLAG=0 D SC^PSOMLLD2
     63 I PSOAFYN="Y" G AFIN ;vfah
     64 I PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)=1)) S PSOFLAG=0 D SC^PSOMLLD2
     65 I $$DT^PSOMLLDT D
     66 .I $D(PSOIBQS(PSODFN,"CV")) D MESS D CV^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"CV")) K PSONEW("NEWCOPAY")
     67 .I $D(PSOIBQS(PSODFN,"VEH")) D MESS D VEH^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"VEH")) K PSONEW("NEWCOPAY")
     68 .I $D(PSOIBQS(PSODFN,"RAD")) D MESS D RAD^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"RAD")) K PSONEW("NEWCOPAY")
     69 .I $D(PSOIBQS(PSODFN,"PGW")) D MESS D PGW^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"PGW")) K PSONEW("NEWCOPAY")
     70 .I $D(PSOIBQS(PSODFN,"MST")) D MESS D MST^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"MST")) K PSONEW("NEWCOPAY")
     71 .I $D(PSOIBQS(PSODFN,"HNC")) D MESS D HNC^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"HNC")) K PSONEW("NEWCOPAY")
     72 K PSOSCOTH,PSOSCOTX
     73 I $G(PSONEW("NEWCOPAY")) S ^PSRX(PSOX("IRXN"),"IB")=PSONEW("NEWCOPAY")
     74 ;
     75AFIN D FINISH,ACP^PSOUTIL ;vfah copay not evaluated by Autofinish,Rx
     76 ;
     77 N PSOSCFLD S PSOSCFLD=$S(PSOSCP'="":$G(PSOANSQ("SC")),1:"")_"^"_$G(PSOANSQ(PSOX("IRXN"),"MST"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"VEH"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"RAD"))
     78 S PSOSCFLD=PSOSCFLD_"^"_$G(PSOANSQ(PSOX("IRXN"),"PGW"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"HNC"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"CV"))
     79 I PSOSCP<50&($TR(PSOSCFLD,"^")'="")&('$P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)) S ^PSRX(PSOX("IRXN"),"IBQ")=PSOSCFLD K PSOSCFLD
     80 ;
     81 D FILE2^PSORN52D
     82 D:$$SWSTAT^IBBAPI() GACT^PSOPFSU0(PSOX("IRXN"),0)
     83 K PSONEW("NEWCOPAY"),PSOANSQ
     84END D EOJ
     85 Q
     86INIT S PSORN52("QFLG")=0 S:'$D(PSOX("DAYS SUPPLY")) PSOX("DAYS SUPPLY")=$P(PSOX("RX0"),"^",8)
     87 S:'$D(PSOX("# OF REFILLS")) PSOX("# OF REFILLS")=$P(PSOX("RX0"),"^",9) S:'$D(PSOX("ISSUE DATE")) PSOX("ISSUE DATE")=DT
     88 D INIT^PSON52 K PSON52
     89 Q
     90 ;
     91FINISH ;
     92 G:PSOX("STATUS")=4 FINISHP
     93 I $D(PSORX("VERIFY")) D  G FINISHX
     94 .K DIC,DLAYGO,DINUM,DIADD,X,DD,DO S DIC="^PS(52.4,",DLAYGO=52.4,DINUM=PSOX("IRXN"),DIC(0)="ML"
     95 .S X=PSOX("IRXN") D FILE^DICN K DD,DO,DIC,DLAYGO,DINUM,X
     96 .S ^PS(52.4,PSOX("IRXN"),0)=PSOX("IRXN")_"^"_$P(PSOX("NRX0"),"^",2)_"^"_DUZ_"^"_$G(PSOX("OIRXN"))_"^"_$E(PSOX("LOGIN DATE"),1,7)_"^"_PSOX("IRXN")_"^"_PSOX("STOP DATE")
     97 .K DIK,DA S DIK="^PS(52.4,",DA=PSOX("IRXN") D IX^DIK K DIK,DA
     98 ;
     99 I $G(PSOX("QS"))="S",$G(PSOBARCD) S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=0 D SUS^PSORXL K DA G FINISHX
     100 ;
     101 I PSOX("FILL DATE")>DT,$P(PSOPAR,"^",6) S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=0 D SUS^PSORXL K DA G FINISHX
     102 ;
     103 ; - Submitting Rx to ECME for 3rd Party Billing
     104 N ACTION
     105 I $$SUBMIT^PSOBPSUT(PSOX("IRXN"),0) D  I ACTION="Q"!(ACTION="^") Q
     106 . S ACTION="" D ECMESND^PSOBPSU1(PSOX("IRXN"),0,PSOX("FILL DATE"),"RN")
     107 . I $$FIND^PSOREJUT(PSOX("IRXN"),0) D
     108 . . S ACTION=$$HDLG^PSOREJU1(PSOX("IRXN"),0,"79,88","RN","IOQ","I")
     109 ;
     110 I $G(PSOX("QS"))="Q",$G(PSOBARCD) D  G FINISHX
     111 . N PSOFROM S PSOFROM="BATCH" I $G(PPL),$L(PPL_PSOX("IRXN")_",")>240 D TRI^PSOBBC D Q^PSORXL K PPL,RXFL
     112 .S RXFL(PSOX("IRXN"))=0
     113 . I $G(PPL) S PPL=PPL_PSOX("IRXN")_","
     114 . E  S PPL=PSOX("IRXN")_","
     115 . Q
     116FINISHP I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSOX("IRXN")_",",RXFL(PSOX("IRXN"))=0 G FINISHX
     117 F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
     118 I $L(PSORX("PSOL",PSOX2))+$L(PSOX("IRXN"))<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSOX("IRXN")_","
     119 E  S PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_","
     120 S RXFL(PSOX("IRXN"))=0
     121FINISHX ;
     122 ;call to build bingo board Rx array
     123 S:'$G(PSORX("MAIL/WINDOW")) PSORX("MAIL/WINDOW")=$P(PSORENW("NRX0"),"^",11)
     124 I $G(PSORX("MAIL/WINDOW"))["W" S BINGCRT=1,BINGRTE="W",BBFLG=1 D BBRX^PSORN52C
     125 K PSOX1,PSOX2
     126 Q
     127EOJ ;
     128 L -^PSRX("B",PSOX("IRXN")) K PSORN52,PSOX("INS"),PSORENW("INS"),PSORXED("INS"),PSONEW("ENT"),PSORXED("ENT"),OLENT,PSOIBHLD,PSOX("SINS"),PSORENW("SINS"),PSORXED("SINS"),FILE
     129 D PSOUL^PSSLOCK(PSOX("IRXN")) D PSOUL^PSSLOCK(PSOX("OIRXN"))
     130 Q
     131MESS ;
     132 I $G(PSOSCOTX)=1&(PSOSCP<50) W:$G(PSODRUG("DEA"))'["S"&($G(PSODRUG("DEA"))'["I") !!,"This Rx has been flagged by the provider as: "_$S($G(PSOSCOTH):"NO COPAY",$G(PSORX("SC"))="SC":"NO COPAY",1:"COPAY"),! S PSOSCOTX=2
     133 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52A.m

    r613 r623  
    1 PSORN52A        ;IHS/DSD/JCM/SAB/FLS-Break up of PSORN52 ;08/09/93
    2         ;;7.0;OUTPATIENT PHARMACY;**157,148,268,225**;DEC 1997;Build 29
    3         Q  ; Call from tag
    4         ;
    5 IBHLD   ;
    6         I $P(PSOIBHLD,"^",2)="" S $P(PSOIBHLD,"^",2)=$S($P(PSOLDIBQ,"^",2)=1:1,$P(PSOLDIBQ,"^",2)=0:0,1:"")
    7         I $P(PSOIBHLD,"^",3)="" S $P(PSOIBHLD,"^",3)=$S($P(PSOLDIBQ,"^",3)=1:1,$P(PSOLDIBQ,"^",3)=0:0,1:"")
    8         I $P(PSOIBHLD,"^",4)="" S $P(PSOIBHLD,"^",4)=$S($P(PSOLDIBQ,"^",4)=1:1,$P(PSOLDIBQ,"^",4)=0:0,1:"")
    9         I $P(PSOIBHLD,"^",5)="" S $P(PSOIBHLD,"^",5)=$S($P(PSOLDIBQ,"^",5)=1:1,$P(PSOLDIBQ,"^",5)=0:0,1:"")
    10         I $P(PSOIBHLD,"^",6)="" S $P(PSOIBHLD,"^",6)=$S($P(PSOLDIBQ,"^",6)=1:1,$P(PSOLDIBQ,"^",6)=0:0,1:"")
    11         I $P(PSOIBHLD,"^",7)="" S $P(PSOIBHLD,"^",7)=$S($P(PSOLDIBQ,"^",7)=1:1,$P(PSOLDIBQ,"^",7)=0:0,1:"")
    12         I $P(PSOIBHLD,"^",8)="" S $P(PSOIBHLD,"^",8)=$S($P(PSOLDIBQ,"^",8)=1:1,$P(PSOLDIBQ,"^",8)=0:0,1:"")
    13         Q
    14         ;
    15 FILE    ; - Filling ^PSRX and ^PS(55 entries
    16         S PSOX("NRX0")=PSORENW("RX0"),PSOX("NRX2")=PSORENW("RX2"),PSOX("NRX3")=PSORENW("RX3"),$P(PSOX("NRX3"),"^",5)=""
    17         S $P(PSOX("NRX0"),"^")=PSOX("NRX #") S:$G(PSOX("PROVIDER"))]"" $P(PSOX("NRX0"),"^",4)=PSOX("PROVIDER")
    18         I $G(PSORNSPD),$G(PSOX("PATIENT STATUS")),$G(PSOX("PATIENT STATUS"))?.N S $P(PSOX("NRX0"),"^",3)=PSOX("PATIENT STATUS")
    19         S:$G(PSOX("COSIGNING PROVIDER"))]"" $P(PSOX("NRX3"),"^",3)=PSOX("COSIGNING PROVIDER")
    20         S $P(PSOX("NRX0"),"^",5)=PSOX("CLINIC"),$P(PSOX("NRX0"),"^",9)=PSOX("# OF REFILLS")
    21         I $G(PSOX("DAYS SUPPLY")) S $P(PSOX("NRX0"),"^",8)=PSOX("DAYS SUPPLY")
    22         I $G(PSOX("QTY")) S $P(PSOX("NRX0"),"^",7)=PSOX("QTY")
    23         S $P(PSOX("NRX0"),"^",11)=$S(PSOX("FILL DATE")>DT&($P(PSOPAR,"^",6)):"M",$D(PSOX("MAIL/WINDOW")):PSOX("MAIL/WINDOW"),1:$P(PSOX("NRX0"),"^",11))
    24         S $P(PSOX("NRX0"),"^",13)=PSOX("ISSUE DATE"),$P(PSOX("STA"),"^")=PSOX("STATUS"),$P(PSOX("NRX0"),"^",16)=$S($G(PSOX("CLERK CODE"))]"":PSOX("CLERK CODE"),1:DUZ)
    25         S $P(PSOX("NRX0"),"^",17)=$G(PSODRUG("COST"))
    26         S $P(PSOX("NRX2"),"^")=PSOX("LOGIN DATE"),$P(PSOX("NRX2"),"^",2)=PSOX("FILL DATE"),$P(PSOX("NRX2"),"^",3)="",$P(PSOX("NRX2"),"^",5)=PSOX("DISPENSED DATE")
    27         S $P(PSOX("NRX2"),"^",6)=PSOX("STOP DATE"),$P(PSOX("NRX2"),"^",7)=$S($G(PSOX("NDC"))]"":PSOX("NDC"),1:$G(PSODRUG("NDC")))
    28         S $P(PSOX("NRX2"),"^",8)=$S($G(PSOX("MANUFACTURER"))]"":PSOX("MANUFACTURER"),1:$G(PSODRUG("MANUFACTURER")))
    29         S $P(PSOX("NRX2"),"^",9)=+PSOSITE,$P(PSOX("NRX2"),"^",10)=""
    30         S $P(PSOX("NRX2"),"^",11)=$S($G(PSOX("EXPIRATION DATE"))]"":PSOX("EXPIRATION DATE"),1:$G(PSODRUG("EXPIRATION DATE")))
    31         S:$G(PSOX("GENERIC PROVIDER"))]"" $P(PSOX("NRX2"),"^",12)=PSOX("GENERIC PROVIDER")
    32         S $P(PSOX("NRX2"),"^",13)="",$P(PSOX("NRX2"),"^",15)="",$P(PSOX("NRX3"),"^",4)=$P(PSOX("NRX3"),"^")
    33         S $P(PSOX("EPH"),"^")=$S($G(PSOX("DAW"))]"":PSOX("DAW"),1:$G(PSODRUG("DAW")))
    34         ;S PSOX("LAST DISPENSED DATE")=$P(PSOX("NRX3"),"^")
    35         S PSOX("LAST DISPENSED DATE")=PSOX("DISPENSED DATE")
    36         S $P(PSOX("NRX3"),"^")=PSOX("LAST DISPENSED DATE")
    37         S:$G(PSOX("NEXT POSSIBLE REFILL"))]"" $P(PSOX("NRX3"),"^",2)=PSOX("NEXT POSSIBLE REFILL")
    38         S:'$P(^VA(200,$P(PSOX("NRX0"),"^",4),"PS"),"^",7) $P(PSOX("NRX3"),"^",3)=""
    39         S:$G(PSOX("REMARKS"))']"" PSOX("REMARKS")="RENEWED FROM RX # "_$P(PSOX("RX0"),"^")
    40         S $P(PSOX("NRX3"),"^",7)=PSOX("REMARKS"),$P(PSOX("NRX3"),"^",8)=""
    41         ;
    42         ; - File OTHER PATIENT INSTRUCTIONS into ^PSRX
    43         I $G(PSOFXRNX) S PSOFXRN=1
    44         D ^PSORN52C,FILE^PSORN52D
    45         I $G(^PSRX(PSOX("OIRXN"),"INSS"))]"" S ^PSRX(PSOX("IRXN"),"INSS")=^PSRX(PSOX("OIRXN"),"INSS") K PSOX1 G F55
    46         I $G(PSOX("SINS"))]"" S ^PSRX(PSOX("IRXN"),"INSS")=PSOX("SINS")
    47         K PSOX1
    48         ;
    49         ; - File data into ^PS(55)
    50 F55     L +^PS(55,PSODFN,"P"):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) S:'$D(^PS(55,PSODFN,"P",0)) ^(0)="^55.03PA^^"
    51         F PSOX1=$P(^PS(55,PSODFN,"P",0),"^",3):1 Q:'$D(^PS(55,PSODFN,"P",PSOX1))
    52         S PSOX("55 IEN")=PSOX1
    53         S ^PS(55,PSODFN,"P",PSOX1,0)=PSOX("IRXN"),$P(^PS(55,PSODFN,"P",0),"^",3,4)=PSOX1_"^"_($P(^PS(55,PSODFN,"P",0),"^",4)+1)
    54         S ^PS(55,PSODFN,"P","A",PSOX("STOP DATE"),PSOX("IRXN"))=""
    55         L -^PS(55,PSODFN,"P")
    56         K PSOX1
    57         ;
    58         ; - Patient Counseling questions
    59         I $G(OR0) D FULL^VALM1,COUN^PSONEW S PSONOOR=""
    60         I $D(^XUSEC("PSORPH",DUZ)) S DA=PSOX("IRXN"),DIE=52,DR="41////"_PSOCOU_";S:'X Y=""@1"";42////"_PSOCOUU_";@1" D ^DIE K DIE,DR
    61         ;
    62         ; - Re-indexing file 52 entry
    63         K DIK,DA S DIK="^PSRX(",DA=PSOX("IRXN") D IX1^DIK K DIK
    64         S DA=PSOX("IRXN") D ORC^PSORN52C
    65         Q
     1PSORN52A ;IHS/DSD/JCM/SAB/FLS-Break up of PSORN52 ;08/09/93
     2 ;;7.0;OUTPATIENT PHARMACY;**157,148,268**;DEC 1997;Build 9
     3 Q  ; Call from tag
     4 ;
     5IBHLD ;
     6 I $P(PSOIBHLD,"^",2)="" S $P(PSOIBHLD,"^",2)=$S($P(PSOLDIBQ,"^",2)=1:1,$P(PSOLDIBQ,"^",2)=0:0,1:"")
     7 I $P(PSOIBHLD,"^",3)="" S $P(PSOIBHLD,"^",3)=$S($P(PSOLDIBQ,"^",3)=1:1,$P(PSOLDIBQ,"^",3)=0:0,1:"")
     8 I $P(PSOIBHLD,"^",4)="" S $P(PSOIBHLD,"^",4)=$S($P(PSOLDIBQ,"^",4)=1:1,$P(PSOLDIBQ,"^",4)=0:0,1:"")
     9 I $P(PSOIBHLD,"^",5)="" S $P(PSOIBHLD,"^",5)=$S($P(PSOLDIBQ,"^",5)=1:1,$P(PSOLDIBQ,"^",5)=0:0,1:"")
     10 I $P(PSOIBHLD,"^",6)="" S $P(PSOIBHLD,"^",6)=$S($P(PSOLDIBQ,"^",6)=1:1,$P(PSOLDIBQ,"^",6)=0:0,1:"")
     11 I $P(PSOIBHLD,"^",7)="" S $P(PSOIBHLD,"^",7)=$S($P(PSOLDIBQ,"^",7)=1:1,$P(PSOLDIBQ,"^",7)=0:0,1:"")
     12 Q
     13 ;
     14FILE ; - Filling ^PSRX and ^PS(55 entries
     15 S PSOX("NRX0")=PSORENW("RX0"),PSOX("NRX2")=PSORENW("RX2"),PSOX("NRX3")=PSORENW("RX3"),$P(PSOX("NRX3"),"^",5)=""
     16 S $P(PSOX("NRX0"),"^")=PSOX("NRX #") S:$G(PSOX("PROVIDER"))]"" $P(PSOX("NRX0"),"^",4)=PSOX("PROVIDER")
     17 I $G(PSORNSPD),$G(PSOX("PATIENT STATUS")),$G(PSOX("PATIENT STATUS"))?.N S $P(PSOX("NRX0"),"^",3)=PSOX("PATIENT STATUS")
     18 S:$G(PSOX("COSIGNING PROVIDER"))]"" $P(PSOX("NRX3"),"^",3)=PSOX("COSIGNING PROVIDER")
     19 S $P(PSOX("NRX0"),"^",5)=PSOX("CLINIC"),$P(PSOX("NRX0"),"^",9)=PSOX("# OF REFILLS")
     20 I $G(PSOX("DAYS SUPPLY")) S $P(PSOX("NRX0"),"^",8)=PSOX("DAYS SUPPLY")
     21 I $G(PSOX("QTY")) S $P(PSOX("NRX0"),"^",7)=PSOX("QTY")
     22 S $P(PSOX("NRX0"),"^",11)=$S(PSOX("FILL DATE")>DT&($P(PSOPAR,"^",6)):"M",$D(PSOX("MAIL/WINDOW")):PSOX("MAIL/WINDOW"),1:$P(PSOX("NRX0"),"^",11))
     23 S $P(PSOX("NRX0"),"^",13)=PSOX("ISSUE DATE"),$P(PSOX("STA"),"^")=PSOX("STATUS"),$P(PSOX("NRX0"),"^",16)=$S($G(PSOX("CLERK CODE"))]"":PSOX("CLERK CODE"),1:DUZ)
     24 S $P(PSOX("NRX0"),"^",17)=$G(PSODRUG("COST"))
     25 S $P(PSOX("NRX2"),"^")=PSOX("LOGIN DATE"),$P(PSOX("NRX2"),"^",2)=PSOX("FILL DATE"),$P(PSOX("NRX2"),"^",3)="",$P(PSOX("NRX2"),"^",5)=PSOX("DISPENSED DATE")
     26 S $P(PSOX("NRX2"),"^",6)=PSOX("STOP DATE"),$P(PSOX("NRX2"),"^",7)=$S($G(PSOX("NDC"))]"":PSOX("NDC"),1:$G(PSODRUG("NDC")))
     27 S $P(PSOX("NRX2"),"^",8)=$S($G(PSOX("MANUFACTURER"))]"":PSOX("MANUFACTURER"),1:$G(PSODRUG("MANUFACTURER")))
     28 S $P(PSOX("NRX2"),"^",9)=+PSOSITE,$P(PSOX("NRX2"),"^",10)=""
     29 S $P(PSOX("NRX2"),"^",11)=$S($G(PSOX("EXPIRATION DATE"))]"":PSOX("EXPIRATION DATE"),1:$G(PSODRUG("EXPIRATION DATE")))
     30 S:$G(PSOX("GENERIC PROVIDER"))]"" $P(PSOX("NRX2"),"^",12)=PSOX("GENERIC PROVIDER")
     31 S $P(PSOX("NRX2"),"^",13)="",$P(PSOX("NRX2"),"^",15)="",$P(PSOX("NRX3"),"^",4)=$P(PSOX("NRX3"),"^")
     32 S $P(PSOX("EPH"),"^")=$S($G(PSOX("DAW"))]"":PSOX("DAW"),1:$G(PSODRUG("DAW")))
     33 ;S PSOX("LAST DISPENSED DATE")=$P(PSOX("NRX3"),"^")
     34 S PSOX("LAST DISPENSED DATE")=PSOX("DISPENSED DATE")
     35 S $P(PSOX("NRX3"),"^")=PSOX("LAST DISPENSED DATE")
     36 S:$G(PSOX("NEXT POSSIBLE REFILL"))]"" $P(PSOX("NRX3"),"^",2)=PSOX("NEXT POSSIBLE REFILL")
     37 S:'$P(^VA(200,$P(PSOX("NRX0"),"^",4),"PS"),"^",7) $P(PSOX("NRX3"),"^",3)=""
     38 S:$G(PSOX("REMARKS"))']"" PSOX("REMARKS")="RENEWED FROM RX # "_$P(PSOX("RX0"),"^")
     39 S $P(PSOX("NRX3"),"^",7)=PSOX("REMARKS"),$P(PSOX("NRX3"),"^",8)=""
     40 ;
     41 ; - File OTHER PATIENT INSTRUCTIONS into ^PSRX
     42 I $G(PSOFXRNX) S PSOFXRN=1
     43 D ^PSORN52C,FILE^PSORN52D
     44 I $G(^PSRX(PSOX("OIRXN"),"INSS"))]"" S ^PSRX(PSOX("IRXN"),"INSS")=^PSRX(PSOX("OIRXN"),"INSS") K PSOX1 G F55
     45 I $G(PSOX("SINS"))]"" S ^PSRX(PSOX("IRXN"),"INSS")=PSOX("SINS")
     46 K PSOX1
     47 ;
     48 ; - File data into ^PS(55)
     49F55 L +^PS(55,PSODFN,"P"):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) S:'$D(^PS(55,PSODFN,"P",0)) ^(0)="^55.03PA^^"
     50 F PSOX1=$P(^PS(55,PSODFN,"P",0),"^",3):1 Q:'$D(^PS(55,PSODFN,"P",PSOX1))
     51 S PSOX("55 IEN")=PSOX1
     52 S ^PS(55,PSODFN,"P",PSOX1,0)=PSOX("IRXN"),$P(^PS(55,PSODFN,"P",0),"^",3,4)=PSOX1_"^"_($P(^PS(55,PSODFN,"P",0),"^",4)+1)
     53 S ^PS(55,PSODFN,"P","A",PSOX("STOP DATE"),PSOX("IRXN"))=""
     54 L -^PS(55,PSODFN,"P")
     55 K PSOX1
     56 ;
     57 ; - Patient Counseling questions
     58 I $G(OR0) D FULL^VALM1,COUN^PSONEW S PSONOOR=""
     59 I $D(^XUSEC("PSORPH",DUZ)) S DA=PSOX("IRXN"),DIE=52,DR="41////"_PSOCOU_";S:'X Y=""@1"";42////"_PSOCOUU_";@1" D ^DIE K DIE,DR
     60 ;
     61 ; - Re-indexing file 52 entry
     62 K DIK,DA S DIK="^PSRX(",DA=PSOX("IRXN") D IX1^DIK K DIK
     63 S DA=PSOX("IRXN") D ORC^PSORN52C
     64 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52C.m

    r613 r623  
    1 PSORN52C        ;BIR/SAB-files renewal entries con't ;08/09/93
    2         ;;7.0;OUTPATIENT PHARMACY;**1,7,11,27,46,75,87,100,111,124,117,131,146,148,200,225**;DEC 1997;Build 29
    3         ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
    4         S DIC="^PSRX(",DLAYGO=52,DIC(0)="L",X=PSOX("NRX #") K DD,DO
    5         D FILE^DICN S PSOX("IRXN")=+Y K DLAYGO,X,Y,DIC,DD,DO
    6         D:+$G(DGI) TECH^PSODGDGI ; L +^PSRX(PSOX("IRXN")):0
    7         D:$G(^TMP("PSODAI",$J,0))
    8         .S $P(^PSRX(PSOX("IRXN"),3),"^",6)=1
    9         .I $O(^TMP("PSODAI",$J,0)) S DAI=0 F  S DAI=$O(^TMP("PSODAI",$J,DAI)) Q:'DAI  D
    10         ..S:'$D(^PSRX(PSOX("IRXN"),"DAI",0)) ^PSRX(PSOX("IRXN"),"DAI",0)="^52.03^^" S ^PSRX(PSOX("IRXN"),"DAI",DAI,0)=^TMP("PSODAI",$J,DAI,0)
    11         ..S $P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)=+$P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)+1,$P(^(0),"^",4)=+$P(^(0),"^",4)+1
    12         .K ^TMP("PSODAI",$J),DAI
    13         S PSORN52(PSOX("IRXN"),0)=PSOX("NRX0"),PSORN52(PSOX("IRXN"),2)=PSOX("NRX2"),PSORN52(PSOX("IRXN"),3)=PSOX("NRX3")
    14         S PSORN52(PSOX("IRXN"),"EPH")=PSOX("EPH")
    15         S:'$G(PSOX("ENT")) PSORN52(PSOX("IRXN"),"SIG")=PSOX("SIG")
    16         S PSORN52(PSOX("IRXN"),"STA")=PSOX("STA")
    17         S:$G(PSOX("TN"))]"" PSORN52(PSOX("IRXN"),"TN")=PSOX("TN")
    18         I $G(PSOX("METHOD OF PICK-UP"))]"",PSOX("FILL DATE")'>DT S PSORN52(PSOX("IRXN"),"MP")=PSOX("METHOD OF PICK-UP")
    19         S PSORN52(PSOX("IRXN"),"TYPE")=0
    20         S PSOX1="" F  S PSOX1=$O(PSORN52(PSOX("IRXN"),PSOX1)) Q:PSOX1=""  S ^PSRX(PSOX("IRXN"),PSOX1)=$G(PSORN52(PSOX("IRXN"),PSOX1))
    21         I $O(SIG(0)) D  G ENT
    22         .S II=0 F I=0:0 S I=$O(SIG(I)) Q:'I  S ^PSRX(PSOX("IRXN"),"SIG1",I,0)=SIG(I),II=II+1
    23         .S ^PSRX(PSOX("IRXN"),"SIG1",0)="^52.04A^"_II_"^"_II,$P(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1 K I,II
    24         .S $P(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1
    25 ENT     S ^PSRX(PSOX("IRXN"),"POE")=1,^PSRX(PSOX("IRXN"),"INS")=$G(PSOX("INS"))
    26         I $G(OR0) S:$P(OR0,"^",24) ^PSRX(PSOX("IRXN"),"PKI")=1
    27         I $G(PSOX("SIG",1))]"",'$O(PSOX("SIG",1)) S ^PSRX(PSOX("IRXN"),"INS1",1,0)=PSOX("SIG",1),^PSRX(PSOX("IRXN"),"INS1",0)="^52.0115^1^1^"_DT_"^^"
    28         I $O(^PSRX(PSOX("OIRXN"),"INS1",0)) D
    29         .F D=0:0 S D=$O(^PSRX(PSOX("OIRXN"),"INS1",D)) Q:'D  S ^PSRX(PSOX("IRXN"),"INS1",D,0)=^PSRX(PSOX("OIRXN"),"INS1",D,0)
    30         .S ^PSRX(PSOX("IRXN"),"INS1",0)=^PSRX(PSOX("OIRXN"),"INS1",0)
    31 TNT     F I=1:1:PSOX("ENT") S ^PSRX(PSOX("IRXN"),6,I,0)=PSOX("DOSE",I)_"^"_$G(PSOX("DOSE ORDERED",I))_"^"_$G(PSOX("UNITS",I))_"^"_$G(PSOX("NOUN",I))_"^" D
    32         .S ^PSRX(PSOX("IRXN"),6,I,0)=^PSRX(PSOX("IRXN"),6,I,0)_$G(PSOX("DURATION",I))_"^"_$G(PSOX("CONJUNCTION",I))_"^"_$G(PSOX("ROUTE",I))_"^"_$G(PSOX("SCHEDULE",I))_"^"_$G(PSOX("VERB",I))
    33         .I $G(PSOX("ODOSE",I))]"" S ^PSRX(PSOX("IRXN"),6,I,1)=PSOX("ODOSE",I)
    34         S:$G(PSOX("ENT")) ^PSRX(PSOX("IRXN"),6,0)="^52.0113^"_PSOX("ENT")_"^"_PSOX("ENT")
    35         Q
    36 ORC     ;
    37         D MARK^PSOTPCAN
    38         K PSORDEDT,GG,PSOHD,PSOID,PTST,PTDY,PTRF,RFCNT,RN,SEG1,SIG,SIGOK,DIC
    39         K ST0,STA,STP,STR,JJ,LSI,MM,ORDG,ORIG,PHARMST,PSCAN,PSCNT,PSOI,GMRAL,DIC,DIE,HDR,IEN,NAME D KVA^VADPT
    40         I $G(PSOFDR) D
    41         .I $G(PKI1)=1,$G(PKIR)]"" D ACT^PSOPKIV1(PSOX("IRXN"))
    42         .S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",2)=$P(OR0,"^"),^PSRX("APL",$P(OR0,"^"),PSOX("IRXN"))=""
    43         .I $P($G(^PS(52.41,+$G(ORD),"EXT")),"^")="" I $G(PSOSIGFL)!($G(PSODRUG("OI"))'=$P(OR0,"^",8)) K:'$G(PSOPRC) PRC K PHI
    44         .I $O(PRC(0)) S T=0 F  S T=$O(PRC(T)) Q:'T  S ^PSRX(PSOX("IRXN"),"PRC",T,0)=PRC(T),^PSRX(PSOX("IRXN"),"PRC",0)="^^"_T_"^"_T_"^"_DT_"^"
    45         .I $O(PHI(0)) S T=0 F  S T=$O(PHI(T)) Q:'T  S ^PSRX(PSOX("IRXN"),"PI",T,0)=PHI(T),^PSRX(PSOX("IRXN"),"PI",0)="^^"_T_"^"_T_"^"_DT_"^"
    46         .I $G(PSOSIGFL)!($G(PSODRUG("OI"))'=$P(OR0,"^",8)) D  S PSOI=1 Q
    47         ..S POERR("PLACER")=$P(^PS(52.41,ORD,0),"^"),PSORDEDT=ORD
    48         ..K ^PS(52.41,"AOR",PSODFN,+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD)
    49         ..S DA=ORD,DIK="^PS(52.41," D ^DIK
    50         ..S $P(^PSRX(PSOX("IRXN"),"OR1"),"^")=$G(PSODRUG("OI"))
    51         .E  S $P(^PSRX(PSOX("IRXN"),"OR1"),"^")=$P(OR0,"^",8)
    52         .D PSOUL^PSSLOCK(ORD_"S") S DIK="^PS(52.41,",DA=ORD D ^DIK K DIK,DA
    53         I $G(PSOX("OIRXN")),'$G(COPY) S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",3)=PSOX("OIRXN"),$P(^PSRX(PSOX("OIRXN"),"OR1"),"^",4)=PSOX("IRXN"),^PSRX("AQ",PSOX("IRXN"),PSOX("OIRXN"))="" K PRC
    54         I $O(PRC(0)) S T=0 F  S T=$O(PRC(T)) Q:'T  S ^PSRX(PSOX("IRXN"),"PRC",T,0)=PRC(T),^PSRX(PSOX("IRXN"),"PRC",0)="^^"_T_"^"_T_"^"_DT_"^"
    55         I $O(PHI(0)) S T=0 F  S T=$O(PHI(T)) Q:'T  S ^PSRX(PSOX("IRXN"),"PI",T,0)=PHI(T),^PSRX(PSOX("IRXN"),"PI",0)="^^"_T_"^"_T_"^"_DT_"^"
    56         S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",5)=DUZ
    57         S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",8)=$$NOW^XLFDT D
    58         . N DA,DIK S DA=PSOX("IRXN"),DIK="^PSRX(",DIK(1)=38.3 D EN1^DIK K DIK,DA
    59         S PHARMST="",$P(^PSRX(PSOX("IRXN"),"OR1"),"^")=$G(PSODRUG("OI"))
    60         S RXN=PSOX("IRXN") D SAVE
    61         S STAT=$S($G(OR0)]""&('$G(PSOI)):"SC",$G(PSOI):"RO",1:"SN") S PHARMST=$S('$G(PSORX("VERIFY")):"CM",1:"IP") ;D EN^PSOHLSN1(RXN,STAT,PHARMST,"",PSONOOR)
    62         S ^TMP("PSORXN",$J,RXN)=STAT_"^"_PHARMST_"^"_PSONOOR D PSOL^PSSLOCK(RXN)
    63         D RESTORE K PSORDEDT,PHI,PRC,STAT,COMM,PSOI,OR2,OR1,PHARMST,RXN,DRG,STA,ACT,OCXR,OCXD1,OCXDT,OCXI
    64         Q
    65 BBRX    ;build bingo board Rx array; called by PSON52,PSOR52,PSORN52
    66         I $G(BBRX(1))']"" S BBRX(1)=PSOX("IRXN")_"," Q
    67         F PSOX1=0:0 S PSOX1=$O(BBRX(PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
    68         I $L(BBRX(PSOX2))+$L(PSOX("IRXN"))<220 S BBRX(PSOX2)=BBRX(PSOX2)_PSOX("IRXN")_","
    69         E  S BBRX(PSOX2+1)=PSOX("IRXN")_","
    70         Q
    71 SAVE    ;this module will be used to save PSO arrays
    72         K ^TMP("PSOLST",$J) F I=0:0 S I=$O(PSOLST(I)) Q:'I  S ^TMP("PSOLST",$J,I,0)=PSOLST(I)
    73         K ^TMP("PSOSD",$J) S (STA,DRG)="" F  S STA=$O(PSOSD(STA)) Q:STA=""  F  S DRG=$O(PSOSD(STA,DRG)) Q:DRG=""  S ^TMP("PSOSD",$J,STA,DRG)=PSOSD(STA,DRG)
    74         I $G(PSOSD) S ^TMP("PSOSD",$J,0)=PSOSD
    75         I $G(PSODRUG("NAME"))]"" K ^TMP("PSODRUG",$J) S STA=""  F  S STA=$O(PSODRUG(STA)) Q:STA=""  S ^TMP("PSODRUG",$J,STA)=PSODRUG(STA)
    76         I $G(PSOX("# OF REFILLS"))]"" K ^TMP("PSOX",$J),^TMP("PSORENW",$J),^TMP("PSONEW",$J),^TMP("PSORXED",$J) D
    77         .S STA="" F  S STA=$O(PSOX(STA)) Q:STA=""  S ^TMP("PSOX",$J,STA)=$G(PSOX(STA)) D
    78         ..I STA="OLD LAST RX#",$O(PSOX(STA,"")) K ^TMP("PSOX",$J,STA) S ^TMP("PSOX",$J,STA,$O(PSOX(STA,"")))=PSOX(STA,$O(PSOX(STA,""))) D  Q
    79         ...I $O(PSONEW(STA,"")) S ^TMP("PSONEW",$J,STA,$O(PSONEW(STA,"")))=PSONEW(STA,$O(PSONEW(STA,"")))
    80         ...I $O(PSORENW(STA,"")) S ^TMP("PSORENW",$J,STA,$O(PSORENW(STA,"")))=PSORENW(STA,$O(PSORENW(STA,"")))
    81         ...I $O(PSORXED(STA,"")) S ^TMP("PSORXED",$J,STA,$O(PSORXED(STA,"")))=PSORXED(STA,$O(PSORXED(STA,"")))
    82         ..F ACT="PSORENW","PSONEW","PSORXED" I $G(@(ACT_"("""_STA_""")"))]"" S ^TMP(ACT,$J,STA)=@(ACT_"("""_STA_""")")
    83         K PSOPTPST,PSOSD,PSONEW,PSOLST,PSORENW,PSORXED,PSODRUG
    84         Q
    85 RESTORE ;this module restore saved arrays
    86         S STA=0 F  S STA=$O(^TMP("PSOLST",$J,STA)) Q:'STA  S PSOLST(STA)=^TMP("PSOLST",$J,STA,0)
    87         I $G(^TMP("PSOSD",$J,0)) S PSOSD=$G(^TMP("PSOSD",$J,0))
    88         S (STA,DRG)="" F  S STA=$O(^TMP("PSOSD",$J,STA)) Q:STA=""  F  S DRG=$O(^TMP("PSOSD",$J,STA,DRG)) Q:DRG=""  S PSOSD(STA,DRG)=^TMP("PSOSD",$J,STA,DRG)
    89         S STA="" F  S STA=$O(^TMP("PSODRUG",$J,STA)) Q:STA=""  S PSODRUG(STA)=^TMP("PSODRUG",$J,STA)
    90         S STA="" F ACT="PSOX","PSORENW","PSONEW","PSORXED" D:$O(^TMP(ACT,$J,STA))]""
    91         .F  S STA=$O(^TMP(ACT,$J,STA)) Q:STA=""  I STA'="OLD LAST RX#" S @(ACT_"("""_STA_""")")=^TMP(ACT,$J,STA)
    92         I $O(^TMP("PSOX",$J,"OLD LAST RX#","")) S PSOX("OLD LAST RX#",$O(^TMP("PSOX",$J,"OLD LAST RX#","")))=^TMP("PSOX",$J,"OLD LAST RX#",$O(^TMP("PSOX",$J,"OLD LAST RX#","")))
    93         I $O(^TMP("PSONEW",$J,"OLD LAST RX#","")) S PSONEW("OLD LAST RX#",$O(^TMP("PSONEW",$J,"OLD LAST RX#","")))=^TMP("PSONEW",$J,"OLD LAST RX#",$O(^TMP("PSONEW",$J,"OLD LAST RX#","")))
    94         I $O(^TMP("PSORENW",$J,"OLD LAST RX#","")) S PSORENW("OLD LAST RX#",$O(^TMP("PSORENW",$J,"OLD LAST RX#","")))=^TMP("PSORENW",$J,"OLD LAST RX#",$O(^TMP("PSORENW",$J,"OLD LAST RX#","")))
    95         I $O(^TMP("PSORXED",$J,"OLD LAST RX#","")) S PSORXED("OLD LAST RX#",$O(^TMP("PSORXED",$J,"OLD LAST RX#","")))=^TMP("PSORXED",$J,"OLD LAST RX#",$O(^TMP("PSORXED",$J,"OLD LAST RX#","")))
    96         K ^TMP("PSOSD",$J),^TMP("PSODRUG",$J),^TMP("PSOX",$J),^TMP("PSORENW",$J),^TMP("PSONEW",$J),^TMP("PSORXED",$J),^TMP("PSOLST",$J)
    97         Q
     1PSORN52C ;BIR/SAB-files renewal entries con't ;08/09/93
     2 ;;7.0;OUTPATIENT PHARMACY;**1,7,11,27,46,75,87,100,111,124,117,131,146,148,200**;DEC 1997;Build 7
     3 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
     4 S DIC="^PSRX(",DLAYGO=52,DIC(0)="L",X=PSOX("NRX #") K DD,DO
     5 D FILE^DICN S PSOX("IRXN")=+Y K DLAYGO,X,Y,DIC,DD,DO
     6 D:+$G(DGI) TECH^PSODGDGI ; L +^PSRX(PSOX("IRXN")):0
     7 D:$G(^TMP("PSODAI",$J,0))
     8 .S $P(^PSRX(PSOX("IRXN"),3),"^",6)=1
     9 .I $O(^TMP("PSODAI",$J,0)) S DAI=0 F  S DAI=$O(^TMP("PSODAI",$J,DAI)) Q:'DAI  D
     10 ..S:'$D(^PSRX(PSOX("IRXN"),"DAI",0)) ^PSRX(PSOX("IRXN"),"DAI",0)="^52.03^^" S ^PSRX(PSOX("IRXN"),"DAI",DAI,0)=^TMP("PSODAI",$J,DAI,0)
     11 ..S $P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)=+$P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)+1,$P(^(0),"^",4)=+$P(^(0),"^",4)+1
     12 .K ^TMP("PSODAI",$J),DAI
     13 S PSORN52(PSOX("IRXN"),0)=PSOX("NRX0"),PSORN52(PSOX("IRXN"),2)=PSOX("NRX2"),PSORN52(PSOX("IRXN"),3)=PSOX("NRX3")
     14 S PSORN52(PSOX("IRXN"),"EPH")=PSOX("EPH")
     15 S:'$G(PSOX("ENT")) PSORN52(PSOX("IRXN"),"SIG")=PSOX("SIG")
     16 S PSORN52(PSOX("IRXN"),"STA")=PSOX("STA")
     17 S:$G(PSOX("TN"))]"" PSORN52(PSOX("IRXN"),"TN")=PSOX("TN")
     18 I $G(PSOX("METHOD OF PICK-UP"))]"",PSOX("FILL DATE")'>DT S PSORN52(PSOX("IRXN"),"MP")=PSOX("METHOD OF PICK-UP")
     19 S PSORN52(PSOX("IRXN"),"TYPE")=0
     20 S PSOX1="" F  S PSOX1=$O(PSORN52(PSOX("IRXN"),PSOX1)) Q:PSOX1=""  S ^PSRX(PSOX("IRXN"),PSOX1)=$G(PSORN52(PSOX("IRXN"),PSOX1))
     21 I $O(SIG(0)) D  G ENT
     22 .S II=0 F I=0:0 S I=$O(SIG(I)) Q:'I  S ^PSRX(PSOX("IRXN"),"SIG1",I,0)=SIG(I),II=II+1
     23 .S ^PSRX(PSOX("IRXN"),"SIG1",0)="^52.04A^"_II_"^"_II,$P(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1 K I,II
     24 .S $P(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1
     25ENT S ^PSRX(PSOX("IRXN"),"POE")=1,^PSRX(PSOX("IRXN"),"INS")=$G(PSOX("INS"))
     26 I $G(OR0) S:$P(OR0,"^",24) ^PSRX(PSOX("IRXN"),"PKI")=1
     27 I $G(PSOX("SIG",1))]"",'$O(PSOX("SIG",1)) S ^PSRX(PSOX("IRXN"),"INS1",1,0)=PSOX("SIG",1),^PSRX(PSOX("IRXN"),"INS1",0)="^52.0115^1^1^"_DT_"^^"
     28 I $O(^PSRX(PSOX("OIRXN"),"INS1",0)) D
     29 .F D=0:0 S D=$O(^PSRX(PSOX("OIRXN"),"INS1",D)) Q:'D  S ^PSRX(PSOX("IRXN"),"INS1",D,0)=^PSRX(PSOX("OIRXN"),"INS1",D,0)
     30 .S ^PSRX(PSOX("IRXN"),"INS1",0)=^PSRX(PSOX("OIRXN"),"INS1",0)
     31TNT F I=1:1:PSOX("ENT") S ^PSRX(PSOX("IRXN"),6,I,0)=PSOX("DOSE",I)_"^"_$G(PSOX("DOSE ORDERED",I))_"^"_$G(PSOX("UNITS",I))_"^"_$G(PSOX("NOUN",I))_"^" D
     32 .S ^PSRX(PSOX("IRXN"),6,I,0)=^PSRX(PSOX("IRXN"),6,I,0)_$G(PSOX("DURATION",I))_"^"_$G(PSOX("CONJUNCTION",I))_"^"_$G(PSOX("ROUTE",I))_"^"_$G(PSOX("SCHEDULE",I))_"^"_$G(PSOX("VERB",I))
     33 .I $G(PSOX("ODOSE",I))]"" S ^PSRX(PSOX("IRXN"),6,I,1)=PSOX("ODOSE",I)
     34 S:$G(PSOX("ENT")) ^PSRX(PSOX("IRXN"),6,0)="^52.0113^"_PSOX("ENT")_"^"_PSOX("ENT")
     35 Q
     36ORC ;
     37 D MARK^PSOTPCAN
     38 K PSORDEDT,GG,PSOHD,PSOID,PTST,PTDY,PTRF,RFCNT,RN,SEG1,SIG,SIGOK,DIC
     39 K ST0,STA,STP,STR,JJ,LSI,MM,ORDG,ORIG,PHARMST,PSCAN,PSCNT,PSOI,GMRAL,DIC,DIE,HDR,IEN,NAME D KVA^VADPT
     40 I $G(PSOFDR) D
     41 .I $G(PKI1)=1,$G(PKIR)]"" D ACT^PSOPKIV1(PSOX("IRXN"))
     42 .S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",2)=$P(OR0,"^"),^PSRX("APL",$P(OR0,"^"),PSOX("IRXN"))=""
     43 .I $P($G(^PS(52.41,+$G(ORD),"EXT")),"^")="" I $G(PSOSIGFL)!($G(PSODRUG("OI"))'=$P(OR0,"^",8)) K:'$G(PSOPRC) PRC K PHI
     44 .I $O(PRC(0)) S T=0 F  S T=$O(PRC(T)) Q:'T  S ^PSRX(PSOX("IRXN"),"PRC",T,0)=PRC(T),^PSRX(PSOX("IRXN"),"PRC",0)="^^"_T_"^"_T_"^"_DT_"^"
     45 .I $O(PHI(0)) S T=0 F  S T=$O(PHI(T)) Q:'T  S ^PSRX(PSOX("IRXN"),"PI",T,0)=PHI(T),^PSRX(PSOX("IRXN"),"PI",0)="^^"_T_"^"_T_"^"_DT_"^"
     46 .I $G(PSOSIGFL)!($G(PSODRUG("OI"))'=$P(OR0,"^",8)) D  S PSOI=1 Q
     47 ..S POERR("PLACER")=$P(^PS(52.41,ORD,0),"^"),PSORDEDT=ORD
     48 ..K ^PS(52.41,"AOR",PSODFN,+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD)
     49 ..S DA=ORD,DIK="^PS(52.41," D ^DIK
     50 ..S $P(^PSRX(PSOX("IRXN"),"OR1"),"^")=$G(PSODRUG("OI"))
     51 .E  S $P(^PSRX(PSOX("IRXN"),"OR1"),"^")=$P(OR0,"^",8)
     52 .D PSOUL^PSSLOCK(ORD_"S") S DIK="^PS(52.41,",DA=ORD D ^DIK K DIK,DA
     53 S:$G(PSOX("OIRXN"))&('$G(COPY)) $P(^PSRX(PSOX("IRXN"),"OR1"),"^",3)=PSOX("OIRXN"),$P(^PSRX(PSOX("OIRXN"),"OR1"),"^",4)=PSOX("IRXN"),^PSRX("AQ",PSOX("IRXN"),PSOX("OIRXN"))=""
     54 I $O(PRC(0)) S T=0 F  S T=$O(PRC(T)) Q:'T  S ^PSRX(PSOX("IRXN"),"PRC",T,0)=PRC(T),^PSRX(PSOX("IRXN"),"PRC",0)="^^"_T_"^"_T_"^"_DT_"^"
     55 I $O(PHI(0)) S T=0 F  S T=$O(PHI(T)) Q:'T  S ^PSRX(PSOX("IRXN"),"PI",T,0)=PHI(T),^PSRX(PSOX("IRXN"),"PI",0)="^^"_T_"^"_T_"^"_DT_"^"
     56 S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",5)=DUZ
     57 S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",8)=$$NOW^XLFDT D
     58 . N DA,DIK S DA=PSOX("IRXN"),DIK="^PSRX(",DIK(1)=38.3 D EN1^DIK K DIK,DA
     59 S PHARMST="",$P(^PSRX(PSOX("IRXN"),"OR1"),"^")=$G(PSODRUG("OI"))
     60 S RXN=PSOX("IRXN") D SAVE
     61 S STAT=$S($G(OR0)]""&('$G(PSOI)):"SC",$G(PSOI):"RO",1:"SN") S PHARMST=$S('$G(PSORX("VERIFY")):"CM",1:"IP") ;D EN^PSOHLSN1(RXN,STAT,PHARMST,"",PSONOOR)
     62 S ^TMP("PSORXN",$J,RXN)=STAT_"^"_PHARMST_"^"_PSONOOR D PSOL^PSSLOCK(RXN)
     63 D RESTORE K PSORDEDT,PHI,PRC,STAT,COMM,PSOI,OR2,OR1,PHARMST,RXN,DRG,STA,ACT,OCXR,OCXD1,OCXDT,OCXI
     64 Q
     65BBRX ;build bingo board Rx array; called by PSON52,PSOR52,PSORN52
     66 I $G(BBRX(1))']"" S BBRX(1)=PSOX("IRXN")_"," Q
     67 F PSOX1=0:0 S PSOX1=$O(BBRX(PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
     68 I $L(BBRX(PSOX2))+$L(PSOX("IRXN"))<220 S BBRX(PSOX2)=BBRX(PSOX2)_PSOX("IRXN")_","
     69 E  S BBRX(PSOX2+1)=PSOX("IRXN")_","
     70 Q
     71SAVE ;this module will be used to save PSO arrays
     72 K ^TMP("PSOLST",$J) F I=0:0 S I=$O(PSOLST(I)) Q:'I  S ^TMP("PSOLST",$J,I,0)=PSOLST(I)
     73 K ^TMP("PSOSD",$J) S (STA,DRG)="" F  S STA=$O(PSOSD(STA)) Q:STA=""  F  S DRG=$O(PSOSD(STA,DRG)) Q:DRG=""  S ^TMP("PSOSD",$J,STA,DRG)=PSOSD(STA,DRG)
     74 I $G(PSOSD) S ^TMP("PSOSD",$J,0)=PSOSD
     75 I $G(PSODRUG("NAME"))]"" K ^TMP("PSODRUG",$J) S STA=""  F  S STA=$O(PSODRUG(STA)) Q:STA=""  S ^TMP("PSODRUG",$J,STA)=PSODRUG(STA)
     76 I $G(PSOX("# OF REFILLS"))]"" K ^TMP("PSOX",$J),^TMP("PSORENW",$J),^TMP("PSONEW",$J),^TMP("PSORXED",$J) D
     77 .S STA="" F  S STA=$O(PSOX(STA)) Q:STA=""  S ^TMP("PSOX",$J,STA)=$G(PSOX(STA)) D
     78 ..I STA="OLD LAST RX#",$O(PSOX(STA,"")) K ^TMP("PSOX",$J,STA) S ^TMP("PSOX",$J,STA,$O(PSOX(STA,"")))=PSOX(STA,$O(PSOX(STA,""))) D  Q
     79 ...I $O(PSONEW(STA,"")) S ^TMP("PSONEW",$J,STA,$O(PSONEW(STA,"")))=PSONEW(STA,$O(PSONEW(STA,"")))
     80 ...I $O(PSORENW(STA,"")) S ^TMP("PSORENW",$J,STA,$O(PSORENW(STA,"")))=PSORENW(STA,$O(PSORENW(STA,"")))
     81 ...I $O(PSORXED(STA,"")) S ^TMP("PSORXED",$J,STA,$O(PSORXED(STA,"")))=PSORXED(STA,$O(PSORXED(STA,"")))
     82 ..F ACT="PSORENW","PSONEW","PSORXED" I $G(@(ACT_"("""_STA_""")"))]"" S ^TMP(ACT,$J,STA)=@(ACT_"("""_STA_""")")
     83 K PSOPTPST,PSOSD,PSONEW,PSOLST,PSORENW,PSORXED,PSODRUG
     84 Q
     85RESTORE ;this module restore saved arrays
     86 S STA=0 F  S STA=$O(^TMP("PSOLST",$J,STA)) Q:'STA  S PSOLST(STA)=^TMP("PSOLST",$J,STA,0)
     87 I $G(^TMP("PSOSD",$J,0)) S PSOSD=$G(^TMP("PSOSD",$J,0))
     88 S (STA,DRG)="" F  S STA=$O(^TMP("PSOSD",$J,STA)) Q:STA=""  F  S DRG=$O(^TMP("PSOSD",$J,STA,DRG)) Q:DRG=""  S PSOSD(STA,DRG)=^TMP("PSOSD",$J,STA,DRG)
     89 S STA="" F  S STA=$O(^TMP("PSODRUG",$J,STA)) Q:STA=""  S PSODRUG(STA)=^TMP("PSODRUG",$J,STA)
     90 S STA="" F ACT="PSOX","PSORENW","PSONEW","PSORXED" D:$O(^TMP(ACT,$J,STA))]""
     91 .F  S STA=$O(^TMP(ACT,$J,STA)) Q:STA=""  I STA'="OLD LAST RX#" S @(ACT_"("""_STA_""")")=^TMP(ACT,$J,STA)
     92 I $O(^TMP("PSOX",$J,"OLD LAST RX#","")) S PSOX("OLD LAST RX#",$O(^TMP("PSOX",$J,"OLD LAST RX#","")))=^TMP("PSOX",$J,"OLD LAST RX#",$O(^TMP("PSOX",$J,"OLD LAST RX#","")))
     93 I $O(^TMP("PSONEW",$J,"OLD LAST RX#","")) S PSONEW("OLD LAST RX#",$O(^TMP("PSONEW",$J,"OLD LAST RX#","")))=^TMP("PSONEW",$J,"OLD LAST RX#",$O(^TMP("PSONEW",$J,"OLD LAST RX#","")))
     94 I $O(^TMP("PSORENW",$J,"OLD LAST RX#","")) S PSORENW("OLD LAST RX#",$O(^TMP("PSORENW",$J,"OLD LAST RX#","")))=^TMP("PSORENW",$J,"OLD LAST RX#",$O(^TMP("PSORENW",$J,"OLD LAST RX#","")))
     95 I $O(^TMP("PSORXED",$J,"OLD LAST RX#","")) S PSORXED("OLD LAST RX#",$O(^TMP("PSORXED",$J,"OLD LAST RX#","")))=^TMP("PSORXED",$J,"OLD LAST RX#",$O(^TMP("PSORXED",$J,"OLD LAST RX#","")))
     96 K ^TMP("PSOSD",$J),^TMP("PSODRUG",$J),^TMP("PSOX",$J),^TMP("PSORENW",$J),^TMP("PSONEW",$J),^TMP("PSORXED",$J),^TMP("PSOLST",$J)
     97 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52D.m

    r613 r623  
    1 PSORN52D        ;BIR/LE - files new and renewal entries con't ;02/27/04
    2         ;;7.0;OUTPATIENT PHARMACY;**143,219,239,225**;DEC 1997;Build 29
    3         ;External reference VADPT supported by DBIA 10061
    4         Q
    5 GET     ;must have FILE and PSORENW variables to pull default data for ICD and SC/EI for SC>50% Rx's from file 52
    6         N ARRAY,ERR,SUBF,RXN,II,JJ,ORXN,SUBFLD,PENDSC,PSOPATST,PSOIBQF
    7         I FILE=52 S SUBF=52.052311,SUBFLD=52311,RXN=PSORENW("IRXN"),(SRXN,ORXN)=PSORENW("OIRXN") S:($TR($G(^PSRX(SRXN,"IBQ")),"^")'="") PSOIBQF=1
    8         ;$TR checks for when patient status is exempt, null IBQ node was set for exempts, or SC>50 - data is in ICD node
    9         I FILE=52.41 S SUBF=52.41311,SUBFLD=311,(SRXN,RXN)=ORD,ORXN=PSORENW("OIRXN") S:($TR($G(^PS(52.41,SRXN,"IBQ")),"^")'="") PSOIBQF=1
    10         D GETS^DIQ(FILE,SRXN,SUBFLD_"*","I","ARRAY","ERR")
    11         K PSORX("ICD"),PSOX("ICD")
    12         Q:'$D(ARRAY)
    13         I FILE=52.41 S PENDSC=$$GET1^DIQ(52.41,ORD,"17"),PENDSC=$S(PENDSC="SC":1,PENDSC="NSC":0,1:"")
    14         S PSOPATST=$$GET1^DIQ(52,RXN_",",3,"I")
    15         ;
    16 G1      ;get ICD, if no IBQ node get SC/EI's
    17         F II=1:1:8 Q:'$D(ARRAY(SUBF,(II_","_SRXN_",")))  D
    18         . S PSORX("ICD",II)=ARRAY(SUBF,(II_","_SRXN_","),.01,"I") S:FILE=52.41 PSONEW("ICD",II)=PSORX("ICD",II)
    19         . Q:II>1!($G(PSOIBQF))  ;only need ei's from 1st node; all nodes same for SC/EI
    20         . F JJ=1:1:8 I ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")=1!(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")=0) D
    21         .. I JJ=1 S (PSOANSQ(RXN,"VEH"),PSORX(ORXN,"VEH"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
    22         .. I JJ=2 S (PSOANSQ(RXN,"RAD"),PSORX(ORXN,"RAD"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
    23         .. I JJ=4 S (PSOANSQ(RXN,"PGW"),PSORX(ORXN,"PGW"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
    24         .. I JJ=5 S (PSOANSQ(RXN,"MST"),PSORX(ORXN,"MST"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
    25         .. I JJ=6 S (PSOANSQ(RXN,"HNC"),PSORX(ORXN,"HNC"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
    26         .. I JJ=7 S (PSOANSQ(RXN,"CV"),PSORX(ORXN,"CV"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
    27         .. I JJ=8 S (PSOANSQ(RXN,"SHAD"),PSORX(ORXN,"SHAD"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
    28         I '$G(PSOIBQF) S II=1,JJ=3 D
    29         . I PSOSCP>49&(FILE=52.41) S (PSOANSQ(RXN,"SC>50"),PSORX(ORXN,"SC>50"),PSOANSQ("SC>50"))=PENDSC Q
    30         . I PSOSCP>49&(FILE'=52.41) S:$D(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")) (PSOANSQ(RXN,"SC>50"),PSOANSQ("SC>50"),PSORX(ORXN,"SC>50"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
    31         . ; when patient status is exempt use SC>50 variable to differenciate regular SC<50 and exempt SC<50
    32         . I PSOSCP<50&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)=1) D
    33         .. I FILE=52.41 S (PSOANSQ(RXN,"SC>50"),PSORX(ORXN,"SC>50"),PSOANSQ("SC>50"))=PENDSC Q
    34         .. S:$G(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")) (PSOANSQ(RXN,"SC>50"),PSORX(ORXN,"SC>50"),PSOANSQ("SC>50"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")
    35         . I PSOSCP<50&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)'=1) D
    36         .. I FILE=52.41 S (PSOANSQ(RXN,"SC"),PSORX(ORXN,"SC"),PSOANSQ("SC"))=PENDSC Q
    37         .. S:$D(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")) (PSOANSQ(RXN,"SC"),PSORX(ORXN,"SC"),PSOANSQ("SC"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")
    38         Q
    39         ;
    40 FILE    ;
    41         Q:'$D(^PSRX(PSOX("OIRXN"),"ICD"))
    42         N II F II=1:1:8 Q:$G(^PSRX(PSOX("OIRXN"),"ICD",II,0))=""  D
    43         . S ^PSRX(PSOX("IRXN"),"ICD",II,0)=$G(^PSRX(PSOX("OIRXN"),"ICD",II,0))
    44         . S:$P(^PSRX(PSOX("IRXN"),"ICD",II,0),"^",1)'="" ^PSRX(PSOX("IRXN"),"ICD","B",$P(^PSRX(PSOX("IRXN"),"ICD",II,0),"^",1),II)=""
    45         I II>1 S ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311^"_(II-1)_"^"_(II-1)
    46         Q
    47 FILE2   ;file ICD's on existing node or build new nodes
    48         ;note: variable PSOSCP2 is only available from CPRS Edit API and MISS
    49         ;        sub-routine below.
    50         N D,RXN,II,TYPE,DATA,DATA1,PSOPATST
    51         I $G(PSOX("IRXN")) S PSOPATST=$$GET1^DIQ(52,PSOX("IRXN")_",",3,"I")
    52         ;I '$G(PSONEW("PATIENT STATUS")) I $G(PSOX("IRXN")) S PSONEW("PATIENT STATUS")=$$GET1^DIQ(52,PSOX("IRXN")_",",3,"I")
    53         I $G(PSOSCP2)!($G(PSOFDR)&($G(ORD))) D
    54         .;if RX edited in CPRS delete all but what is sent from CPRS
    55         . K ^PSRX(PSOX("IRXN"),"ICD"),^PSRX(PSOX("IRXN"),"IBQ")
    56         S DATA="^^^^^^^^",(DATA1,TYPE)=""
    57         S $P(DATA,U,4)=$S(PSOSCP>49:$G(PSOANSQ("SC>50")),PSOSCP<50&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)=1):$G(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$G(PSOANSQ("SC")),1:"")
    58         F  S TYPE=$O(PSOANSQ(PSOX("IRXN"),TYPE)) Q:TYPE=""  D
    59         . I TYPE="VEH" S $P(DATA,U,2)=PSOANSQ(PSOX("IRXN"),"VEH")
    60         . I TYPE="RAD" S $P(DATA,U,3)=PSOANSQ(PSOX("IRXN"),"RAD")
    61         . I TYPE="PGW" S $P(DATA,U,5)=PSOANSQ(PSOX("IRXN"),"PGW")
    62         . I TYPE="MST" S $P(DATA,U,6)=PSOANSQ(PSOX("IRXN"),"MST")
    63         . I TYPE="HNC" S $P(DATA,U,7)=PSOANSQ(PSOX("IRXN"),"HNC")
    64         . I TYPE="CV" S $P(DATA,U,8)=PSOANSQ(PSOX("IRXN"),"CV")
    65         . I TYPE="SHAD" S $P(DATA,U,9)=PSOANSQ(PSOX("IRXN"),"SHAD")
    66         I $O(PSORX("ICD","")) F D=1:1:8 Q:'$D(PSORX("ICD",D))  S $P(DATA,"^")=PSORX("ICD",D) D
    67         . S ^PSRX(PSOX("IRXN"),"ICD",D,0)=DATA,$P(DATA,"^")="",^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311P^"_D_"^"_D
    68         . S:PSORX("ICD",D)'="" ^PSRX(PSOX("IRXN"),"ICD","B",PSORX("ICD",D),D)=""
    69         E  S ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311P^1^1",^PSRX(PSOX("IRXN"),"ICD",1,0)=$G(DATA)
    70         I PSOSCP<50&(($TR(DATA,"^")'=""))&(($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)'=1)) D
    71         .S DATA1=$G(PSOANSQ("SC"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"MST"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"VEH"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"RAD"))
    72         .S DATA1=DATA1_"^"_$G(PSOANSQ(PSOX("IRXN"),"PGW"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"HNC"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"CV"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"SHAD"))
    73         .S:($TR(DATA1,"^")'="") ^PSRX(PSOX("IRXN"),"IBQ")=DATA1
    74         K PSORX("ICD")
    75         Q
    76         ;
    77 RESET   ;called from reset copay status PSOCPC
    78         ;Must be available at this point:  PSODA, PSOIBQ=SC^MST^AO^IR^EC^HNC^CV^SHAD
    79         Q:'$D(PSODA)!('$D(PSOIBQ))
    80         Q:'$D(^PSRX(PSODA))
    81         ;Q:'$D(^PSRX(PSODA,"ICD"))  ;if old Rx and no ICD's defined; don't set
    82         N I,DATA,PSOICD
    83         S:$D(^PSRX(PSODA,"ICD")) PSOICD=1
    84         I '$G(DFN) S DFN=$$GET1^DIQ(52,PSODA_",",2,"I")
    85         S DATA="^^^^^^^^"
    86         F I=1:1:8 D
    87         . I I=1 S $P(DATA,"^",4)=$P(PSOIBQ,"^",I)
    88         . I I=2 S $P(DATA,"^",6)=$P(PSOIBQ,"^",I)
    89         . I I=3 S $P(DATA,"^",2)=$P(PSOIBQ,"^",I)
    90         . I I=4 S $P(DATA,"^",3)=$P(PSOIBQ,"^",I)
    91         . I I=5 S $P(DATA,"^",5)=$P(PSOIBQ,"^",I)
    92         . I I=6 S $P(DATA,"^",7)=$P(PSOIBQ,"^",I)
    93         . I I=7 S $P(DATA,"^",8)=$P(PSOIBQ,"^",I)
    94         . I I=8 S $P(DATA,"^",9)=$P(PSOIBQ,"^",I)
    95         I $G(PSOICD) S I=0 F  S I=$O(^PSRX(PSODA,"ICD",I)) Q:I=""!(I'?1N.NN)  D
    96         . Q:'$D(^PSRX(PSODA,"ICD",I,0))
    97         . S $P(^PSRX(PSODA,"ICD",I,0),"^",2,9)=$P(DATA,"^",2,9)
    98         ; for pre-cidc RX
    99         I '$G(PSOICD) S ^PSRX(PSODA,"ICD",1,0)="^"_$P(DATA,"^",2,9),^PSRX(PSODA,"ICD",0)="^52.052311P^1^1"
    100         Q
    101         ;
    102 SCP     ;Called from multiple routines - DFN or PSODFN variable must be available to call this subroutine.
    103         I '$G(DFN) S DFN=+$G(PSODFN)
    104         D ELIG^VADPT S PSOANSQ("SC>50")="",(PSOSCA,PSOSCP)="",PSOSCP=$P(VAEL(3),U,2)
    105         S:PSOSCP=""&($P(VAEL(3),U)=1) PSOSCP=0
    106         S PSOSCA=$$SC^SDCO22(DFN)
    107         K VAEL
    108         Q
    109 SHAD    ;
    110         N XX
    111         I $P($G(PSOPIBQ),U,8)]"" S XX=$P(PSOPIBQ,U,8) I XX=0!(XX=1) S PSOANSQ(PSOX("IRXN"),"SHAD")=XX Q
    112         I $P($G(^PSRX(RXN,"ICD",1,0)),U,9)]"" S XX=$P($G(^PSRX(PSOX("IRXN"),"ICD",1,0)),U,9) S:XX=0!(XX=1) PSOANSQ(PSOX("IRXN"),"SHAD")=XX
    113         Q
    114         ;
    115 SET3    ;for when patient status is exempt or SC>50
    116         N PSOPATST S PSOPATST=PSORX("PATIENT STATUS")
    117         I PSORX("PATIENT STATUS")'?1N.N S PSOPATST="",PSOPATST=$O(^PS(53,"B",PSORX("PATIENT STATUS"),PSOPATST))
    118         F JJJ=2:1:9 I $P(PSOOICD,"^",JJJ)=0!($P(PSOOICD,"^",JJJ)=1) D
    119         . I JJJ=2 S PSORX(PSOIBOLD,"VEH")=$P(PSOOICD,"^",JJJ)
    120         . I JJJ=3 S PSORX(PSOIBOLD,"RAD")=$P(PSOOICD,"^",JJJ)
    121         . I JJJ=4 D
    122         .. S:PSOSCP<50 PSORX(PSOIBOLD,"SC")=$P(PSOOICD,"^",JJJ)
    123         .. S:PSOSCP>49!($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)=1) PSORX(PSOIBOLD,"SC>50")=$P(PSOOICD,"^",JJJ)
    124         . I JJJ=5 S PSORX(PSOIBOLD,"PGW")=$P(PSOOICD,"^",JJJ)
    125         . I JJJ=6 S PSORX(PSOIBOLD,"MST")=$P(PSOOICD,"^",JJJ)
    126         . I JJJ=7 S PSORX(PSOIBOLD,"HNC")=$P(PSOOICD,"^",JJJ)
    127         . I JJJ=8 S PSORX(PSOIBOLD,"CV")=$P(PSOOICD,"^",JJJ)
    128         . I JJJ=9 S PSORX(PSOIBOLD,"SHAD")=$P(PSOOICD,"^",JJJ)
    129         K JJJ,PSOOICD
    130         Q
     1PSORN52D ;BIR/LE - files new and renewal entries con't ;02/27/04
     2 ;;7.0;OUTPATIENT PHARMACY;**143,219,239**;DEC 1997
     3 ;External reference VADPT supported by DBIA 10061
     4 Q
     5GET ;must have FILE and PSORENW variables to pull default data for ICD and SC/EI for SC>50% Rx's from file 52
     6 N ARRAY,ERR,SUBF,RXN,II,JJ,ORXN,SUBFLD,PENDSC,PSOPATST,PSOIBQF
     7 I FILE=52 S SUBF=52.052311,SUBFLD=52311,RXN=PSORENW("IRXN"),(SRXN,ORXN)=PSORENW("OIRXN") S:($TR($G(^PSRX(SRXN,"IBQ")),"^")'="") PSOIBQF=1
     8 ;            $TR checks for when patient status is exempt, null IBQ node was set for exempts, or SC>50 - data is in ICD node
     9 I FILE=52.41 S SUBF=52.41311,SUBFLD=311,(SRXN,RXN)=ORD,ORXN=PSORENW("OIRXN") S:($TR($G(^PS(52.41,SRXN,"IBQ")),"^")'="") PSOIBQF=1
     10 D GETS^DIQ(FILE,SRXN,SUBFLD_"*","I","ARRAY","ERR")
     11 K PSORX("ICD"),PSOX("ICD")
     12 Q:'$D(ARRAY)
     13 I FILE=52.41 S PENDSC=$$GET1^DIQ(52.41,ORD,"17"),PENDSC=$S(PENDSC="SC":1,PENDSC="NSC":0,1:"")
     14 S PSOPATST=$$GET1^DIQ(52,RXN_",",3,"I")
     15 ;
     16G1 ;get ICD, if no IBQ node get SC/EI's
     17 F II=1:1:8 Q:'$D(ARRAY(SUBF,(II_","_SRXN_",")))  D
     18 . S PSORX("ICD",II)=ARRAY(SUBF,(II_","_SRXN_","),.01,"I") S:FILE=52.41 PSONEW("ICD",II)=PSORX("ICD",II)
     19 . Q:II>1!($G(PSOIBQF))  ;only need ei's from 1st node; all nodes same for SC/EI
     20 . F JJ=1:1:7 I ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")=1!(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")=0) D
     21 .. I JJ=1 S (PSOANSQ(RXN,"VEH"),PSORX(ORXN,"VEH"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
     22 .. I JJ=2 S (PSOANSQ(RXN,"RAD"),PSORX(ORXN,"RAD"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
     23 .. I JJ=4 S (PSOANSQ(RXN,"PGW"),PSORX(ORXN,"PGW"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
     24 .. I JJ=5 S (PSOANSQ(RXN,"MST"),PSORX(ORXN,"MST"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
     25 .. I JJ=6 S (PSOANSQ(RXN,"HNC"),PSORX(ORXN,"HNC"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
     26 .. I JJ=7 S (PSOANSQ(RXN,"CV"),PSORX(ORXN,"CV"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
     27 ;
     28 I '$G(PSOIBQF) S II=1,JJ=3 D
     29 . I PSOSCP>49&(FILE=52.41) S (PSOANSQ(RXN,"SC>50"),PSORX(ORXN,"SC>50"),PSOANSQ("SC>50"))=PENDSC Q
     30 . I PSOSCP>49&(FILE'=52.41) S:$D(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")) (PSOANSQ(RXN,"SC>50"),PSOANSQ("SC>50"),PSORX(ORXN,"SC>50"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q
     31 . ; when patient status is exempt use SC>50 variable to differenciate regular SC<50 and exempt SC<50
     32 . I PSOSCP<50&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)=1) D
     33 .. I FILE=52.41 S (PSOANSQ(RXN,"SC>50"),PSORX(ORXN,"SC>50"),PSOANSQ("SC>50"))=PENDSC Q
     34 .. S:$G(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")) (PSOANSQ(RXN,"SC>50"),PSORX(ORXN,"SC>50"),PSOANSQ("SC>50"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")
     35 . I PSOSCP<50&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)'=1) D
     36 .. I FILE=52.41 S (PSOANSQ(RXN,"SC"),PSORX(ORXN,"SC"),PSOANSQ("SC"))=PENDSC Q
     37 .. S:$D(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")) (PSOANSQ(RXN,"SC"),PSORX(ORXN,"SC"),PSOANSQ("SC"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")
     38 ;
     39 Q
     40 ;
     41FILE ;
     42 Q:'$D(^PSRX(PSOX("OIRXN"),"ICD"))
     43 N II F II=1:1:8 Q:$G(^PSRX(PSOX("OIRXN"),"ICD",II,0))=""  D
     44 . S ^PSRX(PSOX("IRXN"),"ICD",II,0)=$G(^PSRX(PSOX("OIRXN"),"ICD",II,0))
     45 . S:$P(^PSRX(PSOX("IRXN"),"ICD",II,0),"^",1)'="" ^PSRX(PSOX("IRXN"),"ICD","B",$P(^PSRX(PSOX("IRXN"),"ICD",II,0),"^",1),II)=""
     46 I II>1 S ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311^"_(II-1)_"^"_(II-1)
     47 Q
     48FILE2 ;file ICD's on existing node or build new nodes
     49 ;note: variable PSOSCP2 is only available from CPRS Edit API and MISS
     50 ;        sub-routine below.
     51 N D,RXN,II,TYPE,DATA,DATA1,PSOPATST
     52 I $G(PSOX("IRXN")) S PSOPATST=$$GET1^DIQ(52,PSOX("IRXN")_",",3,"I")
     53 ;I '$G(PSONEW("PATIENT STATUS")) I $G(PSOX("IRXN")) S PSONEW("PATIENT STATUS")=$$GET1^DIQ(52,PSOX("IRXN")_",",3,"I")
     54 I $G(PSOSCP2)!($G(PSOFDR)&($G(ORD))) D
     55 .;if RX edited in CPRS delete all but what is sent from CPRS
     56 . K ^PSRX(PSOX("IRXN"),"ICD"),^PSRX(PSOX("IRXN"),"IBQ")
     57 ;
     58 S DATA="^^^^^^^",(DATA1,TYPE)=""
     59 S $P(DATA,U,4)=$S(PSOSCP>49:$G(PSOANSQ("SC>50")),PSOSCP<50&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)=1):$G(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$G(PSOANSQ("SC")),1:"")
     60 ;
     61 F  S TYPE=$O(PSOANSQ(PSOX("IRXN"),TYPE)) Q:TYPE=""  D
     62 . I TYPE="VEH" S $P(DATA,U,2)=PSOANSQ(PSOX("IRXN"),"VEH")
     63 . I TYPE="RAD" S $P(DATA,U,3)=PSOANSQ(PSOX("IRXN"),"RAD")
     64 . I TYPE="PGW" S $P(DATA,U,5)=PSOANSQ(PSOX("IRXN"),"PGW")
     65 . I TYPE="MST" S $P(DATA,U,6)=PSOANSQ(PSOX("IRXN"),"MST")
     66 . I TYPE="HNC" S $P(DATA,U,7)=PSOANSQ(PSOX("IRXN"),"HNC")
     67 . I TYPE="CV" S $P(DATA,U,8)=PSOANSQ(PSOX("IRXN"),"CV")
     68 ;
     69 I $O(PSORX("ICD","")) F D=1:1:8 Q:'$D(PSORX("ICD",D))  S $P(DATA,"^")=PSORX("ICD",D) D
     70 . S ^PSRX(PSOX("IRXN"),"ICD",D,0)=DATA,$P(DATA,"^")="",^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311P^"_D_"^"_D
     71 . S:PSORX("ICD",D)'="" ^PSRX(PSOX("IRXN"),"ICD","B",PSORX("ICD",D),D)=""
     72 E  S ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311P^1^1",^PSRX(PSOX("IRXN"),"ICD",1,0)=$G(DATA)
     73 ;
     74 I PSOSCP<50&(($TR(DATA,"^")'=""))&(($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)'=1)) D
     75 .S DATA1=$G(PSOANSQ("SC"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"MST"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"VEH"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"RAD"))
     76 .S DATA1=DATA1_"^"_$G(PSOANSQ(PSOX("IRXN"),"PGW"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"HNC"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"CV"))
     77 .S:($TR(DATA1,"^")'="") ^PSRX(PSOX("IRXN"),"IBQ")=DATA1
     78 K PSORX("ICD")
     79 Q
     80 ;
     81RESET ;called from reset copay status PSOCPC
     82 ;Must be available at this point:  PSODA, PSOIBQ=SC^MST^AO^IR^EC^HNC^CV
     83 Q:'$D(PSODA)!('$D(PSOIBQ))
     84 Q:'$D(^PSRX(PSODA))
     85 ;Q:'$D(^PSRX(PSODA,"ICD"))  ;if old Rx and no ICD's defined; don't set
     86 N I,DATA,PSOICD
     87 S:$D(^PSRX(PSODA,"ICD")) PSOICD=1
     88 I '$G(DFN) S DFN=$$GET1^DIQ(52,PSODA_",",2,"I")
     89 S DATA="^^^^^^^"
     90 F I=1:1:7 D
     91 . I I=1 S $P(DATA,"^",4)=$P(PSOIBQ,"^",I)
     92 . I I=2 S $P(DATA,"^",6)=$P(PSOIBQ,"^",I)
     93 . I I=3 S $P(DATA,"^",2)=$P(PSOIBQ,"^",I)
     94 . I I=4 S $P(DATA,"^",3)=$P(PSOIBQ,"^",I)
     95 . I I=5 S $P(DATA,"^",5)=$P(PSOIBQ,"^",I)
     96 . I I=6 S $P(DATA,"^",7)=$P(PSOIBQ,"^",I)
     97 . I I=7 S $P(DATA,"^",8)=$P(PSOIBQ,"^",I)
     98 ;
     99 I $G(PSOICD) S I=0 F  S I=$O(^PSRX(PSODA,"ICD",I)) Q:I=""!(I'?1N.NN)  D
     100 . Q:'$D(^PSRX(PSODA,"ICD",I,0))
     101 . S $P(^PSRX(PSODA,"ICD",I,0),"^",2,8)=$P(DATA,"^",2,8)
     102 ; for pre-cidc RX
     103 I '$G(PSOICD) S ^PSRX(PSODA,"ICD",1,0)="^"_$P(DATA,"^",2,8),^PSRX(PSODA,"ICD",0)="^52.052311P^1^1"
     104 Q
     105 ;
     106SCP ;Called from multiple routines - DFN or PSODFN variable must be available to call this subroutine.
     107 I '$G(DFN) S DFN=+$G(PSODFN)
     108 D ELIG^VADPT S PSOANSQ("SC>50")="",(PSOSCA,PSOSCP)="",PSOSCP=$P(VAEL(3),U,2)
     109 S:PSOSCP=""&($P(VAEL(3),U)=1) PSOSCP=0
     110 S PSOSCA=$$SC^SDCO22(DFN)
     111 K VAEL
     112 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORX1.m

    r613 r623  
    1 PSORX1  ;BIR/SAB-medication processing driver ; 1/7/07 3:32pm
    2         ;;7.0;OUTPATIENT PHARMACY;**7,22,23,57,62,46,74,71,90,95,115,117,146,139,135,182,195,233,268,208**;DEC 1997;Build 41
    3         ; Modified from FOIA VISTA,
    4         ; Copyright (C) 2007 WorldVistA
    5         ;
    6         ; This program is free software; you can redistribute it and/or modify
    7         ; it under the terms of the GNU General Public License as published by
    8         ; the Free Software Foundation; either version 2 of the License, or
    9         ; (at your option) any later version.
    10         ;
    11         ; This program is distributed in the hope that it will be useful,
    12         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ; GNU General Public License for more details.
    15         ;
    16         ; You should have received a copy of the GNU General Public License
    17         ; along with this program; if not, write to the Free Software
    18         ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    19         ;External reference PDA^PPPPDA1 supported by DBIA 1374
    20         ;External reference ^PS(55 supported by DBIA 2228
    21         ;External reference ^DIC(31 supported by DBIA 658
    22         ;External reference ^DPT(D0,.372 supported by DBIA 1476
    23         ;External reference DISPPRF^DGPFAPI supported by DBIA #4563
    24         ;External reference ^ORRDI1 is supported by DBIA 4659
    25         ;External reference ^XTMP("ORRDI" is supported by DBIA 4660
    26         ;
    27         ;PSO*195 add call to display Patient Record Flag (DISPPRF^DGPFAPI)
    28         ;
    29 START   K PSOQFLG,PSOID,PSOFIN,PSOQUIT,PSODRUG S (PSOBCK,PSOERR)=1 D INIT G:PSORX("QFLG") END
    30         D PT G:$G(PSORX("QFLG")) END D FULL^VALM1 I $G(NOPROC) K NOPROC G NX
    31         ;call to add bingo board data to file 52.11
    32         F SLPPL=0:0 S SLPPL=$O(RXRS(SLPPL)) Q:'SLPPL  D
    33         .I $P($G(^PSRX(SLPPL,"STA")),"^")'=5 K RXRS(SLPPL) Q
    34         .S RXREC=SLPPL D WIND^PSOSUPOE I $G(PBINGRTE) D BBADD^PSOSUPOE S (BINGCRT,BINGRTE)=1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL"
    35         K TM,TM1 I $G(PSORX("PSOL",1))]""!($D(RXRS)) D ^PSORXL K PSORX S PSOPBM1=1
    36         G:$G(NOBG) NX
    37         S TM=$P(^TMP("PSOBB",$J),"^"),TM1=$P(^TMP("PSOBB",$J),"^",2) K ^TMP("PSOBB",$J)
    38         I $G(PSOFROM)="NEW"!($G(PSOFROM)="REFILL")!($G(PSOFROM)="PARTIAL") D:$D(BINGCRT)&($D(BINGRTE)&($D(DISGROUP))) ^PSOBING1 K BINGCRT,BINGRTE,BBRX,BBFLG
    39         I $G(PSOPBM),$G(PSOPBM1) S $P(^PS(55,PSODFN,0),"^",7)=PSOPBM,$P(^(0),"^",8)="A" K PSOPBM,PSOPBM1
    40 NX      I $G(POERR("DEAD"))!$G(PSOQFLG) D EOJ G START
    41         D EOJ G START
    42 END     Q
    43         ;---------------------------------------------------------
    44 INIT    ;
    45         S PSORX("QFLG")=0
    46         D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) S PSORX("QFLG")=1
    47         I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1
    48 INITX   Q
    49         ;
    50 PT      ;
    51         K ^TMP("PSORXDC",$J),CLOZPAT,DIC,PSODFN,PSOPBM,PSOPBM1 S PSORX("QFLG")=0,DIC=2,DIC(0)="QEAM" D ^DIC K DIC,DA
    52         I +Y'>0 S PSORX("QFLG")=1 G PTX
    53 OERR    N:$G(MEDP) PAT,POERR K PSOXFLG S (DFN,PSODFN)=+Y,PSORX("NAME")=$P(Y,"^",2)
    54         K NPPROC,PSOQFLG,DIC,DR,DIQ S DIC=2,DA=PSODFN,DR=.351,DIQ="PSOPTPST" D EN^DIQ1 K DIC,DA,DR,DIQ D DEAD^PSOPTPST I $G(PSOQFLG) S NOPROC=1 Q
    55         ;PSO*195 move SSN write to here and add DISPPRF call
    56         D ^VADPT W !!?10,$C(7),PSORX("NAME") ; correction for VOE
    57         W " ",VA("PID") ; Correction with VOE, VA shouldn't be using SSN here!
    58         S PSONOAL="" D ALLERGY^PSOORUT2 D  I PSONOAL'="" D PAUSE
    59         .I PSONOAL'="" W !,$C(7),"     No Allergy Assessment!"
    60         D REMOTE
    61         N PSOUPDT
    62         S PSOUPDT=1
    63         I XQY0["PSO LMOE FINISH" S PSOUPDT=0
    64         D CHKADDR^PSOBAI(PSODFN,1,PSOUPDT)
    65         D:(XQY0["PSO LMOE FINISH")&('$G(SNGLPAT)) DISPPRF^DGPFAPI(PSODFN)
    66         ;
    67         I $P($G(^PS(55,PSODFN,"LAN")),"^") W !?10,"Patient has another language preference!",! H 3
    68         I $G(^PS(55,"ASTALK",PSODFN)) W !,"Patient is enrolled to receive ScripTalk 'talking' prescription labels.",! H 2 D MAIL
    69         D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) S ^TMP("PSOBB",$J)=TM_"^"_TM1
    70         I '$G(MEDP) S X="PPPPDA1" X ^%ZOSF("TEST") S:$T X=$$PDA^PPPPDA1(PSODFN)
    71         S PSOQFLG=0,DIC="^PS(55,",DLAYGO=55
    72         K PSOPBM ; KILL SO THAT WON'T CARRY OVER PRIOR PATIENT'S VALUE
    73         I '$D(^PS(55,PSODFN,0)) D
    74         .S PSOPBM=$P(TM,".")
    75         .K DD,DO S DIC(0)="L",(DINUM,X)=PSODFN D FILE^DICN D:Y<1  K DIC,DA,DR,DD,DO
    76         ..S $P(^PS(55,PSODFN,0),"^")=PSODFN K DIK S DA=PSODFN,DIK="^PS(55,",DIK(1)=.01 D EN^DIK K DIK
    77         D RXSTA
    78         S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD
    79         I $G(^PS(55,PSODFN,"PS"))']"" D  I $G(POERR("QFLG")) G EOJ
    80         .L +^PS(55,PSODFN):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W $C(7),!!,"Patient Data is Being Edited by Another User!",! S POERR("QFLG")=1 S:$G(PSOFIN) PSOQUIT=1 Q
    81         .S PSOXFLG=1,SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")",! K SSN
    82         .S DIE=55,DR=".02;.03;.04;.05;1;D ELIG^PSORX1;3;50;106;106.1",DA=PSODFN W !!,?5,">>PHARMACY PATIENT DATA<<",! D ^DIE L -^PS(55,PSODFN)
    83         S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^")
    84         I $G(^PS(55,PSODFN,"PS"))']"" D  I $G(POERR("QFLG")) G EOJ
    85         .W !!,"Patient Status Required!!",! D ELIG
    86         .W ! K POERR("QFLG"),DIC,DR,DIE S DIC("A")="RX PATIENT STATUS: ",DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC
    87         .I $D(DIRUT)!(Y=-1) D  Q
    88         ..W $C(7),"Required Data!",! S POERR("QFLG")=1 S:$G(PSOFIN) PSOQUIT=1
    89         ..I $G(PSOPBM) D  K PSOPBM
    90         ...I $O(^PS(55,PSODFN,0))="" S DA=PSODFN,DIK="^PS(55," D ^DIK
    91         .S ^PS(55,PSODFN,"PS")=+Y,PSORX("PATIENT STATUS")=$P(^PS(53,+Y,0),"^")
    92         .K DIRUT,DTOUT,DUOUT,X,Y,DA
    93         Q:$G(PSOFIN)
    94         I '$G(PSOPBM),'$P(^PS(55,PSODFN,0),"^",7),$P(^(0),"^",8)']"" S PSOPBM=$P(TM,".")
    95         D ^PSOBUILD
    96         F PT="GET","DEAD","INP","CNH","TPB","ADDRESS","COPAY" S RTN=PT_"^PSOPTPST" D @RTN Q:$G(POERR("DEAD"))!($G(PSOQFLG))
    97         I $G(POERR("DEAD")) S POERR("QFLG")=1 F II=0:0 S II=$O(^PS(52.41,"P",PSODFN,II)) D:$P($G(^PS(52.41,II,0)),"^",3)'="DC"&($P($G(^(0)),"^",3)'="DE") DC^PSOORFI2
    98         K PSOERR("DEAD"),II I $G(PSOQFLG) S POERR("QFLG")=1 G EOJ Q
    99         S (PAT,PSOXXDFN)=PSODFN,POERR=1 D ^PSOORUT2,BLD^PSOORUT1,EN^PSOLMUTL
    100         D CLEAR^VALM1 G:$G(PSOQUIT) PTX D EN^PSOLMAO
    101         S (DFN,PSODFN)=PSOXXDFN K DIE,DIC,DLAYGO,DR,DA,PSOX,PSORXED
    102 PTX     ;
    103         K X,Y,^TMP("PS",$J),C,DEA,PRC,PSCNT,PSOACT,PSOCLC,PSOCS,PSOCT,PSOFINFL,PSOHD,PSOLST,PSOOPT,PSOPF,PSOX,PSOX1,PSOXXDFN,SIGOK,STP,STR
    104         Q
    105 EOJ     ;
    106         K PSOERR,PSOMED,PSORX,PSOSD,PSODRUG,PSODFN,PSOOPT,PSOBILL,PSOIBQS,PSOCPAY,PSOPF,PSOPI,COMM,DGI,DGS,PT,PTDY,PTRF,RN,RTN,SERS,ST0,STAT,DFN,STOP,SLPPL,RXREC,PSOPBM
    107         K:'$G(MEDP) PSOQFLG
    108         D KVA^VADPT,FULL^VALM1 K PSOLST,PSOXFLG,PSCNT,PSDIS,PSOAL,P1,LOG,%,%DT,%I,D0,DAT,DFN,DRG,ORX,PSON,PSOPTPST,PSORX,PTST,PSOBCK,PSOID,PSOBXPUL
    109         K INCOM,SIG,SG,STP,RX0,RXN,RX2,RX3,RTS,C,DEAD,PS,PSOCLC,PSOCNT,PSOCT,PSODA,PSOFROM,PSOHD,R3,REA,RF,RFD,RFM,RLD,RXNUM,RXP,RXPR,RXRP,RXRS,STR,POERR,VALMSG
    110         K ^TMP("PSORXDC",$J),^TMP("PSOAL",$J),^TMP("PSOAO",$J),^TMP("PSOSF",$J),^TMP("PSOPF",$J),^TMP("PSOPI",$J),^TMP("PSOPO",$J),^TMP("PSOHDR",$J) I '$G(MEDP),'$G(PSOQUIT) K PAT
    111         K PSORX,RFN,PSOXXDFN,VALM,VALMKEY,PSOBCK,SPOERR,PSOFLAG,VALMBCK,D,GMRA,GMRAL,GMRAREC,PSOSTA,PSODT,RXFL,NOBG,BBRX,BBFLG
    112         Q
    113 ELIG    ; shows eligibility and disabilities
    114         D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):"     SC%: "_$P(VAEL(3),"^",2),1:"") S N=0 F  S N=$O(VAEL(1,N)) Q:'N  W !,?10,$P(VAEL(1,N),"^",2)
    115         W !,"Disabilities: " F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I  S I1=$S($D(^DPT(DFN,.372,I,0)):^(0),1:"") D:+I1
    116         .S PSDIS=$S($P($G(^DIC(31,+I1,0)),"^")]""&($P($G(^(0)),"^",4)']""):$P(^(0),"^"),$P($G(^DIC(31,+I1,0)),"^",4)]"":$P(^(0),"^",4),1:""),PSCNT=$P(I1,"^",2)
    117         .W:$L(PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), ")>80 !,?15
    118         .W $S($G(PSDIS)]"":PSDIS_"-",1:"")_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), "
    119         K N
    120         Q
    121 PROFILE ;
    122         S (PSORX("REFILL"),PSORX("RENEW"))=0,PSOX="" D ^PSOBUILD
    123         I '$G(PSOSD) W !,"This patient has no prescriptions" S:'$D(DFN) DFN=PSODFN D GMRA^PSODEM G PROFILEX
    124         S (PSODRG,PSOX)="" F  S PSODRG=$O(PSOSD(PSODRG)) Q:PSODRG=""  F  S PSOX=$O(PSOSD(PSODRG,PSOX)) Q:PSOX=""  S:$P(PSOSD(PSODRG,PSOX),"^",3)="" PSORX("RENEW")=1 S:$P(PSOSD(PSODRG,PSOX),"^",4)="" PSORX("REFILL")=1
    125         K PSOX
    126 PROFILEX        Q
    127         ;
    128 MAIL    ; MAKE SURE MAIL STATUS IS COMPATIBLE WITH SCRIPTALK PATIENT
    129         I $P($G(^PS(59,PSOSITE,"STALK")),"^")="" Q  ; NO SCRIPTALK PRINTER SET UP FOR THIS DIVISION
    130         N MAIL
    131         S MAIL=$G(^PS(55,PSODFN,0)) I $P(MAIL,"^",3)>1 Q
    132 MAILP   W !!,"REMINDER: CMOP does not fill ScripTalk prescriptions.Please select mail"
    133         W !,"status:  2 (DO NOT MAIL), 3 (LOCAL REGULAR MAIL) or 4 (LOCAL CERTFIED MAIL)."
    134         R !,"MAIL: ",MAIL:120
    135         I MAIL?1"^".E Q
    136         I MAIL<2!(MAIL>4) W !,"INVALID MAIL SETTING - ENTER 2,3, OR 4" G MAILP
    137         W "  ",$S(MAIL=2:"DO NOT MAIL",MAIL=3:"LOCAL REGULAR MAIL",1:"LOCAL CERTIFIED MAIL")
    138         S $P(^PS(55,PSODFN,0),"^",3)=MAIL
    139         Q
    140 REMOTE  ;
    141         I $T(HAVEHDR^ORRDI1)']"" Q
    142         I '$$HAVEHDR^ORRDI1 Q
    143         I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) W !,"Remote data not available - Only local order checks processed." D  Q
    144         .K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W ! K DIR
    145         Q
    146 PAUSE   ;
    147         W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
    148         Q
    149         ;
    150 RXSTA   ; DISPLAY ELIGIBILITY & PROMPT FOR RX PATIENT STATUS
    151         N DA,PSOSTA
    152         I '$G(PSODFN) Q
    153         S DA=PSODFN,PSOSTA=$G(^PS(55,PSODFN,"PS"))
    154         I XQY0["PSO LMOE FINISH"!(XQY0["PSO LM BACKDOOR ORDERS") I PSOSTA]"" D
    155         .D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):"     SC%: "_$P(VAEL(3),"^",2),1:"")
    156         .S N=0 F  S N=$O(VAEL(1,N)) Q:'N  W !,?10,$P(VAEL(1,N),"^",2)
    157         .S DIC("A")="RX PATIENT STATUS: ",DIC("B")=PSOSTA,DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC
    158         .I +Y>0,+Y'=PSOSTA S DIE="^PS(55,",DR="3////"_+Y D ^DIE
    159         Q
     1PSORX1 ;BIR/SAB-medication processing driver ; 1/7/07 3:32pm
     2 ;;7.0;OUTPATIENT PHARMACY;**7,22,23,57,62,46,74,71,90,95,115,117,146,139,135,182,195,233,268,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 ;External reference PDA^PPPPDA1 supported by DBIA 1374
     20 ;External reference ^PS(55 supported by DBIA 2228
     21 ;External reference ^DIC(31 supported by DBIA 658
     22 ;External reference ^DPT(D0,.372 supported by DBIA 1476
     23 ;External reference DISPPRF^DGPFAPI supported by DBIA #4563
     24 ;External reference ^ORRDI1 is supported by DBIA 4659
     25 ;External reference ^XTMP("ORRDI" is supported by DBIA 4660
     26 ;
     27 ;PSO*195 add call to display Patient Record Flag (DISPPRF^DGPFAPI)
     28 ;
     29START K PSOQFLG,PSOID,PSOFIN,PSOQUIT,PSODRUG S (PSOBCK,PSOERR)=1 D INIT G:PSORX("QFLG") END
     30 D PT G:$G(PSORX("QFLG")) END D FULL^VALM1 I $G(NOPROC) K NOPROC G NX
     31 ;call to add bingo board data to file 52.11
     32 F SLPPL=0:0 S SLPPL=$O(RXRS(SLPPL)) Q:'SLPPL  D
     33 .I $P($G(^PSRX(SLPPL,"STA")),"^")'=5 K RXRS(SLPPL) Q
     34 .S RXREC=SLPPL D WIND^PSOSUPOE I $G(PBINGRTE) D BBADD^PSOSUPOE S (BINGCRT,BINGRTE)=1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL"
     35 K TM,TM1 I $G(PSORX("PSOL",1))]""!($D(RXRS)) D ^PSORXL K PSORX S PSOPBM1=1
     36 G:$G(NOBG) NX
     37 S TM=$P(^TMP("PSOBB",$J),"^"),TM1=$P(^TMP("PSOBB",$J),"^",2) K ^TMP("PSOBB",$J)
     38 I $G(PSOFROM)="NEW"!($G(PSOFROM)="REFILL")!($G(PSOFROM)="PARTIAL") D:$D(BINGCRT)&($D(BINGRTE)&($D(DISGROUP))) ^PSOBING1 K BINGCRT,BINGRTE,BBRX,BBFLG
     39 I $G(PSOPBM),$G(PSOPBM1) S $P(^PS(55,PSODFN,0),"^",7)=PSOPBM,$P(^(0),"^",8)="A" K PSOPBM,PSOPBM1
     40NX I $G(POERR("DEAD"))!$G(PSOQFLG) D EOJ G START
     41 D EOJ G START
     42END Q
     43 ;---------------------------------------------------------
     44INIT ;
     45 S PSORX("QFLG")=0
     46 D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) S PSORX("QFLG")=1
     47 I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1
     48INITX Q
     49 ;
     50PT ;
     51 K ^TMP("PSORXDC",$J),CLOZPAT,DIC,PSODFN,PSOPBM,PSOPBM1 S PSORX("QFLG")=0,DIC=2,DIC(0)="QEAM" D ^DIC K DIC,DA
     52 I +Y'>0 S PSORX("QFLG")=1 G PTX
     53OERR N:$G(MEDP) PAT,POERR K PSOXFLG S (DFN,PSODFN)=+Y,PSORX("NAME")=$P(Y,"^",2)
     54 K NPPROC,PSOQFLG,DIC,DR,DIQ S DIC=2,DA=PSODFN,DR=.351,DIQ="PSOPTPST" D EN^DIQ1 K DIC,DA,DR,DIQ D DEAD^PSOPTPST I $G(PSOQFLG) S NOPROC=1 Q
     55 ;PSO*195 move SSN write to here and add DISPPRF call
     56 D ^VADPT W !!?10,$C(7),PSORX("NAME") ; correction for VOE
     57 W " ",VA("PID") ; Correction with VOE, VA shouldn't be using SSN here!
     58 S PSONOAL="" D ALLERGY^PSOORUT2 D  I PSONOAL'="" D PAUSE
     59 .I PSONOAL'="" W !,$C(7),"     No Allergy Assessment!"
     60 D REMOTE
     61 N PSOUPDT
     62 S PSOUPDT=1
     63 I XQY0["PSO LMOE FINISH" S PSOUPDT=0
     64 D CHKADDR^PSOBAI(PSODFN,1,PSOUPDT)
     65 D:(XQY0["PSO LMOE FINISH")&('$G(SNGLPAT)) DISPPRF^DGPFAPI(PSODFN)
     66 ;
     67 I $P($G(^PS(55,PSODFN,"LAN")),"^") W !?10,"Patient has another language preference!",! H 3
     68 I $G(^PS(55,"ASTALK",PSODFN)) W !,"Patient is enrolled to receive ScripTalk 'talking' prescription labels.",! H 2 D MAIL
     69 D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) S ^TMP("PSOBB",$J)=TM_"^"_TM1
     70 I '$G(MEDP) S X="PPPPDA1" X ^%ZOSF("TEST") S:$T X=$$PDA^PPPPDA1(PSODFN)
     71 S PSOQFLG=0,DIC="^PS(55,",DLAYGO=55
     72 K PSOPBM ; KILL SO THAT WON'T CARRY OVER PRIOR PATIENT'S VALUE
     73 I '$D(^PS(55,PSODFN,0)) D
     74 .S PSOPBM=$P(TM,".")
     75 .K DD,DO S DIC(0)="L",(DINUM,X)=PSODFN D FILE^DICN D:Y<1  K DIC,DA,DR,DD,DO
     76 ..S $P(^PS(55,PSODFN,0),"^")=PSODFN K DIK S DA=PSODFN,DIK="^PS(55,",DIK(1)=.01 D EN^DIK K DIK
     77 D RXSTA
     78 S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD
     79 I $G(^PS(55,PSODFN,"PS"))']"" D  I $G(POERR("QFLG")) G EOJ
     80 .L +^PS(55,PSODFN):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W $C(7),!!,"Patient Data is Being Edited by Another User!",! S POERR("QFLG")=1 S:$G(PSOFIN) PSOQUIT=1 Q
     81 .S PSOXFLG=1,SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")",! K SSN
     82 .S DIE=55,DR=".02;.03;.04;.05;1;D ELIG^PSORX1;3;50;106;106.1",DA=PSODFN W !!,?5,">>PHARMACY PATIENT DATA<<",! D ^DIE L -^PS(55,PSODFN)
     83 S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^")
     84 I $G(^PS(55,PSODFN,"PS"))']"" D  I $G(POERR("QFLG")) G EOJ
     85 .W !!,"Patient Status Required!!",! D ELIG
     86 .W ! K POERR("QFLG"),DIC,DR,DIE S DIC("A")="RX PATIENT STATUS: ",DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC
     87 .I $D(DIRUT)!(Y=-1) D  Q
     88 ..W $C(7),"Required Data!",! S POERR("QFLG")=1 S:$G(PSOFIN) PSOQUIT=1
     89 ..I $G(PSOPBM) D  K PSOPBM
     90 ...I $O(^PS(55,PSODFN,0))="" S DA=PSODFN,DIK="^PS(55," D ^DIK
     91 .S ^PS(55,PSODFN,"PS")=+Y,PSORX("PATIENT STATUS")=$P(^PS(53,+Y,0),"^")
     92 .K DIRUT,DTOUT,DUOUT,X,Y,DA
     93 Q:$G(PSOFIN)
     94 I '$G(PSOPBM),'$P(^PS(55,PSODFN,0),"^",7),$P(^(0),"^",8)']"" S PSOPBM=$P(TM,".")
     95 D ^PSOBUILD
     96 F PT="GET","DEAD","INP","CNH","TPB","ADDRESS","COPAY" S RTN=PT_"^PSOPTPST" D @RTN Q:$G(POERR("DEAD"))!($G(PSOQFLG))
     97 I $G(POERR("DEAD")) S POERR("QFLG")=1 F II=0:0 S II=$O(^PS(52.41,"P",PSODFN,II)) D:$P($G(^PS(52.41,II,0)),"^",3)'="DC"&($P($G(^(0)),"^",3)'="DE") DC^PSOORFI2
     98 K PSOERR("DEAD"),II I $G(PSOQFLG) S POERR("QFLG")=1 G EOJ Q
     99 S (PAT,PSOXXDFN)=PSODFN,POERR=1 D ^PSOORUT2,BLD^PSOORUT1,EN^PSOLMUTL
     100 D CLEAR^VALM1 G:$G(PSOQUIT) PTX D EN^PSOLMAO
     101 S (DFN,PSODFN)=PSOXXDFN K DIE,DIC,DLAYGO,DR,DA,PSOX,PSORXED
     102PTX ;
     103 K X,Y,^TMP("PS",$J),C,DEA,PRC,PSCNT,PSOACT,PSOCLC,PSOCS,PSOCT,PSOFINFL,PSOHD,PSOLST,PSOOPT,PSOPF,PSOX,PSOX1,PSOXXDFN,SIGOK,STP,STR
     104 Q
     105EOJ ;
     106 K PSOERR,PSOMED,PSORX,PSOSD,PSODRUG,PSODFN,PSOOPT,PSOBILL,PSOIBQS,PSOCPAY,PSOPF,PSOPI,COMM,DGI,DGS,PT,PTDY,PTRF,RN,RTN,SERS,ST0,STAT,DFN,STOP,SLPPL,RXREC,PSOPBM
     107 K:'$G(MEDP) PSOQFLG
     108 D KVA^VADPT,FULL^VALM1 K PSOLST,PSOXFLG,PSCNT,PSDIS,PSOAL,P1,LOG,%,%DT,%I,D0,DAT,DFN,DRG,ORX,PSON,PSOPTPST,PSORX,PTST,PSOBCK,PSOID,PSOBXPUL
     109 K INCOM,SIG,SG,STP,RX0,RXN,RX2,RX3,RTS,C,DEAD,PS,PSOCLC,PSOCNT,PSOCT,PSODA,PSOFROM,PSOHD,R3,REA,RF,RFD,RFM,RLD,RXNUM,RXP,RXPR,RXRP,RXRS,STR,POERR,VALMSG
     110 K ^TMP("PSORXDC",$J),^TMP("PSOAL",$J),^TMP("PSOAO",$J),^TMP("PSOSF",$J),^TMP("PSOPF",$J),^TMP("PSOPI",$J),^TMP("PSOPO",$J),^TMP("PSOHDR",$J) I '$G(MEDP),'$G(PSOQUIT) K PAT
     111 K PSORX,RFN,PSOXXDFN,VALM,VALMKEY,PSOBCK,SPOERR,PSOFLAG,VALMBCK,D,GMRA,GMRAL,GMRAREC,PSOSTA,PSODT,RXFL,NOBG,BBRX,BBFLG
     112 Q
     113ELIG ; shows eligibility and disabilities
     114 D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):"     SC%: "_$P(VAEL(3),"^",2),1:"") S N=0 F  S N=$O(VAEL(1,N)) Q:'N  W !,?10,$P(VAEL(1,N),"^",2)
     115 W !,"Disabilities: " F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I  S I1=$S($D(^DPT(DFN,.372,I,0)):^(0),1:"") D:+I1
     116 .S PSDIS=$S($P($G(^DIC(31,+I1,0)),"^")]""&($P($G(^(0)),"^",4)']""):$P(^(0),"^"),$P($G(^DIC(31,+I1,0)),"^",4)]"":$P(^(0),"^",4),1:""),PSCNT=$P(I1,"^",2)
     117 .W:$L(PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), ")>80 !,?15
     118 .W $S($G(PSDIS)]"":PSDIS_"-",1:"")_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), "
     119 K N
     120 Q
     121PROFILE ;
     122 S (PSORX("REFILL"),PSORX("RENEW"))=0,PSOX="" D ^PSOBUILD
     123 I '$G(PSOSD) W !,"This patient has no prescriptions" S:'$D(DFN) DFN=PSODFN D GMRA^PSODEM G PROFILEX
     124 S (PSODRG,PSOX)="" F  S PSODRG=$O(PSOSD(PSODRG)) Q:PSODRG=""  F  S PSOX=$O(PSOSD(PSODRG,PSOX)) Q:PSOX=""  S:$P(PSOSD(PSODRG,PSOX),"^",3)="" PSORX("RENEW")=1 S:$P(PSOSD(PSODRG,PSOX),"^",4)="" PSORX("REFILL")=1
     125 K PSOX
     126PROFILEX Q
     127 ;
     128MAIL ; MAKE SURE MAIL STATUS IS COMPATIBLE WITH SCRIPTALK PATIENT
     129 I $P($G(^PS(59,PSOSITE,"STALK")),"^")="" Q  ; NO SCRIPTALK PRINTER SET UP FOR THIS DIVISION
     130 N MAIL
     131 S MAIL=$G(^PS(55,PSODFN,0)) I $P(MAIL,"^",3)>1 Q
     132MAILP W !!,"REMINDER: CMOP does not fill ScripTalk prescriptions.Please select mail"
     133 W !,"status:  2 (DO NOT MAIL), 3 (LOCAL REGULAR MAIL) or 4 (LOCAL CERTFIED MAIL)."
     134 R !,"MAIL: ",MAIL:120
     135 I MAIL?1"^".E Q
     136 I MAIL<2!(MAIL>4) W !,"INVALID MAIL SETTING - ENTER 2,3, OR 4" G MAILP
     137 W "  ",$S(MAIL=2:"DO NOT MAIL",MAIL=3:"LOCAL REGULAR MAIL",1:"LOCAL CERTIFIED MAIL")
     138 S $P(^PS(55,PSODFN,0),"^",3)=MAIL
     139 Q
     140REMOTE ;
     141 I $T(HAVEHDR^ORRDI1)']"" Q
     142 I '$$HAVEHDR^ORRDI1 Q
     143 I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) W !,"Remote data not available - Only local order checks processed." D  Q
     144 .K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W ! K DIR
     145 Q
     146PAUSE ;
     147 W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
     148 Q
     149 ;
     150RXSTA ; DISPLAY ELIGIBILITY & PROMPT FOR RX PATIENT STATUS
     151 N DA,PSOSTA
     152 I '$G(PSODFN) Q
     153 S DA=PSODFN,PSOSTA=$G(^PS(55,PSODFN,"PS"))
     154 I XQY0["PSO LMOE FINISH"!(XQY0["PSO LM BACKDOOR ORDERS") I PSOSTA]"" D
     155 .D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):"     SC%: "_$P(VAEL(3),"^",2),1:"")
     156 .S N=0 F  S N=$O(VAEL(1,N)) Q:'N  W !,?10,$P(VAEL(1,N),"^",2)
     157 .S DIC("A")="RX PATIENT STATUS: ",DIC("B")=PSOSTA,DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC
     158 .I +Y>0,+Y'=PSOSTA S DIE="^PS(55,",DR="3////"_+Y D ^DIE
     159 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXDL.m

    r613 r623  
    1 PSORXDL ;BIR/SAB - Deletes one prescription ;06/10/96
    2         ;;7.0;OUTPATIENT PHARMACY;**4,17,9,27,117,131,148,201,291**;DEC 1997;Build 2
    3         ;External reference to ^PS(55 supported by DBIA 2228
    4         ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
    5         ;External reference to ^PS(59.7 supported by DBIA 694
    6         ;External reference to ^PSDRUG( supported by DBIA 221
    7         I '$D(^XUSEC("PSORPH",DUZ)) W !,$C(7),"Requires Pharmacy Key (PSORPH) !" Q
    8         I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"SITE PARAMETERS MUST BE DEFINED!",! Q
    9         K DA,PSODEFLG,PSOHLRE,PSOHLDAH,QTY,PSOABCDA,PSOREF
    10         S (PSDEL,PSOXXDEL)=1,PS="DELETE",DIC("S")="I $P($G(^(0)),""^"",2),$P($G(^(""STA"")),""^"")'=13,$G(^(2))"
    11         D A1^PSORXVW K DIC("S") I $G(DA)<1 G KILL
    12         D FULL^VALM1
    13         S RXN=+$G(DA)
    14         S PSORXDFN=+$P($G(^PSRX(RXN,0)),"^",2)
    15         S PSOPLCK=$$L^PSSLOCK(PSORXDFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY K PSOPLCK G PSORXDL
    16         K PSOPLCK D PSOL^PSSLOCK(RXN) I '$G(PSOMSG) W !,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),! K PSOMSG D ULP G PSORXDL
    17         S (REL,PSOGGFL)=0 F PSOGG=0:0 S PSOGG=$O(^PSRX(DA,1,PSOGG)) Q:'PSOGG  S:$D(^PSRX(DA,1,PSOGG,0)) PSOGGFL=PSOGG
    18         S REL=$S($G(PSOGGFL)&($P($G(^PSRX(DA,1,+$G(PSOGGFL),0)),"^",18))&('$P($G(^(0)),"^",16)):1,'$G(PSOGGFL)&($P($G(^PSRX(DA,2)),"^",13))&('$P($G(^(2)),"^",15)):1,1:0)
    19         I REL W !!,$S($G(PSOGGFL):"Refill number "_$G(PSOGGFL),1:"The Original Fill")," has already been released for Rx # "_$P($G(^PSRX(DA,0)),"^")
    20         I REL W !,"Drug: ",$P($G(^PSDRUG(+$P($G(^PSRX(DA,0)),"^",6),0)),"^"),?49,$P($G(^DPT(+$P($G(^PSRX(DA,0)),"^",2),0)),"^")
    21         I REL W ! K DIR S DIR(0)="Y",DIR("A")="Return this fill to stock and delete the prescription",DIR("B")="N" D  D ^DIR K DIR G:$G(Y)=1 PASS W !!?5,"No Action Taken.",!  D ULK,ULP,KILL G PSORXDL
    22         .S DIR("?")=" ",DIR("?",1)="Enter 'Y' to return this last fill to stock and continue with the deleting of",DIR("?",2)="this prescription, enter 'N' to exit."
    23         K DIR S DIR(0)="Y",DIR("A",1)="Are you sure you want to DELETE Rx # "_$P(^PSRX(DA,0),"^"),DIR("A",2)="Drug: "_$P(^PSDRUG($P(^PSRX(DA,0),"^",6),0),"^")
    24         S DIR("A")="for "_$P(^DPT($P(^PSRX(DA,0),"^",2),0),"^")
    25         S DIR("B")="NO" D ^DIR D:$D(DTOUT) ULK,ULP G:$D(DTOUT) KILL I $D(DIRUT)!'Y D ULK,ULP,KILL G PSORXDL
    26 PASS    N PSORXDAC K PSOXYZF S PSORXDAC=$O(^PS(52.5,"B",DA,0)) I PSORXDAC,$P($G(^PS(52.5,PSORXDAC,0)),"^",7)="L" N PSOXYZ S PSOXYZF=0 W !!,"Please wait, Rx is Loading for CMOP Transmission.." D
    27         .F PSOXYZ=1:1:5 W "." H 1 I $P($G(^PS(52.5,PSORXDAC,0)),"^",7)'="L" S PSOXYZF=1
    28         I $G(PSOXYZF)=0 W !!,"Sorry, still loading for CMOP transmission, try again later.",! D ULK,ULP,KILL K PSOXYZF G PSORXDL
    29         K PSOXYZF
    30         I $G(REL) S PSOHLRE=REL,PSOHLDAH=$G(DA)
    31         I $G(REL) S RXP=DA S PSODEFLG=0 D RESK I $G(PSODEFLG) D ULK,ULP,KILL G PSORXDL
    32         I $G(PSOHLRE) W !!?5,"Deleting prescription..",! S DA=$G(PSOHLDAH),REL=$G(PSOHLRE)
    33         S PSOABCDA=$G(DA) D NOOR^PSOCAN4 I $D(DIRUT) W " NO ACTION TAKEN!",! D ULK,ULP,KILL G PSORXDL
    34         S DA=$G(PSOABCDA) K DIR,PSOABCDA S DIR("A")="Comments",DIR("B")="Per Pharmacy Request",DIR(0)="F^5:100" D ^DIR K DIR I $D(DIRUT) W !!?5,"NO ACTION TAKEN!",! D ULK,ULP G KILL
    35         I $G(PKI1) N INCOM S INCOM=Y D DCV^PSOPKIV1,ULK,ULP G PSORXDL
    36 ENQ     S PSOIB=$S($D(^PSRX(DA,"IB")):^PSRX(DA,"IB"),1:0) ;Check if copay
    37         S RX=^PSRX(DA,0),RXN=DA
    38         S $P(^PSRX(RXN,"STA"),"^")=13,$P(^PSRX(RXN,"D"),"^")=$G(Y)
    39         S DA=RXN K ^PSRX("ACP",$P(^PSRX(DA,0),"^",2),+$P(^(2),"^",2),0,DA) D ACT
    40         S DA=RXN I $G(^PSRX(DA,"H"))]"" K ^PSRX("AH",+$P(^PSRX(DA,"H"),"^"),DA) S ^PSRX(DA,"H")=""
    41         D EN^PSOHLSN1(DA,"OC","",$P(^PSRX(DA,"D"),"^"),PSONOOR)
    42         S DA=$O(^PS(52.5,"B",RXN,0)) I DA S DIK="^PS(52.5," D ^DIK
    43         S DA=RXN I $D(^PS(52.4,RXN)) S DIK="^PS(52.4," D ^DIK
    44         K PSOABCDA I $G(DA) S PSOABCDA=$G(DA)
    45         I $O(^PS(52.41,"ARF",RXN,0)) S DA=$O(^PS(52.41,"ARF",RXN,0)),DIK="^PS(52.41," D ^DIK K DA,DIK
    46         I $G(PSOABCDA) S DA=$G(PSOABCDA)
    47         I $G(PSOABCDA) S DA=$G(PSOABCDA) K PSOABCDA
    48         Q:+$G(PSORX("INTERVENE"))!($G(PSVFLAG))  I $D(DA),'$G(PSOZVER) D ULK,ULP G PSORXDL
    49         S ^PSDRUG(+$P(RX,"^",6),660.1)=$S($D(^PSDRUG(+$P(RX,"^",6),660.1)):^(660.1),1:0)+$P(RX,"^",7)
    50         S DFN=+$P(RX,"^",2) F I=0:0 S I=$O(^PS(55,DFN,"P",I)) Q:'I  I +^(I,0)=RXN K ^(0) S ^(0)=$P(^PS(55,DFN,"P",0),"^",1,3)_"^"_($P(^(0),"^",4)-1)
    51         F I=0:0 S I=$O(^PS(55,DFN,"P","A",I)) Q:'I  I $D(^(I,RXN)) K ^(RXN)
    52         K STAT,COM,RX,RXN Q:+$G(PSORX("INTERVENE"))!($G(PSVFLAG))  I $G(PSDEL) D ULK,ULP G PSORXDL
    53         ;
    54 KILL    K PSORXDFN,PSOMSG,PSOPLCK,RXO,RX0,RX2,RESK,PSIN,PSODEF,PSOPCECT,PSDEL,I,II,J,N,PHYS,PS,RFDATE,RFL,RFL1,ST,ST0,%,%Y,D0,DA,DI,DIC,DIE,DIH,DIU,DIV,DR,Z,DIG,X,Y,PSOIB,RX,RXN,PSODEFLG,PSOREF,PSOHLRE,PSOHLDAH,PSOGG,PSODLCOM,COPAYFLG
    55         K DIR,RXP,DIRUT,DUOUT,DTOUT,SIGOK,REL,PSONODF,PSONOOR,PSOGGFL,PSOXYZF,TYPE,XTYPE,QDRUG,QTY,PSOWHERE,PSOLOCRL,PSOCPRX,PSODT,PSODA,PSOINVTX,IFN,PSROF,PSOABCDA,PSOXXDEL,PSOPFS
    56         Q
    57 ACT     ;adds activity info for deleted rx
    58         S (RXF,PSOREF)=0 F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I  S (RXF,PSOREF)=I S:I>5 RXF=I+1 K ^PSRX("ACP",$P(^PSRX(RXN,0),"^",2),$P(^PSRX(RXN,1,I,0),"^"),I,RXN)
    59         S DA=0 F FDA=0:0 S FDA=$O(^PSRX(RXN,"A",FDA)) Q:'FDA  S DA=FDA
    60         D NOW^%DTC S DA=DA+1,^PSRX(RXN,"A",0)="^52.3DA^"_DA_"^"_DA,^PSRX(RXN,"A",DA,0)=%_"^"_"D"_"^"_DUZ_"^"_RXF_"^"_"RX DELETED on "_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)
    61 EX      W !,"...PRESCRIPTION #"_$P(RX,"^")_" MARKED DELETED!!"
    62         K RXF,I,FDA,DIC,DIE,%,%I,%H S DA=RXN
    63         ; - Sending Refill to ECME for claim REVERSAL (Rx Delete)
    64         D REVERSE^PSOBPSU1(RXN,PSOREF,"DE",5,,1)
    65         Q
    66 RESK    ;
    67         S RESK=1,PSIN=+$P(^PS(59.7,1,49.99),"^",2) K PSODEF S PSOPCECT=1
    68         S PSOLOUD=1 D:$P($G(^PS(55,+$P(^PSRX(RXP,0),"^",2),0)),"^",6)'=2 EN^PSOHLUP($P(^PSRX(RXP,0),"^",2)) K PSOLOUD
    69         I $S('+$P($G(^PSRX(+RXP,"STA")),"^"):0,$P(^("STA"),"^")=11:0,$P(^("STA"),"^")=12:0,$P(^("STA"),"^")=14:0,$P(^("STA"),"^")=15:0,1:1) D STAT^PSORESK1 S PSODEFLG=1 Q
    70         W !!?5,"Returning Medication to Stock..",!
    71         K DIR,PSODLCOM,COM S DIR(0)="F^10:75",DIR("A")="Comments",DIR("?")="Comments are required, 10-75 characters." W ! D ^DIR K DIR S (COM,PSODLCOM)=Y I Y["^"!($D(DIRUT)) W !!,"No Action Taken!",! S PSODEFLG=1 Q
    72         S QDRUG=+$P($G(^PSRX(RXP,0)),"^",6),QTY=$P($G(^(0)),"^",7) I $O(^PSRX(RXP,1,0)) G REF
    73         S XTYPE="O" I $P($G(^PSRX(RXP,2)),"^",15) Q
    74         I $P($G(^PSRX(RXP,2)),"^",2)<$G(PSIN) Q
    75         K PSOLOCRL,PSOWHERE S PSOLOCRL=$P($G(^PSRX(RXP,2)),"^",13)
    76         Q:'$G(PSOLOCRL)
    77         S PSOWHERE=$S($D(^PSRX("AR",$G(PSOLOCRL),RXP,0)):1,1:0)
    78         I +$G(^PSRX(RXP,"IB"))!($P($G(^PSRX(RXP,"PFS")),"^",2)) S COPAYFLG=1 N PSOPFS S:$P($G(^PSRX(RXP,"PFS")),"^",2) PSOPFS="1^"_$P(^PSRX(RXP,"PFS"),"^",1,2) D CP^PSORESK1 I '$G(COPAYFLG) S PSODEFLG=1 Q
    79         I $G(^PSDRUG(QDRUG,660.1)),$G(PSOWHERE) D INVT W:$G(PSODEFLG) !!?5,"No Action Taken!",! Q:$G(PSODEFLG)  I $G(PSOINVTX) D INVINC
    80         I $G(^PSDRUG(QDRUG,660.1)),'$G(PSOWHERE) D INVINC
    81         I $G(PSOWHERE) K ^PSRX("AR",$G(PSOLOCRL),RXP,0)
    82         D NOW^%DTC K DIE S DA=RXP,DIE="^PSRX(",DR="31///@;32.1///"_% D ^DIE K DIE
    83         ;D EN^PSOHLSN1(RXP,"ZD")
    84         D ACT^PSORESK1
    85         S DA=$O(^PS(52.5,"B",RXP,0)) I DA K DIK S DIK="^PS(52.5," D ^DIK K DIK
    86         D EN^PSOHLSN1(RXP,"ZD")
    87         W !,"Rx # "_$P($G(^PSRX(RXP,0)),"^")_" Returned to Stock.",!
    88         ; - Sending Rx to ECME for claim REVERSAL (Return to Stock)
    89         D REVERSE^PSOBPSU1(RXP,0,"RS",4,,1)
    90         Q
    91 REF     ;
    92         K TYPE F PSROF=0:0 S PSROF=$O(^PSRX(RXP,1,PSROF)) Q:'PSROF  S:$P($G(^PSRX(RXP,1,PSROF,0)),"^") TYPE=PSROF
    93         I '$G(TYPE) Q
    94         S XTYPE=1
    95         I $P($G(^PSRX(RXP,1,TYPE,0)),"^",16) Q
    96         I '$P($G(^PSRX(RXP,1,TYPE,0)),"^",18) Q
    97         I '$P($G(^PSRX(RXP,1,TYPE,0)),"^",18),$P($G(^(0)),"^")'<PSIN Q
    98         S PSOLOCRL=$P($G(^PSRX(RXP,1,TYPE,0)),"^",18)
    99         Q:'$G(PSOLOCRL)
    100         S PSOWHERE=$S($D(^PSRX("AR",$G(PSOLOCRL),RXP,TYPE)):1,1:0)
    101         S QTY=$P($G(^PSRX(RXP,1,TYPE,0)),"^",4)
    102         I +$G(^PSRX(RXP,"IB"))!($P($G(^PSRX(RXP,1,TYPE,"PFS")),"^",2)) S COPAYFLG=1 N PSOPFS S:$P($G(^PSRX(RXP,1,TYPE,"PFS")),"^",2) PSOPFS="1^"_$P(^PSRX(RXP,1,TYPE,"PFS"),"^",1,2) D CP^PSORESK1 I '$G(COPAYFLG) S PSODEFLG=1 Q
    103         I $G(^PSDRUG(QDRUG,660.1)),$G(PSOWHERE) D INVT W:$G(PSODEFLG) !!?5,"No Action Taken!",! Q:$G(PSODEFLG)  I $G(PSOINVTX) D INVINC
    104         I $G(^PSDRUG(QDRUG,660.1)),'$G(PSOWHERE) D INVINC
    105         I $G(PSOWHERE) K ^PSRX("AR",$G(PSOLOCRL),RXP,TYPE)
    106         D NOW^%DTC K DIE S DA(1)=RXP,DA=TYPE,DIE="^PSRX("_DA(1)_",1,",DR="17////@;.01///@" W ! D ^DIE K DIE
    107         ;D EN^PSOHLSN1(RXP,"ZD")
    108         D ACT^PSORESK1
    109         S DA=$O(^PS(52.5,"B",RXP,0)) I DA K DIK S DIK="^PS(52.5," D ^DIK K DIK
    110         D EN^PSOHLSN1(RXP,"ZD") W !,"Rx # "_$P($G(^PSRX(RXP,0)),"^")_" Refill Returned to Stock.",!
    111         ; - Sending Rx refill to ECME for claim REVERSAL (Return to Stock)
    112         D REVERSE^PSOBPSU1(RXP,TYPE,"RS",4,,1)
    113         Q
    114 INVT    ;
    115         S PSOINVTX=0
    116         K DIR,DIRUT S DIR(0)="Y",DIR("B")="N",DIR("A")="This is a CMOP Rx, do you want to increment the local inventory" D  W ! D ^DIR K DIR S:$D(DIRUT) PSODEFLG=1 Q:$G(PSODEFLG)  I $G(Y)=1 S PSOINVTX=1
    117         .S DIR("?")=" ",DIR("?",1)="Enter 'Y' if you want to increment the local inventory with the Quantity that",DIR("?",2)="has been released at the CMOP"
    118         Q
    119 INVINC  ;
    120         S ^PSDRUG(QDRUG,660.1)=$S($P($G(^PSDRUG(QDRUG,660.1)),"^"):$P($G(^PSDRUG(QDRUG,660.1)),"^"),1:0)+$G(QTY)
    121         Q
    122         ;
    123 ULK     ;
    124         I $G(RXN) D PSOUL^PSSLOCK(RXN)
    125         Q
    126 ULP     ;
    127         D UL^PSSLOCK(+$G(PSORXDFN))
    128         Q
     1PSORXDL ;BIR/SAB - Deletes one prescription ;06/10/96
     2 ;;7.0;OUTPATIENT PHARMACY;**4,17,9,27,117,131,148,201**;DEC 1997
     3 ;External reference to ^PS(55 supported by DBIA 2228
     4 ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
     5 ;External reference to ^PS(59.7 supported by DBIA 694
     6 ;External reference to ^PSDRUG( supported by DBIA 221
     7 I '$D(^XUSEC("PSORPH",DUZ)) W !,$C(7),"Requires Pharmacy Key (PSORPH) !" Q
     8 I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"SITE PARAMETERS MUST BE DEFINED!",! Q
     9 K DA,PSODEFLG,PSOHLRE,PSOHLDAH,QTY,PSOABCDA,PSOREF S (PSDEL,PSOXXDEL)=1,PS="DELETE",DIC("S")="I $P($G(^(0)),""^"",2),$P($G(^(""STA"")),""^"")'=13,$G(^(2))" D A1^PSORXVW K DIC("S") G:'$G(DA) KILL
     10 D FULL^VALM1
     11 S RXN=+$G(DA)
     12 S PSORXDFN=+$P($G(^PSRX(RXN,0)),"^",2)
     13 S PSOPLCK=$$L^PSSLOCK(PSORXDFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY K PSOPLCK G PSORXDL
     14 K PSOPLCK D PSOL^PSSLOCK(RXN) I '$G(PSOMSG) W !,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),! K PSOMSG D ULP G PSORXDL
     15 S (REL,PSOGGFL)=0 F PSOGG=0:0 S PSOGG=$O(^PSRX(DA,1,PSOGG)) Q:'PSOGG  S:$D(^PSRX(DA,1,PSOGG,0)) PSOGGFL=PSOGG
     16 S REL=$S($G(PSOGGFL)&($P($G(^PSRX(DA,1,+$G(PSOGGFL),0)),"^",18))&('$P($G(^(0)),"^",16)):1,'$G(PSOGGFL)&($P($G(^PSRX(DA,2)),"^",13))&('$P($G(^(2)),"^",15)):1,1:0)
     17 I REL W !!,$S($G(PSOGGFL):"Refill number "_$G(PSOGGFL),1:"The Original Fill")," has already been released for Rx # "_$P($G(^PSRX(DA,0)),"^")
     18 I REL W !,"Drug: ",$P($G(^PSDRUG(+$P($G(^PSRX(DA,0)),"^",6),0)),"^"),?49,$P($G(^DPT(+$P($G(^PSRX(DA,0)),"^",2),0)),"^")
     19 I REL W ! K DIR S DIR(0)="Y",DIR("A")="Return this fill to stock and delete the prescription",DIR("B")="N" D  D ^DIR K DIR G:$G(Y)=1 PASS W !!?5,"No Action Taken.",!  D ULK,ULP,KILL G PSORXDL
     20 .S DIR("?")=" ",DIR("?",1)="Enter 'Y' to return this last fill to stock and continue with the deleting of",DIR("?",2)="this prescription, enter 'N' to exit."
     21 K DIR S DIR(0)="Y",DIR("A",1)="Are you sure you want to DELETE Rx # "_$P(^PSRX(DA,0),"^"),DIR("A",2)="Drug: "_$P(^PSDRUG($P(^PSRX(DA,0),"^",6),0),"^")
     22 S DIR("A")="for "_$P(^DPT($P(^PSRX(DA,0),"^",2),0),"^")
     23 S DIR("B")="NO" D ^DIR D:$D(DTOUT) ULK,ULP G:$D(DTOUT) KILL I $D(DIRUT)!'Y D ULK,ULP,KILL G PSORXDL
     24PASS N PSORXDAC K PSOXYZF S PSORXDAC=$O(^PS(52.5,"B",DA,0)) I PSORXDAC,$P($G(^PS(52.5,PSORXDAC,0)),"^",7)="L" N PSOXYZ S PSOXYZF=0 W !!,"Please wait, Rx is Loading for CMOP Transmission.." D
     25 .F PSOXYZ=1:1:5 W "." H 1 I $P($G(^PS(52.5,PSORXDAC,0)),"^",7)'="L" S PSOXYZF=1
     26 I $G(PSOXYZF)=0 W !!,"Sorry, still loading for CMOP transmission, try again later.",! D ULK,ULP,KILL K PSOXYZF G PSORXDL
     27 K PSOXYZF
     28 I $G(REL) S PSOHLRE=REL,PSOHLDAH=$G(DA)
     29 I $G(REL) S RXP=DA S PSODEFLG=0 D RESK I $G(PSODEFLG) D ULK,ULP,KILL G PSORXDL
     30 I $G(PSOHLRE) W !!?5,"Deleting prescription..",! S DA=$G(PSOHLDAH),REL=$G(PSOHLRE)
     31 S PSOABCDA=$G(DA) D NOOR^PSOCAN4 I $D(DIRUT) W " NO ACTION TAKEN!",! D ULK,ULP,KILL G PSORXDL
     32 S DA=$G(PSOABCDA) K DIR,PSOABCDA S DIR("A")="Comments",DIR("B")="Per Pharmacy Request",DIR(0)="F^5:100" D ^DIR K DIR I $D(DIRUT) W !!?5,"NO ACTION TAKEN!",! D ULK,ULP G KILL
     33 I $G(PKI1) N INCOM S INCOM=Y D DCV^PSOPKIV1,ULK,ULP G PSORXDL
     34ENQ S PSOIB=$S($D(^PSRX(DA,"IB")):^PSRX(DA,"IB"),1:0) ;Check if copay
     35 S RX=^PSRX(DA,0),RXN=DA
     36 S $P(^PSRX(RXN,"STA"),"^")=13,$P(^PSRX(RXN,"D"),"^")=$G(Y)
     37 S DA=RXN K ^PSRX("ACP",$P(^PSRX(DA,0),"^",2),+$P(^(2),"^",2),0,DA) D ACT
     38 S DA=RXN I $G(^PSRX(DA,"H"))]"" K ^PSRX("AH",+$P(^PSRX(DA,"H"),"^"),DA) S ^PSRX(DA,"H")=""
     39 D EN^PSOHLSN1(DA,"OC","",$P(^PSRX(DA,"D"),"^"),PSONOOR)
     40 S DA=$O(^PS(52.5,"B",RXN,0)) I DA S DIK="^PS(52.5," D ^DIK
     41 S DA=RXN I $D(^PS(52.4,RXN)) S DIK="^PS(52.4," D ^DIK
     42 K PSOABCDA I $G(DA) S PSOABCDA=$G(DA)
     43 I $O(^PS(52.41,"ARF",RXN,0)) S DA=$O(^PS(52.41,"ARF",RXN,0)),DIK="^PS(52.41," D ^DIK K DA,DIK
     44 I $G(PSOABCDA) S DA=$G(PSOABCDA)
     45 I $G(PSOABCDA) S DA=$G(PSOABCDA) K PSOABCDA
     46 Q:+$G(PSORX("INTERVENE"))!($G(PSVFLAG))  I $D(DA),'$G(PSOZVER) D ULK,ULP G PSORXDL
     47 S ^PSDRUG(+$P(RX,"^",6),660.1)=$S($D(^PSDRUG(+$P(RX,"^",6),660.1)):^(660.1),1:0)+$P(RX,"^",7)
     48 S DFN=+$P(RX,"^",2) F I=0:0 S I=$O(^PS(55,DFN,"P",I)) Q:'I  I +^(I,0)=RXN K ^(0) S ^(0)=$P(^PS(55,DFN,"P",0),"^",1,3)_"^"_($P(^(0),"^",4)-1)
     49 F I=0:0 S I=$O(^PS(55,DFN,"P","A",I)) Q:'I  I $D(^(I,RXN)) K ^(RXN)
     50 K STAT,COM,RX,RXN Q:+$G(PSORX("INTERVENE"))!($G(PSVFLAG))  I $G(PSDEL) D ULK,ULP G PSORXDL
     51 ;
     52KILL K PSORXDFN,PSOMSG,PSOPLCK,RXO,RX0,RX2,RESK,PSIN,PSODEF,PSOPCECT,PSDEL,I,II,J,N,PHYS,PS,RFDATE,RFL,RFL1,ST,ST0,%,%Y,D0,DA,DI,DIC,DIE,DIH,DIU,DIV,DR,Z,DIG,X,Y,PSOIB,RX,RXN,PSODEFLG,PSOREF,PSOHLRE,PSOHLDAH,PSOGG,PSODLCOM,COPAYFLG
     53 K DIR,RXP,DIRUT,DUOUT,DTOUT,SIGOK,REL,PSONODF,PSONOOR,PSOGGFL,PSOXYZF,TYPE,XTYPE,QDRUG,QTY,PSOWHERE,PSOLOCRL,PSOCPRX,PSODT,PSODA,PSOINVTX,IFN,PSROF,PSOABCDA,PSOXXDEL,PSOPFS
     54 Q
     55ACT ;adds activity info for deleted rx
     56 S (RXF,PSOREF)=0 F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I  S (RXF,PSOREF)=I S:I>5 RXF=I+1 K ^PSRX("ACP",$P(^PSRX(RXN,0),"^",2),$P(^PSRX(RXN,1,I,0),"^"),I,RXN)
     57 S DA=0 F FDA=0:0 S FDA=$O(^PSRX(RXN,"A",FDA)) Q:'FDA  S DA=FDA
     58 D NOW^%DTC S DA=DA+1,^PSRX(RXN,"A",0)="^52.3DA^"_DA_"^"_DA,^PSRX(RXN,"A",DA,0)=%_"^"_"D"_"^"_DUZ_"^"_RXF_"^"_"RX DELETED on "_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)
     59EX W !,"...PRESCRIPTION #"_$P(RX,"^")_" MARKED DELETED!!"
     60 K RXF,I,FDA,DIC,DIE,%,%I,%H S DA=RXN
     61 ; - Sending Refill to ECME for claim REVERSAL (Rx Delete)
     62 D REVERSE^PSOBPSU1(RXN,PSOREF,"DE",5,,1)
     63 Q
     64RESK ;
     65 S RESK=1,PSIN=+$P(^PS(59.7,1,49.99),"^",2) K PSODEF S PSOPCECT=1
     66 S PSOLOUD=1 D:$P($G(^PS(55,+$P(^PSRX(RXP,0),"^",2),0)),"^",6)'=2 EN^PSOHLUP($P(^PSRX(RXP,0),"^",2)) K PSOLOUD
     67 I $S('+$P($G(^PSRX(+RXP,"STA")),"^"):0,$P(^("STA"),"^")=11:0,$P(^("STA"),"^")=12:0,$P(^("STA"),"^")=14:0,$P(^("STA"),"^")=15:0,1:1) D STAT^PSORESK1 S PSODEFLG=1 Q
     68 W !!?5,"Returning Medication to Stock..",!
     69 K DIR,PSODLCOM,COM S DIR(0)="F^10:75",DIR("A")="Comments",DIR("?")="Comments are required, 10-75 characters." W ! D ^DIR K DIR S (COM,PSODLCOM)=Y I Y["^"!($D(DIRUT)) W !!,"No Action Taken!",! S PSODEFLG=1 Q
     70 S QDRUG=+$P($G(^PSRX(RXP,0)),"^",6),QTY=$P($G(^(0)),"^",7) I $O(^PSRX(RXP,1,0)) G REF
     71 S XTYPE="O" I $P($G(^PSRX(RXP,2)),"^",15) Q
     72 I $P($G(^PSRX(RXP,2)),"^",2)<$G(PSIN) Q
     73 K PSOLOCRL,PSOWHERE S PSOLOCRL=$P($G(^PSRX(RXP,2)),"^",13)
     74 Q:'$G(PSOLOCRL)
     75 S PSOWHERE=$S($D(^PSRX("AR",$G(PSOLOCRL),RXP,0)):1,1:0)
     76 I +$G(^PSRX(RXP,"IB"))!($P($G(^PSRX(RXP,"PFS")),"^",2)) S COPAYFLG=1 N PSOPFS S:$P($G(^PSRX(RXP,"PFS")),"^",2) PSOPFS="1^"_$P(^PSRX(RXP,"PFS"),"^",1,2) D CP^PSORESK1 I '$G(COPAYFLG) S PSODEFLG=1 Q
     77 I $G(^PSDRUG(QDRUG,660.1)),$G(PSOWHERE) D INVT W:$G(PSODEFLG) !!?5,"No Action Taken!",! Q:$G(PSODEFLG)  I $G(PSOINVTX) D INVINC
     78 I $G(^PSDRUG(QDRUG,660.1)),'$G(PSOWHERE) D INVINC
     79 I $G(PSOWHERE) K ^PSRX("AR",$G(PSOLOCRL),RXP,0)
     80 D NOW^%DTC K DIE S DA=RXP,DIE="^PSRX(",DR="31///@;32.1///"_% D ^DIE K DIE
     81 ;D EN^PSOHLSN1(RXP,"ZD")
     82 D ACT^PSORESK1
     83 S DA=$O(^PS(52.5,"B",RXP,0)) I DA K DIK S DIK="^PS(52.5," D ^DIK K DIK
     84 D EN^PSOHLSN1(RXP,"ZD")
     85 W !,"Rx # "_$P($G(^PSRX(RXP,0)),"^")_" Returned to Stock.",!
     86 ; - Sending Rx to ECME for claim REVERSAL (Return to Stock)
     87 D REVERSE^PSOBPSU1(RXP,0,"RS",4,,1)
     88 Q
     89REF ;
     90 K TYPE F PSROF=0:0 S PSROF=$O(^PSRX(RXP,1,PSROF)) Q:'PSROF  S:$P($G(^PSRX(RXP,1,PSROF,0)),"^") TYPE=PSROF
     91 I '$G(TYPE) Q
     92 S XTYPE=1
     93 I $P($G(^PSRX(RXP,1,TYPE,0)),"^",16) Q
     94 I '$P($G(^PSRX(RXP,1,TYPE,0)),"^",18) Q
     95 I '$P($G(^PSRX(RXP,1,TYPE,0)),"^",18),$P($G(^(0)),"^")'<PSIN Q
     96 S PSOLOCRL=$P($G(^PSRX(RXP,1,TYPE,0)),"^",18)
     97 Q:'$G(PSOLOCRL)
     98 S PSOWHERE=$S($D(^PSRX("AR",$G(PSOLOCRL),RXP,TYPE)):1,1:0)
     99 S QTY=$P($G(^PSRX(RXP,1,TYPE,0)),"^",4)
     100 I +$G(^PSRX(RXP,"IB"))!($P($G(^PSRX(RXP,1,TYPE,"PFS")),"^",2)) S COPAYFLG=1 N PSOPFS S:$P($G(^PSRX(RXP,1,TYPE,"PFS")),"^",2) PSOPFS="1^"_$P(^PSRX(RXP,1,TYPE,"PFS"),"^",1,2) D CP^PSORESK1 I '$G(COPAYFLG) S PSODEFLG=1 Q
     101 I $G(^PSDRUG(QDRUG,660.1)),$G(PSOWHERE) D INVT W:$G(PSODEFLG) !!?5,"No Action Taken!",! Q:$G(PSODEFLG)  I $G(PSOINVTX) D INVINC
     102 I $G(^PSDRUG(QDRUG,660.1)),'$G(PSOWHERE) D INVINC
     103 I $G(PSOWHERE) K ^PSRX("AR",$G(PSOLOCRL),RXP,TYPE)
     104 D NOW^%DTC K DIE S DA(1)=RXP,DA=TYPE,DIE="^PSRX("_DA(1)_",1,",DR="17////@;.01///@" W ! D ^DIE K DIE
     105 ;D EN^PSOHLSN1(RXP,"ZD")
     106 D ACT^PSORESK1
     107 S DA=$O(^PS(52.5,"B",RXP,0)) I DA K DIK S DIK="^PS(52.5," D ^DIK K DIK
     108 D EN^PSOHLSN1(RXP,"ZD") W !,"Rx # "_$P($G(^PSRX(RXP,0)),"^")_" Refill Returned to Stock.",!
     109 ; - Sending Rx refill to ECME for claim REVERSAL (Return to Stock)
     110 D REVERSE^PSOBPSU1(RXP,TYPE,"RS",4,,1)
     111 Q
     112INVT ;
     113 S PSOINVTX=0
     114 K DIR,DIRUT S DIR(0)="Y",DIR("B")="N",DIR("A")="This is a CMOP Rx, do you want to increment the local inventory" D  W ! D ^DIR K DIR S:$D(DIRUT) PSODEFLG=1 Q:$G(PSODEFLG)  I $G(Y)=1 S PSOINVTX=1
     115 .S DIR("?")=" ",DIR("?",1)="Enter 'Y' if you want to increment the local inventory with the Quantity that",DIR("?",2)="has been released at the CMOP"
     116 Q
     117INVINC ;
     118 S ^PSDRUG(QDRUG,660.1)=$S($P($G(^PSDRUG(QDRUG,660.1)),"^"):$P($G(^PSDRUG(QDRUG,660.1)),"^"),1:0)+$G(QTY)
     119 Q
     120 ;
     121ULK ;
     122 I $G(RXN) D PSOUL^PSSLOCK(RXN)
     123 Q
     124ULP ;
     125 D UL^PSSLOCK(+$G(PSORXDFN))
     126 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXED.m

    r613 r623  
    1 PSORXED ;IHS/DSD/JCM-edit rx utility ; 5/18/07 2:53pm
    2         ;;7.0;OUTPATIENT PHARMACY;**2,16,21,26,56,71,125,201,246**;DEC 1997;Build 12
    3         ;External reference to ^PSXEDIT supported by DBIA 2209
    4         ;External reference to ^DD(52 supported by DBIA 999
    5         ;External reference to ^PSDRUG supported by DBIA 221
    6         ;External reference to ^PS(55 supported by DBIA 2228
    7 START   ;this entry point is no longer used.
    8         ;D INIT,LKUP G:PSORXED("QFLG") END D PARSE,EOJ G START
    9 END     D EOJ
    10         Q
    11 INIT    S PSORXED("QFLG")=0 Q
    12 LKUP    ; this line of code is no longer used S PSONUM="RX",PSONUM("A")="EDIT",PSOQFLG=0 D EN1^PSONUM I PSOQFLG!($Q(PSOLIST)']"") S PSORXED("QFLG")=1
    13         K PSOQFLG Q
    14         ;
    15 PARSE   F PSORXED("LIST")=1:1 Q:'$D(PSOLIST(PSORXED("LIST")))!PSORXED("QFLG")  F PSORXED("I")=1:1:$L(PSOLIST(PSORXED("LIST"))) S PSORXED("IRXN")=$P(PSOLIST(PSORXED("LIST")),",",PSORXED("I")) D:+PSORXED("IRXN") PROCESS
    16         Q
    17 PROCESS S PSORXED("DFLG")=0 G:$G(^PSRX(PSORXED("IRXN"),0))']"" PROCESSX
    18         S PSORXED("RX0")=^PSRX(PSORXED("IRXN"),0),PSORXED("RX2")=^(2),PSORXED("RX3")=^(3),PSOSIG=$G(^PSRX(PSORXED("IRXN"),"SIG")),PSODAYS=$P(PSORXED("RX0"),"^",8)
    19         S (I,RFED,RFDT)=0 F  S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'I  S RFED=I,PSORXED("RX1")=^PSRX(PSORXED("IRXN"),1,I,0),RFDT=$P(^(0),"^"),PSODAYS=$P(^(0),"^",10) S:$P(^(0),"^",17) PSONEW("PROVIDER NAME")=$P(^VA(200,$P(^(0),"^",17),0),"^")
    20         S PSORXST=+$P($G(^PS(53,+$P(PSORXED("RX0"),"^",3),0)),"^",7) N DA S DA=PSORXED("IRXN") D EN^PSORXPR
    21         D CHECK G:PSORXED("DFLG") PROCESSX
    22         N X S X="PSXEDIT" X ^%ZOSF("TEST") K X I $T D ^PSXEDIT I $G(PSXOUT) K PSXOUT G L1
    23         D DIE^PSORXED1
    24 L1      D LOG,POST
    25 PROCESSX        Q
    26 CHECK   Q  L +^PSRX(PSORXED("IRXN")):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W $C(7),!!,"Rx Number is Locked by Another User!",! S PSORXED("DFLG")=1 H 5 Q
    27         I $G(^PSDRUG($P(PSORXED("RX0"),"^",6),"I"))]"",^("I")<DT D  G CHECKX
    28         . W !,$C(7),"This drug has been inactivated. ",! S PSORXED("DFLG")=1 Q
    29         K PSPOP I $G(PSODIV),$P(PSORXED("RX2"),"^",9)'=PSOSITE S PSPRXN=PSORXED("IRXN") D CHK1^PSOUTLA I $G(PSPOP)=1 S PSORXED("DFLG")=1 G CHECKX
    30         ;
    31         I $P(^PSRX(PSORXED("IRXN"),"STA"),"^")=14!($P(^("STA"),"^")=15) S PSORXED("DFLG")=1 W !!,$C(7),"Discontinued prescriptions cannot be edited.",! G CHECKX
    32         I $D(^PS(52.4,"B",PSORXED("IRXN"))) S PSORXED("DFLG")=1 W !!,$C(7),"Non-verified prescriptions cannot be edited.",!
    33 CHECKX  K PSPOP,DIR,DTOUT,DUOUT,Y,X Q
    34 LOG     K PSFROM S DA=PSORXED("IRXN"),(PSRX0,RX0)=PSORXED("RX0"),QTY=$P(RX0,"^",7),QTY=QTY-$P(^PSRX(DA,0),"^",7) K ZD(DA) S:'$O(^PSRX(DA,1,0)) ZD(DA)=$P(^PSRX(DA,2),"^",2)
    35         S COM="" F I=3,4,5:1:13,17 I $P(PSRX0,"^",I)'=$P(^PSRX(DA,0),"^",I) S PSI=$S(I=13:1,1:I),COM=COM_$P(^DD(52,PSI,0),"^")_" ("_$P(PSRX0,"^",I)_"),"
    36         I $P(PSORXED("RX2"),"^",2)'=$P(^PSRX(DA,2),"^",2) S COM=COM_$P(^DD(52,22,0),"^")_" ("_$P(PSORXED("RX2"),"^",2)_"),"
    37         I $P(PSORXED("RX3"),"^",7)'=$P(^PSRX(DA,3),"^",7) S COM=COM_$P(^DD(52,12,0),"^")_" ("_$P(PSORXED("RX3"),"^",7)_"),"
    38         I PSOSIG'=$P($G(^PSRX(DA,"SIG")),"^") S COM=COM_$P(^DD(52,10,0),"^")_" ("_PSOSIG_"),"
    39         I PSOTRN'=$G(^PSRX(DA,"TN")) S COM=COM_$P(^DD(52,6.5,0),"^")_" ("_PSOTRN_"),"
    40         G:COM="" LOGX K PSRX0 S X=$S($D(PSOCLC):PSOCLC,1:DUZ)
    41         D FILL,LBL D:$G(PSOEDITL)=2&($P($G(^PSRX(DA,"STA")),"^")'=5)&('$G(RXRP(DA)))&('$G(PSOSIGFL)) ASKL
    42         S K=1,D1=0 F Z=0:0 S Z=$O(^PSRX(DA,"A",Z)) Q:'Z  S D1=Z,K=K+1
    43         S D1=D1+1 S:'($D(^PSRX(DA,"A",0))#2) ^(0)="^52.3DA^^^" S ^(0)=$P(^(0),"^",1,2)_"^"_D1_"^"_K
    44         S ^PSRX(DA,"A",D1,0)=DT_"^E^"_$G(DUZ)_"^0^"_COM
    45         I QTY,$P(^PSRX(DA,2),"^",13) S ^PSDRUG($P(^PSRX(DA,0),"^",6),660.1)=$S($D(^PSDRUG(+$P(^PSRX(DA,0),"^",6),660.1)):^(660.1)+QTY,1:QTY)
    46         S:$P(RX0,"^",6)'=$P(^PSRX(DA,0),"^",6) ^PSDRUG(+$P(^PSRX(DA,0),"^",6),660.1)=$S($D(^PSDRUG(+$P(RX0,"^",6),660.1)):^(660.1)+$P(RX0,"^",7),1:$P(RX0,"^",7))
    47         S RX0=^PSRX(DA,0),RX2=^(2),J=DA,OEXDT=+$P(RX2,"^",6) D ^PSOEXDT S NEXDT=+$P(RX2,"^",6) I OEXDT'=NEXDT D
    48         .K ^PSRX("AG",OEXDT,DA) S ^PSRX("AG",NEXDT,DA)=""
    49         .S D=+$P(RX0,"^",2) K ^PS(55,D,"P","A",OEXDT,DA) S ^PS(55,D,"P","A",NEXDT,DA)=""
    50         K D,OEXDT,NEXDT
    51         G:+$P(^PSRX(J,"STA"),"^")!($G(PSOEDITL)=1) LOGX S RXFL(PSORXED("IRXN"))=$S($G(PSOEDITF):$G(PSOEDITF),1:0) I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSORXED("IRXN")_"," D SETRP G LOGX
    52         G:$G(PSOEDITL)=1 LOGX
    53         F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
    54         I $L(PSORX("PSOL",PSOX2))+$L(PSORXED("IRXN"))<220 D  G LOGX
    55         .I PSORX("PSOL",PSOX2)'[PSORXED("IRXN")_"," S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSORXED("IRXN")_"," D SETRP
    56         E  I $G(PSORX("PSOL",PSOX2+1))'[PSORXED("IRXN")_"," S PSORX("PSOL",PSOX2+1)=PSORXED("IRXN")_"," D SETRP   ;;PSO*7*246
    57 LOGX    K PSOEDITF,PSOEDITR,PSOEDITL D:$G(RFED) ^PSORXED1
    58         Q
    59 POST    ; D NEXT D:$G(^PSRX(PSORXED("IRXN"),"IB"))]"" COPAY K PSODAYS,PSORXST
    60         D NEXT D COPAY K PSODAYS,PSORXST
    61         Q
    62 COPAY   S DA=PSORXED("IRXN") I 'RFD,PSODAYS'=+$P(^PSRX(DA,0),"^",8) I +$G(^PSRX(DA,"IB"))!($P($G(^PSRX(DA,"PFS")),"^",2)) D CPCK G RXST
    63         I RFD,+$G(^PSRX(DA,1,RFD,0)),PSODAYS'=$P($G(^PSRX(DA,1,RFD,0)),"^",10) I +$G(^PSRX(DA,"IB"))!($P($G(^PSRX(DA,1,RFD,"PFS")),"^",2)) D CPCK
    64 RXST    G:PSORXST=+$P($G(^PS(53,+$P(^PSRX(DA,0),"^",3),0)),"^",7) COPAYX
    65         W !,$C(7),"Patient Status field for this Rx has been changed from a ",$S(PSORXST=0:"COPAYMENT ELIGIBLE",PSORXST=1:"COPAYMENT EXEMPT",1:"")
    66         W !,"patient status."
    67         W "  The copay status for this Rx will be automatically adjusted."
    68         W !,"If action needs to be taken to adjust charges you MUST use the"
    69         W !,"Reset Copay Status/Cancel Charges option."
    70         W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
    71         I +$P($G(^PS(53,+$P(^PSRX(DA,0),"^",3),0)),"^",7)=1 D  ; SET TO NO COPAY AND AUDIT CHANGE
    72         . I '$D(^PSRX(DA,"IB")) S ^PSRX(DA,"IB")=""
    73         . S $P(^PSRX(DA,"IB"),"^",1)=""
    74         . S PSODA=DA
    75         . S PSOREF=RFD
    76         . S PSOCOMM="Rx Patient Status Change"
    77         . S PSOOLD="Copay"
    78         . S PSONW="No Copay"
    79         . S PREA="R"
    80         . D ACTLOG^PSOCPA
    81 COPAYX  K DA,PSODAYS,PSO,PSODA,PSOFLAG,PSORXST,RFD,PSOREF,PSOCOMM,PSOOLD,PSONW
    82         Q
    83 CPCK    ;update COPAY
    84         I 'RFD,'$D(^PSRX(DA,"PFS")) G CPCK1
    85         I RFD,'$D(^PSRX(DA,1,RFD,"PFS")) G CPCK1
    86         N PSOPFS S PSOPFS=$P($S('RFD:^PSRX(DA,"PFS"),1:^PSRX(DA,1,RFD,"PFS")),"^",1,2)
    87         I +$G(PSOPFS)>0&('$P($G(PSOPFS),"^",2)) K PSOPFS Q
    88         I +$G(PSOPFS)<1 K PSOPFS
    89         E  S PSOPFS="1^"_PSOPFS
    90 CPCK1   N TYPE S PSO=2,PSODA=DA,PSOFLAG=1,PSOPAR7=$G(^PS(59,PSOSITE,"IB")),TYPE=RFD D RXED^PSOCPA K TYPE
    91         Q
    92 NEXT    D NEXT^PSOUTIL(.PSORXED) K DIE,DR,DA S DIE="^PSRX(",DA=PSORXED("IRXN")
    93         S DR="101///"_$P(PSORXED("RX3"),"^")_";102///"_$P(PSORXED("RX3"),"^",2) D ^DIE K DIE,DR,DA,X,Y
    94         Q
    95 EOJ     K PSOSIG,PSORXED,PSOLIST,END,PSRX0
    96         D EX^PSORXED1
    97         Q
    98 FILL    ;
    99         K PSOEDITF,PSOEDITR,PSOERF
    100         F PSOEZ=0:0 S PSOEZ=$O(^PSRX(DA,1,PSOEZ)) Q:'PSOEZ  S:$D(^PSRX(DA,1,PSOEZ,0)) PSOERF=PSOEZ
    101         S PSOEDITF=$S($G(PSOERF):+$G(PSOERF),1:0)
    102         I PSOEDITF S PSOEDITR=$S($P($G(^PSRX(DA,1,PSOEDITF,0)),"^",18):1,1:0) G FILLX
    103         S PSOEDITR=$S($P($G(^PSRX(DA,2)),"^",13):1,1:0)
    104 FILLX   K PSOERF,PSOEZ
    105         Q
    106 LBL     ;
    107         S PSOEDITL=0
    108         I COM["PROV"!(COM["QTY")!(COM["DAYS")!(COM["MAIL")!(COM["UNIT")!(COM["FILL DATE")!(COM["REMARKS") I COM'["STATUS",COM'["CLINIC",COM'["DRUG",COM'["REFILLS",COM'["ISSUE",COM'["SIG",COM'["TRADE" D  Q
    109         .I $G(PSOEDITF) S PSOEDITL=1 Q
    110         .I '$G(PSOEDITF),$G(PSOEDITR) S PSOEDITL=2
    111         I '$G(PSOEDITF),$G(PSOEDITR) S PSOEDITL=2 Q
    112         I '$G(PSOEDITF),'$G(PSOEDITR) S PSOEDITL=0 Q
    113         I $G(RXRP(DA)) S PSOEDITL=1 Q
    114         I '$G(RXRP(DA)),$G(PSOEDITR) S PSOEDITL=2 Q
    115         S PSOEDITL=0
    116         Q
    117 ASKL    ;
    118         W ! K DIR S DIR("?",1)="You have edited a fill that has already been released. Do you want to",DIR("?",2)="include this prescription as one of the prescriptions to be acted upon",DIR("?",3)="at the label prompt."
    119         S DIR("?")="Enter 'Yes' to generate a reprint label request."
    120         S DIR(0)="Y",DIR("A")="The last fill has been released, do you want a reprint label",DIR("B")="Y" D ^DIR K DIR I Y=1 S PSOEDITL=0 Q
    121         S PSOEDITL=1
    122         Q
    123 SETRP   I $P($G(^PSRX(PSORXED("IRXN"),"STA")),"^")'=5,$G(PSOEDITL)=0 S RXRP(PSORXED("IRXN"))="1^^^1",VALMSG="Label will reprint due to Edit"
    124         Q
     1PSORXED ;IHS/DSD/JCM-edit rx utility ;02/18/98  3:14 PM
     2 ;;7.0;OUTPATIENT PHARMACY;**2,16,21,26,56,71,125,201**;DEC 1997
     3 ;External reference to ^PSXEDIT supported by DBIA 2209
     4 ;External reference to ^DD(52 supported by DBIA 999
     5 ;External reference to ^PSDRUG supported by DBIA 221
     6 ;External reference to ^PS(55 supported by DBIA 2228
     7START ;this entry point is no longer used.
     8 ;D INIT,LKUP G:PSORXED("QFLG") END D PARSE,EOJ G START
     9END D EOJ
     10 Q
     11INIT S PSORXED("QFLG")=0 Q
     12LKUP ; this line of code is no longer used S PSONUM="RX",PSONUM("A")="EDIT",PSOQFLG=0 D EN1^PSONUM I PSOQFLG!($Q(PSOLIST)']"") S PSORXED("QFLG")=1
     13 K PSOQFLG Q
     14 ;
     15PARSE F PSORXED("LIST")=1:1 Q:'$D(PSOLIST(PSORXED("LIST")))!PSORXED("QFLG")  F PSORXED("I")=1:1:$L(PSOLIST(PSORXED("LIST"))) S PSORXED("IRXN")=$P(PSOLIST(PSORXED("LIST")),",",PSORXED("I")) D:+PSORXED("IRXN") PROCESS
     16 Q
     17PROCESS S PSORXED("DFLG")=0 G:$G(^PSRX(PSORXED("IRXN"),0))']"" PROCESSX
     18 S PSORXED("RX0")=^PSRX(PSORXED("IRXN"),0),PSORXED("RX2")=^(2),PSORXED("RX3")=^(3),PSOSIG=$G(^PSRX(PSORXED("IRXN"),"SIG")),PSODAYS=$P(PSORXED("RX0"),"^",8)
     19 S (I,RFED,RFDT)=0 F  S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'I  S RFED=I,PSORXED("RX1")=^PSRX(PSORXED("IRXN"),1,I,0),RFDT=$P(^(0),"^"),PSODAYS=$P(^(0),"^",10) S:$P(^(0),"^",17) PSONEW("PROVIDER NAME")=$P(^VA(200,$P(^(0),"^",17),0),"^")
     20 S PSORXST=+$P($G(^PS(53,+$P(PSORXED("RX0"),"^",3),0)),"^",7) N DA S DA=PSORXED("IRXN") D EN^PSORXPR
     21 D CHECK G:PSORXED("DFLG") PROCESSX
     22 N X S X="PSXEDIT" X ^%ZOSF("TEST") K X I $T D ^PSXEDIT I $G(PSXOUT) K PSXOUT G L1
     23 D DIE^PSORXED1
     24L1 D LOG,POST
     25PROCESSX Q
     26CHECK Q  L +^PSRX(PSORXED("IRXN")):0 I '$T W $C(7),!!,"Rx Number is Locked by Another User!",! S PSORXED("DFLG")=1 H 5 Q
     27 I $G(^PSDRUG($P(PSORXED("RX0"),"^",6),"I"))]"",^("I")<DT D  G CHECKX
     28 . W !,$C(7),"This drug has been inactivated. ",! S PSORXED("DFLG")=1 Q
     29 K PSPOP I $G(PSODIV),$P(PSORXED("RX2"),"^",9)'=PSOSITE S PSPRXN=PSORXED("IRXN") D CHK1^PSOUTLA I $G(PSPOP)=1 S PSORXED("DFLG")=1 G CHECKX
     30 ;
     31 I $P(^PSRX(PSORXED("IRXN"),"STA"),"^")=14!($P(^("STA"),"^")=15) S PSORXED("DFLG")=1 W !!,$C(7),"Discontinued prescriptions cannot be edited.",! G CHECKX
     32 I $D(^PS(52.4,"B",PSORXED("IRXN"))) S PSORXED("DFLG")=1 W !!,$C(7),"Non-verified prescriptions cannot be edited.",!
     33CHECKX K PSPOP,DIR,DTOUT,DUOUT,Y,X Q
     34LOG K PSFROM S DA=PSORXED("IRXN"),(PSRX0,RX0)=PSORXED("RX0"),QTY=$P(RX0,"^",7),QTY=QTY-$P(^PSRX(DA,0),"^",7) K ZD(DA) S:'$O(^PSRX(DA,1,0)) ZD(DA)=$P(^PSRX(DA,2),"^",2)
     35 S COM="" F I=3,4,5:1:13,17 I $P(PSRX0,"^",I)'=$P(^PSRX(DA,0),"^",I) S PSI=$S(I=13:1,1:I),COM=COM_$P(^DD(52,PSI,0),"^")_" ("_$P(PSRX0,"^",I)_"),"
     36 I $P(PSORXED("RX2"),"^",2)'=$P(^PSRX(DA,2),"^",2) S COM=COM_$P(^DD(52,22,0),"^")_" ("_$P(PSORXED("RX2"),"^",2)_"),"
     37 I $P(PSORXED("RX3"),"^",7)'=$P(^PSRX(DA,3),"^",7) S COM=COM_$P(^DD(52,12,0),"^")_" ("_$P(PSORXED("RX3"),"^",7)_"),"
     38 I PSOSIG'=$P($G(^PSRX(DA,"SIG")),"^") S COM=COM_$P(^DD(52,10,0),"^")_" ("_PSOSIG_"),"
     39 I PSOTRN'=$G(^PSRX(DA,"TN")) S COM=COM_$P(^DD(52,6.5,0),"^")_" ("_PSOTRN_"),"
     40 G:COM="" LOGX K PSRX0 S X=$S($D(PSOCLC):PSOCLC,1:DUZ)
     41 D FILL,LBL D:$G(PSOEDITL)=2&($P($G(^PSRX(DA,"STA")),"^")'=5)&('$G(RXRP(DA)))&('$G(PSOSIGFL)) ASKL
     42 S K=1,D1=0 F Z=0:0 S Z=$O(^PSRX(DA,"A",Z)) Q:'Z  S D1=Z,K=K+1
     43 S D1=D1+1 S:'($D(^PSRX(DA,"A",0))#2) ^(0)="^52.3DA^^^" S ^(0)=$P(^(0),"^",1,2)_"^"_D1_"^"_K
     44 S ^PSRX(DA,"A",D1,0)=DT_"^E^"_$G(DUZ)_"^0^"_COM
     45 I QTY,$P(^PSRX(DA,2),"^",13) S ^PSDRUG($P(^PSRX(DA,0),"^",6),660.1)=$S($D(^PSDRUG(+$P(^PSRX(DA,0),"^",6),660.1)):^(660.1)+QTY,1:QTY)
     46 S:$P(RX0,"^",6)'=$P(^PSRX(DA,0),"^",6) ^PSDRUG(+$P(^PSRX(DA,0),"^",6),660.1)=$S($D(^PSDRUG(+$P(RX0,"^",6),660.1)):^(660.1)+$P(RX0,"^",7),1:$P(RX0,"^",7))
     47 S RX0=^PSRX(DA,0),RX2=^(2),J=DA,OEXDT=+$P(RX2,"^",6) D ^PSOEXDT S NEXDT=+$P(RX2,"^",6) I OEXDT'=NEXDT D
     48 .K ^PSRX("AG",OEXDT,DA) S ^PSRX("AG",NEXDT,DA)=""
     49 .S D=+$P(RX0,"^",2) K ^PS(55,D,"P","A",OEXDT,DA) S ^PS(55,D,"P","A",NEXDT,DA)=""
     50 K D,OEXDT,NEXDT
     51 G:+$P(^PSRX(J,"STA"),"^")!($G(PSOEDITL)=1) LOGX S RXFL(PSORXED("IRXN"))=$S($G(PSOEDITF):$G(PSOEDITF),1:0) I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSORXED("IRXN")_"," D SETRP G LOGX
     52 G:$G(PSOEDITL)=1 LOGX
     53 F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
     54 I $L(PSORX("PSOL",PSOX2))+$L(PSORXED("IRXN"))<220 D  G LOGX
     55 .I PSORX("PSOL",PSOX2)'[PSORXED("IRXN")_"," S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSORXED("IRXN")_"," D SETRP
     56 E  I PSORX("PSOL",PSOX2+1)'[PSORXED("IRXN")_"," S PSORX("PSOL",PSOX2+1)=PSORXED("IRXN")_"," D SETRP
     57LOGX K PSOEDITF,PSOEDITR,PSOEDITL D:$G(RFED) ^PSORXED1
     58 Q
     59POST ; D NEXT D:$G(^PSRX(PSORXED("IRXN"),"IB"))]"" COPAY K PSODAYS,PSORXST
     60 D NEXT D COPAY K PSODAYS,PSORXST
     61 Q
     62COPAY S DA=PSORXED("IRXN") I 'RFD,PSODAYS'=+$P(^PSRX(DA,0),"^",8) I +$G(^PSRX(DA,"IB"))!($P($G(^PSRX(DA,"PFS")),"^",2)) D CPCK G RXST
     63 I RFD,+$G(^PSRX(DA,1,RFD,0)),PSODAYS'=$P($G(^PSRX(DA,1,RFD,0)),"^",10) I +$G(^PSRX(DA,"IB"))!($P($G(^PSRX(DA,1,RFD,"PFS")),"^",2)) D CPCK
     64RXST G:PSORXST=+$P($G(^PS(53,+$P(^PSRX(DA,0),"^",3),0)),"^",7) COPAYX
     65 W !,$C(7),"Patient Status field for this Rx has been changed from a ",$S(PSORXST=0:"COPAYMENT ELIGIBLE",PSORXST=1:"COPAYMENT EXEMPT",1:"")
     66 W !,"patient status."
     67 W "  The copay status for this Rx will be automatically adjusted."
     68 W !,"If action needs to be taken to adjust charges you MUST use the"
     69 W !,"Reset Copay Status/Cancel Charges option."
     70 W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
     71 I +$P($G(^PS(53,+$P(^PSRX(DA,0),"^",3),0)),"^",7)=1 D  ; SET TO NO COPAY AND AUDIT CHANGE
     72 . I '$D(^PSRX(DA,"IB")) S ^PSRX(DA,"IB")=""
     73 . S $P(^PSRX(DA,"IB"),"^",1)=""
     74 . S PSODA=DA
     75 . S PSOREF=RFD
     76 . S PSOCOMM="Rx Patient Status Change"
     77 . S PSOOLD="Copay"
     78 . S PSONW="No Copay"
     79 . S PREA="R"
     80 . D ACTLOG^PSOCPA
     81COPAYX K DA,PSODAYS,PSO,PSODA,PSOFLAG,PSORXST,RFD,PSOREF,PSOCOMM,PSOOLD,PSONW
     82 Q
     83CPCK ;update COPAY
     84 I 'RFD,'$D(^PSRX(DA,"PFS")) G CPCK1
     85 I RFD,'$D(^PSRX(DA,1,RFD,"PFS")) G CPCK1
     86 N PSOPFS S PSOPFS=$P($S('RFD:^PSRX(DA,"PFS"),1:^PSRX(DA,1,RFD,"PFS")),"^",1,2)
     87 I +$G(PSOPFS)>0&('$P($G(PSOPFS),"^",2)) K PSOPFS Q
     88 I +$G(PSOPFS)<1 K PSOPFS
     89 E  S PSOPFS="1^"_PSOPFS
     90CPCK1 N TYPE S PSO=2,PSODA=DA,PSOFLAG=1,PSOPAR7=$G(^PS(59,PSOSITE,"IB")),TYPE=RFD D RXED^PSOCPA K TYPE
     91 Q
     92NEXT D NEXT^PSOUTIL(.PSORXED) K DIE,DR,DA S DIE="^PSRX(",DA=PSORXED("IRXN")
     93 S DR="101///"_$P(PSORXED("RX3"),"^")_";102///"_$P(PSORXED("RX3"),"^",2) D ^DIE K DIE,DR,DA,X,Y
     94 Q
     95EOJ K PSOSIG,PSORXED,PSOLIST,END,PSRX0
     96 D EX^PSORXED1
     97 Q
     98FILL ;
     99 K PSOEDITF,PSOEDITR,PSOERF
     100 F PSOEZ=0:0 S PSOEZ=$O(^PSRX(DA,1,PSOEZ)) Q:'PSOEZ  S:$D(^PSRX(DA,1,PSOEZ,0)) PSOERF=PSOEZ
     101 S PSOEDITF=$S($G(PSOERF):+$G(PSOERF),1:0)
     102 I PSOEDITF S PSOEDITR=$S($P($G(^PSRX(DA,1,PSOEDITF,0)),"^",18):1,1:0) G FILLX
     103 S PSOEDITR=$S($P($G(^PSRX(DA,2)),"^",13):1,1:0)
     104FILLX K PSOERF,PSOEZ
     105 Q
     106LBL ;
     107 S PSOEDITL=0
     108 I COM["PROV"!(COM["QTY")!(COM["DAYS")!(COM["MAIL")!(COM["UNIT")!(COM["FILL DATE")!(COM["REMARKS") I COM'["STATUS",COM'["CLINIC",COM'["DRUG",COM'["REFILLS",COM'["ISSUE",COM'["SIG",COM'["TRADE" D  Q
     109 .I $G(PSOEDITF) S PSOEDITL=1 Q
     110 .I '$G(PSOEDITF),$G(PSOEDITR) S PSOEDITL=2
     111 I '$G(PSOEDITF),$G(PSOEDITR) S PSOEDITL=2 Q
     112 I '$G(PSOEDITF),'$G(PSOEDITR) S PSOEDITL=0 Q
     113 I $G(RXRP(DA)) S PSOEDITL=1 Q
     114 I '$G(RXRP(DA)),$G(PSOEDITR) S PSOEDITL=2 Q
     115 S PSOEDITL=0
     116 Q
     117ASKL ;
     118 W ! K DIR S DIR("?",1)="You have edited a fill that has already been released. Do you want to",DIR("?",2)="include this prescription as one of the prescriptions to be acted upon",DIR("?",3)="at the label prompt."
     119 S DIR("?")="Enter 'Yes' to generate a reprint label request."
     120 S DIR(0)="Y",DIR("A")="The last fill has been released, do you want a reprint label",DIR("B")="Y" D ^DIR K DIR I Y=1 S PSOEDITL=0 Q
     121 S PSOEDITL=1
     122 Q
     123SETRP I $P($G(^PSRX(PSORXED("IRXN"),"STA")),"^")'=5,$G(PSOEDITL)=0 S RXRP(PSORXED("IRXN"))="1^^^1",VALMSG="Label will reprint due to Edit"
     124 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL.m

    r613 r623  
    1 PSORXL  ;BHAM ISC/SAB - action to be taken on prescriptions ;3/13/07  19:21
    2         ;;7.0;OUTPATIENT PHARMACY;**8,21,24,32,47,135,148,208**;DEC 1997;Build 41
    3         ; Modified from FOIA VistA
    4         ; Copyright (C) GNU GPL 2007 WorldVistA
    5         ;
    6         ;Ext ref to File #50 supported by DBIA 221
    7         ;Ext refs CHPUS^IBACUS and TRI^IBACUS supported by DBIA 203
    8         I $G(PSOTRVV),$G(PPL) S PSORX("PSOL",1)=PPL K PPL
    9         N SLBL,PSOSONE,PSOKLRXS
    10         S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$P(PSOPAR,"^",26) P
    11 LBL     I $G(PSOAFYN)'="Y" W !! S DIR("A",1)="Label Printer: "_$S($G(SUSPT):PSLION,1:$G(PSOLAP))
    12         S DIR("A")="LABEL: QUEUE/CHANGE PRINTER"_$S($P(PSOPAR,"^",23):"/HOLD",1:"")_$S($P(PSOPAR,"^",24):"/SUSPEND",1:"")_$S($P(PSOPAR,"^",26):"/LABEL",1:"")_" or '^' to bypass "
    13         S DIR("?",1)="Enter 'Q' to queue labels to print",DIR("?")="Enter '^' to bypass label functions",DIR("?",4)="Enter 'S' to suspend labels to print later"
    14         S DIR("?",2)="Enter 'H' to hold label until Rx can be filled",DIR("?",3)="Enter 'P' for Rx profile"
    15         S DIR("?",5)="Enter 'C' to select another label printer"
    16         S:$P(PSOPAR,"^",26) DIR("?",5)="Enter 'L' to print labels without queuing"
    17 TRI     ;
    18         S X="IBACUS" X ^%ZOSF("TEST") K X I '$T G PASS
    19         I '$$TRI^IBACUS() G PASS
    20         I '$D(PSORX("PSOL",1))!($G(PSOSUREP))!($G(PSOEXREP)) G PASS
    21         N GGG,PBILL,PSTRD,PSTRDZ,PSTRF,PSTRP,TRXI,TRIRX,PSTRIVAR,VV,VVV,VVCT
    22         D DEV^PSOCPTRI
    23         K ^TMP($J,"PSONOB"),^TMP($J,"PSOBILL")
    24         S VVCT=0 F VV=0:0 S VV=$O(PSORX("PSOL",VV)) Q:'VV  F VVV=1:1 S TRXI=$P(PSORX("PSOL",VV),",",VVV) Q:'TRXI  D
    25         .I '$G(DT) S DT=$$DT^XLFDT
    26         .I $P($G(^PSRX(+TRXI,"STA")),"^")=3 Q
    27         .S PSTRP=$P($G(^PSRX(+TRXI,0)),"^",2),PSTRD=+$G(PSOSITE),PSTRDZ=+$G(DUZ)
    28         .S PSTRF=0 F GGG=0:0 S GGG=$O(^PSRX(+TRXI,1,GGG)) Q:'GGG  S PSTRF=GGG
    29         .S VVCT=VVCT+1
    30         .I $G(RXRP(TRXI))!($G(RXPR(TRXI)))!($G(RXRH(TRXI))) S ^TMP($J,"PSONOB",VVCT)=TRXI Q
    31         .S PBILL=$$CHPUS^IBACUS(PSTRP,DT,TRXI,PSTRF,PSOLAP,PSTRD,PSTRDZ) S ^TMP($J,$S($G(PBILL):"PSOBILL",1:"PSONOB"),VVCT)=TRXI
    32         I '$D(^TMP($J,"PSOBILL")) K ^TMP($J,"PSONOB") G PASS
    33         I '$D(^TMP($J,"PSONOB")),$D(^TMP($J,"PSOBILL")) S (Y,LBL)="H" G H1
    34         ;
    35 SETP    K PSORX("PSOL"),PPL S VVCT=1 F VV=0:0 S VV=$O(^TMP($J,$S($G(PSTRIVAR):"PSONOB",1:"PSOBILL"),VV)) Q:'VV  S TRIRX=^TMP($J,$S($G(PSTRIVAR):"PSONOB",1:"PSOBILL"),VV) I +TRIRX D
    36         .I $G(PSORX("PSOL",1))="" S PSORX("PSOL",1)=TRIRX_"," Q
    37         .I $L(PSORX("PSOL",VVCT))+$L(TRIRX)<220 S PSORX("PSOL",VVCT)=PSORX("PSOL",VVCT)_TRIRX_"," Q
    38         .S VVCT=VVCT+1 S PSORX("PSOL",VVCT)=TRIRX_","
    39         I '$G(PSTRIVAR) S (Y,LBL)="H" S PSOKLRXS=1 K PSORSAVE,PSOPSAVE,PSOHSAVE D RSAVE D H1 D RREST K PSORSAVE,PSOPSAVE,PSOHSAVE K PSOKLRXS S PSTRIVAR=1 G SETP
    40         K ^TMP($J,"PSONOB") S PPL=$G(PSORX("PSOL",1))
    41 PASS    ;
    42         I $G(PSOAFYN)'="Y" I $E($G(DIR("A")),1,6)'="LABEL:" D RESDIR^PSOCPTRI
    43         I $G(PSOAFYN)'="Y" S DIR(0)="SA^P:PROFILE;Q:QUEUE;C:CHANGE PRINTER"_$S($P(PSOPAR,"^",23):";H:HOLD",1:"")_$S($P(PSOPAR,"^",24):";S:SUSPENSE",1:"")_$S($P(PSOPAR,"^",26):";L:PRINT",1:""),DIR("B")="Q" D ^DIR D  G:$D(DIRUT)!($D(DUOUT)) EX
    44         .I $G(PSOAFYN)'="Y" I $D(DIRUT)!($D(DUOUT)) D AL^PSOLBL("UT") I $G(PSOEXREP) S PSOEXREX=1
    45         .I $G(PSOAFYN)'="Y" I $G(PSOPULL) I $D(DIRUT)!($D(DUOUT)) S PSOQFLAG=1
    46         I $G(PSOAFYN)="Y" S PSOLAP=$G(^SC(+ORL,"AFRXCLINPRNT"))
    47         I $G(PSOAFYN)="Y" I PSOLAP="" S DIRUT="^" G:$D(DIRUT)!($D(DUOUT)) EX
    48         I $G(PSOAFYN)="Y" S PSOLAP=$P(^%ZIS(1,PSOLAP,0),"^",1)
    49         S:$G(PSOBEDT) NOPP=Y
    50         I $G(Y)="C" K PSOCLBL,%ZIS("B") S PSOCLBL=1 D @$S('$D(PSOPAR):"^PSOLSET",1:"PLBL^PSOLSET") K PSOCLBL G LBL
    51         I $G(Y)="Q",$D(RXRS),'$G(PSOPULL) D PPLADD^PSOSUPOE
    52         I $G(PSXSYS),($G(Y)'="H"),($G(Y)'="P"),('$G(PSOEXREP)) S LBL=Y,(RXLTOP,PPL1)=1 S:'$G(PSOPULL) SLBL=Y D A^PSOCMOP G:'$G(PPL) D1
    53         K DIR S LBL=Y S:'$G(PSOPULL) SLBL=Y G Q:Y="Q",S:Y="S",H1:Y="H",P:Y="L" I Y="P" W ! S PSDFN=DFN,PSFROM="" D ^PSODSPL K PSDFN,PSFROM G LBL
    54 EX      I $D(DUOUT)!$D(DIRUT) K BINGCRT,BINGRTE,BBRX,BBFLG S:$D(RXRS) SLBL="^" G:$D(RXRS) RXS K DIR,X,DIRUT,DUOUT,ACT,Y,DTOUT,PPL,REPRINT S NOBG=1 Q
    55 Q       S PPL1=1 G:$G(PPL)']"" D1 S PSNP=0,PSL=1 D  I $G(PSOFROM)="NEW",$P(PSOPAR,"^",8) S PSNP=1
    56         .Q:'$P(PSOPAR,"^",8)!($G(PSONOPRT))
    57         .F SLPPL=0:0 S SLPPL=$O(RXRS(SLPPL)) Q:'SLPPL!($G(PSNP))  I '$O(^PSRX(SLPPL,1,0)),'$D(RXPR(SLPPL)) S PSNP=1
    58         I $G(PSOLAP)]"",$G(PSOLAP)'=ION G QLBL
    59 Q1      W ! K POP S %ZIS("B")="",%ZIS="MNQ",%ZIS("A")="Select LABEL DEVICE: " D ^%ZIS S PSLION=ION K %ZIS("A") Q:$G(POP)&($G(PSPARTXX))  G:$G(POP)&($G(PSOSONE)) RXSQ D:$G(POP)&($G(PSONOPRT))  Q:$G(PSOQFLAG)  G:POP!(IO=IO(0)) LBL S PSOLAP=ION
    60         .S PSOQFLAG=1
    61         N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
    62         S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10)
    63         D ^%ZISC S PSL=0
    64 QLBL    I $G(PSXSYS),('$G(RXLTOP)),('$G(PSOEXREP)) D RXL^PSOCMOP G:'$G(PPL) D1
    65         ;- Submitting list of Rx to ECME for DUR/79 REJECT check and possible submission to 3rd Pary Payer
    66         I $G(PSOAFYN)'="Y" D ECME^PSORXL1 ;vfah
    67         ;
    68         S ZTRTN="DQ^PSOLBL",ZTIO=$S($G(SUSPT):PSLION,1:PSOLAP),ZTDESC="Outpatient Pharmacy "_$S($G(SUSPT):"SUSPENSE ",$G(DG):"DRUG INTERACTION ",1:"")_"LABELS OUTPUT ROUTINE",ZTDTH=$S($G(PSOTIME):PSOTIME,1:$H),PDUZ=DUZ
    69         F G="PPL1","PSOSYS","DFN","PSOPAR","PDUZ","PCOMX",$S($G(SUSPT):"PFION",1:"PSOLAP"),"PPL","PSOSITE","RXY","COPIES","SIDE","PSOSUSPR","PSOBARS","PSOBAR1","PSOBAR0","PSODELE","PSOPULL","PSTAT","PSODBQ","PSOEXREP","PSOTREP" S:$D(@G) ZTSAVE(G)=""
    70         S ZTSAVE("PSOAFDFN")="",ZTSAVE("PSOAFDUZ")="",ZTSAVE("PSOAFYN")="",ZTSAVE("PSOAFPAT")="",ZTSAVE("PSOAFPNM")="",ZTSAVE("VFASDD")="",ZTSAVE("ORL")="" ;vfah
    71         S ZTSAVE("PSORX(")="",ZTSAVE("RXRP(")="",ZTSAVE("RXPR(")="",ZTSAVE("RXRS(")="",ZTSAVE("RXFL(")="",ZTSAVE("PCOMH(")=""
    72         D ^%ZISC,^%ZTLOAD K:$G(PSOSONE) RXRS W:$D(ZTSK)&('$G(SUSPT))&('$G(PSOEXREP)) !!,"LABEL(S) QUEUED TO PRINT",!!
    73         Q:$G(PSPARTXX)  K G,PDUZ K:'$G(SUSPT) ZTSK Q:$G(DG)
    74         G:'$G(PSNP) QUEUP G:$G(PSOPRFLG) QUEUP S HOLDRPAS=$G(PSOPRPAS),PSOPRPAS=$P(PSOPAR,"^",13)
    75 PLBL    S PSOION=ION
    76         I '$D(PSOPROP)!($G(PSOPROP)=ION) 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 QUEUP G:$E(IOST)["C"!(PSOION=ION) PLBL S PSOPROP=ION
    77 QPRF    S ZTRTN="DQ^PSOPRF",ZTIO=PSOPROP,ZTDESC="Outpatient Pharmacy "_$S($G(SUSPT):"SUSPENSE ",1:"")_"PATIENT PROFILES",ZTDTH=$S($G(PSOTIME):PSOTIME,1:$H)
    78         F G="PSOPAR","PSODTCUT","PSOPRPAS","DFN","PSOSITE","NEW1","NEW11","PSOBMST","PFIO","PPL" S:$D(@G) ZTSAVE(G)=""
    79         D ^%ZTLOAD W:$D(ZTSK)&('$G(SUSPT))&('$G(PSOEXREP)) !,"PROFILE IS QUEUED TO PRINT",!! K G K:'$G(SUSPT) ZTSK D ^%ZISC
    80 QUEUP   D:$G(POP)&($G(PSONOPRT))  Q:$G(PSOQFLAG)  S PSNP=0,PSOPRPAS=$G(HOLDRPAS) K:PSOPRPAS']"" PSOPRPAS K HOLDRPAS G D1
    81         .S PSOQFLAG=1
    82         Q
    83         ;
    84 S       G S^PSORXL1
    85 SUS     S X="IBACUS" X ^%ZOSF("TEST") K X I '$T G SUSL1
    86         N TRIDA S TRIDA=DA I '$$TRI^IBACUS() S DA=TRIDA G SUSL1
    87         I $G(RXRP(TRIDA))!($G(RXPR(TRIDA)))!($G(RXRH(TRIDA))) S DA=TRIDA G SUSL1
    88         N PBILL,PSTRD,PSTRDZ,PSTRF,PSTRP,GGG
    89         D DEV^PSOCPTRI
    90         I '$G(DT) S DT=$$DT^XLFDT
    91         S PSTRP=$P($G(^PSRX(+TRIDA,0)),"^",2),PSTRD=+$G(PSOSITE),PSTRDZ=+$G(DUZ)
    92         S PSTRF=0 F GGG=0:0 S GGG=$O(^PSRX(+TRIDA,1,GGG)) Q:'GGG  S PSTRF=GGG
    93         S PBILL=$$CHPUS^IBACUS(PSTRP,DT,TRIDA,PSTRF,PSOLAP,PSTRD,PSTRDZ)
    94         I '$G(PBILL) S DA=TRIDA G SUSL1
    95         S FLD(99)="99",FLD(99.1)="Awaiting CHAMPUS billing approval"
    96         N RSDT,ACT,PSUS,RXF,RFN,I,PSDA,NOW,IR,FDA
    97         S DA=TRIDA D H^PSOCPTRH
    98         Q
    99 SUSL1   G SUS^PSORXL1
    100 H1      S PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1))
    101         D:'$D(^TMP($J,"PSOBILL")) NOOR^PSOHLD I $D(DIRUT) K DIRUT G PSORXL
    102         I $D(^TMP($J,"PSOBILL")) S FLD(99)="99",FLD(99.1)="Awaiting CHAMPUS billing approval" G H
    103         G:$G(PPL)']"" D1 D FLD^PSOHLD I $D(DUOUT)!($D(DIRUT)) K DIRUT,DUOUT,FLD,DIR G LBL
    104 H       K SPPL G:$D(DTOUT) D1 S SPPL="" F PI=1:1 Q:$P(PPL,",",PI)=""  D
    105         .S DA=$P(PPL,",",PI) I $P(^PSRX(DA,"STA"),"^")<10,$P(^("STA"),"^")'=4 D @$S($D(^TMP($J,"PSOBILL")):"H^PSOCPTRH",1:"H^PSOHLD") Q
    106         .I $P(^PSRX(DA,"STA"),"^")=4 S SPPL=SPPL_DA_"," Q
    107         I $G(SPPL)]"" D
    108         .W !!,$C(7),"Drug Interaction Rx(s) " F I=1:1 Q:$P(SPPL,",",I)=""  W $P(^PSRX($P(SPPL,",",I),0),"^")_", "
    109         .S PPL=SPPL,DG=1 D Q K DG,SPPL
    110 D1      K RXLTOP I $G(PPL1),$O(PSORX("PSOL",$G(PPL1))) S PPL1=$O(PSORX("PSOL",PPL1)),PPL=PSORX("PSOL",PPL1) G @$S(LBL="H":"H",LBL="L":"P1",1:"QLBL")
    111 RXS     I $D(RXRS),'$G(PSOKLRXS) I $G(SLBL)="H"!($G(SLBL)="S")!($G(SLBL)="^")!($G(SLBL)="") D  G:$G(PPL)'="" Q
    112         .K PPL,PSORX("PSOL") S PSOSONE=1 D PPLADD^PSOSUPOE
    113         .Q:$G(PPL)=""  W !!,"You have selected the following Rx(s) to be pulled from suspense:",!
    114         .F RXSS=0:0 S RXSS=$O(RXRS(RXSS)) Q:'RXSS  W !," Rx # ",$P($G(^PSRX(+$G(RXSS),0)),"^"),?23,$P($G(^PSDRUG(+$P($G(^PSRX(+$G(RXSS),0)),"^",6),0)),"^")
    115         .K DIR W ! S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you still want to pull these Rx(s) from suspense" D ^DIR K DIR I Y'=1 W !!,"Rx(s) will remain in Suspense!",! D RESET^PSOSUPOE K RXRS,PPL
    116         K:'$G(PSOKLRXS) RXRS K ^TMP($J,"PSOBILL"),RXPR,RXRP,RXRH,RXSS,LBL,PPL1,PPL,DIR,%DT,%,SD,COUNT,EXDT,L,PDUZ,REF,REPRINT,RFDATE,RFL1,RFLL,RXN,WARN,ZY,FLD,PI,ZD,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT Q
    117 P       S PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$G(PPL)']"" D1
    118         I $G(PSOLAP)']"" W ! K POP,ZTSK S %ZIS="M",%ZIS("A")="Select LABEL DEVICE: " D ^%ZIS K %ZIS("A") G:POP LBL S PSOLAP=ION
    119         S IOP=PSOLAP D ^%ZIS
    120         N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
    121 P1      S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10),PDUZ=DUZ D DQ1^PSOLBL,^%ZISC
    122         G:'$P(PSOPAR,"^",8)!(+$G(REPRINT))!($G(PSOFROM)'="NEW") D1 I $G(PSOPROP)']"" S PSOION=ION,%ZIS="M",%ZIS("A")="Select PROFILE DEVICE: " D ^%ZIS K %ZIS("A") G:POP D1 S PSOPROP=ION
    123         S IOP=PSOPROP D ^%ZIS D DQ^PSOPRF,^%ZISC G D1
    124         Q
    125 RXSQ    K RXRS G RXS
    126         Q
    127 RSAVE   N PMX
    128         S PMX="" F  S PMX=$O(RXRP(PMX)) Q:PMX=""  S PSORSAVE(PMX)=RXRP(PMX)
    129         S PMX="" F  S PMX=$O(RXPR(PMX)) Q:PMX=""  S PSOPSAVE(PMX)=RXPR(PMX)
    130         S PMX="" F  S PMX=$O(RXRH(PMX)) Q:PMX=""  S PSOHSAVE(PMX)=RXRH(PMX)
    131         Q
    132 RREST   N PMXZ
    133         S PMXZ="" F  S PMXZ=$O(PSORSAVE(PMXZ)) Q:PMXZ=""  S RXRP(PMXZ)=PSORSAVE(PMXZ)
    134         S PMXZ="" F  S PMXZ=$O(PSOPSAVE(PMXZ)) Q:PMXZ=""  S RXPR(PMXZ)=PSOPSAVE(PMXZ)
    135         S PSMX="" F  S PMXZ=$O(PSOHSAVE(PMXZ)) Q:PMXZ=""  S RXRH(PMXZ)=PSOHSAVE(PMXZ)
    136         Q
     1PSORXL ;BHAM ISC/SAB - action to be taken on prescriptions ;3/13/07  19:21
     2 ;;7.0;OUTPATIENT PHARMACY;**8,21,24,32,47,135,148,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VistA
     4 ; Copyright (C) GNU GPL 2007 WorldVistA
     5 ;
     6 ;Ext ref to File #50 supported by DBIA 221
     7 ;Ext refs CHPUS^IBACUS and TRI^IBACUS supported by DBIA 203
     8 I $G(PSOTRVV),$G(PPL) S PSORX("PSOL",1)=PPL K PPL
     9 N SLBL,PSOSONE,PSOKLRXS
     10 S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$P(PSOPAR,"^",26) P
     11LBL I $G(PSOAFYN)'="Y" W !! S DIR("A",1)="Label Printer: "_$S($G(SUSPT):PSLION,1:$G(PSOLAP))
     12 S DIR("A")="LABEL: QUEUE/CHANGE PRINTER"_$S($P(PSOPAR,"^",23):"/HOLD",1:"")_$S($P(PSOPAR,"^",24):"/SUSPEND",1:"")_$S($P(PSOPAR,"^",26):"/LABEL",1:"")_" or '^' to bypass "
     13 S DIR("?",1)="Enter 'Q' to queue labels to print",DIR("?")="Enter '^' to bypass label functions",DIR("?",4)="Enter 'S' to suspend labels to print later"
     14 S DIR("?",2)="Enter 'H' to hold label until Rx can be filled",DIR("?",3)="Enter 'P' for Rx profile"
     15 S DIR("?",5)="Enter 'C' to select another label printer"
     16 S:$P(PSOPAR,"^",26) DIR("?",5)="Enter 'L' to print labels without queuing"
     17TRI ;
     18 S X="IBACUS" X ^%ZOSF("TEST") K X I '$T G PASS
     19 I '$$TRI^IBACUS() G PASS
     20 I '$D(PSORX("PSOL",1))!($G(PSOSUREP))!($G(PSOEXREP)) G PASS
     21 N GGG,PBILL,PSTRD,PSTRDZ,PSTRF,PSTRP,TRXI,TRIRX,PSTRIVAR,VV,VVV,VVCT
     22 D DEV^PSOCPTRI
     23 K ^TMP($J,"PSONOB"),^TMP($J,"PSOBILL")
     24 S VVCT=0 F VV=0:0 S VV=$O(PSORX("PSOL",VV)) Q:'VV  F VVV=1:1 S TRXI=$P(PSORX("PSOL",VV),",",VVV) Q:'TRXI  D
     25 .I '$G(DT) S DT=$$DT^XLFDT
     26 .I $P($G(^PSRX(+TRXI,"STA")),"^")=3 Q
     27 .S PSTRP=$P($G(^PSRX(+TRXI,0)),"^",2),PSTRD=+$G(PSOSITE),PSTRDZ=+$G(DUZ)
     28 .S PSTRF=0 F GGG=0:0 S GGG=$O(^PSRX(+TRXI,1,GGG)) Q:'GGG  S PSTRF=GGG
     29 .S VVCT=VVCT+1
     30 .I $G(RXRP(TRXI))!($G(RXPR(TRXI)))!($G(RXRH(TRXI))) S ^TMP($J,"PSONOB",VVCT)=TRXI Q
     31 .S PBILL=$$CHPUS^IBACUS(PSTRP,DT,TRXI,PSTRF,PSOLAP,PSTRD,PSTRDZ) S ^TMP($J,$S($G(PBILL):"PSOBILL",1:"PSONOB"),VVCT)=TRXI
     32 I '$D(^TMP($J,"PSOBILL")) K ^TMP($J,"PSONOB") G PASS
     33 I '$D(^TMP($J,"PSONOB")),$D(^TMP($J,"PSOBILL")) S (Y,LBL)="H" G H1
     34 ;
     35SETP K PSORX("PSOL"),PPL S VVCT=1 F VV=0:0 S VV=$O(^TMP($J,$S($G(PSTRIVAR):"PSONOB",1:"PSOBILL"),VV)) Q:'VV  S TRIRX=^TMP($J,$S($G(PSTRIVAR):"PSONOB",1:"PSOBILL"),VV) I +TRIRX D
     36 .I $G(PSORX("PSOL",1))="" S PSORX("PSOL",1)=TRIRX_"," Q
     37 .I $L(PSORX("PSOL",VVCT))+$L(TRIRX)<220 S PSORX("PSOL",VVCT)=PSORX("PSOL",VVCT)_TRIRX_"," Q
     38 .S VVCT=VVCT+1 S PSORX("PSOL",VVCT)=TRIRX_","
     39 I '$G(PSTRIVAR) S (Y,LBL)="H" S PSOKLRXS=1 K PSORSAVE,PSOPSAVE,PSOHSAVE D RSAVE D H1 D RREST K PSORSAVE,PSOPSAVE,PSOHSAVE K PSOKLRXS S PSTRIVAR=1 G SETP
     40 K ^TMP($J,"PSONOB") S PPL=$G(PSORX("PSOL",1))
     41PASS ;
     42 I $G(PSOAFYN)'="Y" I $E($G(DIR("A")),1,6)'="LABEL:" D RESDIR^PSOCPTRI
     43 I $G(PSOAFYN)'="Y" S DIR(0)="SA^P:PROFILE;Q:QUEUE;C:CHANGE PRINTER"_$S($P(PSOPAR,"^",23):";H:HOLD",1:"")_$S($P(PSOPAR,"^",24):";S:SUSPENSE",1:"")_$S($P(PSOPAR,"^",26):";L:PRINT",1:""),DIR("B")="Q" D ^DIR D  G:$D(DIRUT)!($D(DUOUT)) EX
     44 .I $G(PSOAFYN)'="Y" I $D(DIRUT)!($D(DUOUT)) D AL^PSOLBL("UT") I $G(PSOEXREP) S PSOEXREX=1
     45 .I $G(PSOAFYN)'="Y" I $G(PSOPULL) I $D(DIRUT)!($D(DUOUT)) S PSOQFLAG=1
     46 I $G(PSOAFYN)="Y" S PSOLAP=$G(^SC(+ORL,"AFRXCLINPRNT"))
     47 I $G(PSOAFYN)="Y" I PSOLAP="" S DIRUT="^" G:$D(DIRUT)!($D(DUOUT)) EX
     48 I $G(PSOAFYN)="Y" S PSOLAP=$P(^%ZIS(1,PSOLAP,0),"^",1)
     49 S:$G(PSOBEDT) NOPP=Y
     50 I $G(Y)="C" K PSOCLBL,%ZIS("B") S PSOCLBL=1 D @$S('$D(PSOPAR):"^PSOLSET",1:"PLBL^PSOLSET") K PSOCLBL G LBL
     51 I $G(Y)="Q",$D(RXRS),'$G(PSOPULL) D PPLADD^PSOSUPOE
     52 I $G(PSXSYS),($G(Y)'="H"),($G(Y)'="P"),('$G(PSOEXREP)) S LBL=Y,(RXLTOP,PPL1)=1 S:'$G(PSOPULL) SLBL=Y D A^PSOCMOP G:'$G(PPL) D1
     53 K DIR S LBL=Y S:'$G(PSOPULL) SLBL=Y G Q:Y="Q",S:Y="S",H1:Y="H",P:Y="L" I Y="P" W ! S PSDFN=DFN,PSFROM="" D ^PSODSPL K PSDFN,PSFROM G LBL
     54EX I $D(DUOUT)!$D(DIRUT) K BINGCRT,BINGRTE,BBRX,BBFLG S:$D(RXRS) SLBL="^" G:$D(RXRS) RXS K DIR,X,DIRUT,DUOUT,ACT,Y,DTOUT,PPL,REPRINT S NOBG=1 Q
     55Q S PPL1=1 G:$G(PPL)']"" D1 S PSNP=0,PSL=1 D  I $G(PSOFROM)="NEW",$P(PSOPAR,"^",8) S PSNP=1
     56 .Q:'$P(PSOPAR,"^",8)!($G(PSONOPRT))
     57 .F SLPPL=0:0 S SLPPL=$O(RXRS(SLPPL)) Q:'SLPPL!($G(PSNP))  I '$O(^PSRX(SLPPL,1,0)),'$D(RXPR(SLPPL)) S PSNP=1
     58 I $G(PSOLAP)]"",$G(PSOLAP)'=ION G QLBL
     59Q1 W ! K POP S %ZIS("B")="",%ZIS="MNQ",%ZIS("A")="Select LABEL DEVICE: " D ^%ZIS S PSLION=ION K %ZIS("A") Q:$G(POP)&($G(PSPARTXX))  G:$G(POP)&($G(PSOSONE)) RXSQ D:$G(POP)&($G(PSONOPRT))  Q:$G(PSOQFLAG)  G:POP!(IO=IO(0)) LBL S PSOLAP=ION
     60 .S PSOQFLAG=1
     61 N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
     62 S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10)
     63 D ^%ZISC S PSL=0
     64QLBL I $G(PSXSYS),('$G(RXLTOP)),('$G(PSOEXREP)) D RXL^PSOCMOP G:'$G(PPL) D1
     65 ;- Submitting list of Rx to ECME for DUR/79 REJECT check and possible submission to 3rd Pary Payer
     66 I $G(PSOAFYN)'="Y" D ECME^PSORXL1 ;vfah
     67 ;
     68 S ZTRTN="DQ^PSOLBL",ZTIO=$S($G(SUSPT):PSLION,1:PSOLAP),ZTDESC="Outpatient Pharmacy "_$S($G(SUSPT):"SUSPENSE ",$G(DG):"DRUG INTERACTION ",1:"")_"LABELS OUTPUT ROUTINE",ZTDTH=$S($G(PSOTIME):PSOTIME,1:$H),PDUZ=DUZ
     69 F G="PPL1","PSOSYS","DFN","PSOPAR","PDUZ","PCOMX",$S($G(SUSPT):"PFION",1:"PSOLAP"),"PPL","PSOSITE","RXY","COPIES","SIDE","PSOSUSPR","PSOBARS","PSOBAR1","PSOBAR0","PSODELE","PSOPULL","PSTAT","PSODBQ","PSOEXREP","PSOTREP" S:$D(@G) ZTSAVE(G)=""
     70 S ZTSAVE("PSOAFDFN")="",ZTSAVE("PSOAFDUZ")="",ZTSAVE("PSOAFYN")="",ZTSAVE("PSOAFPAT")="",ZTSAVE("PSOAFPNM")="",ZTSAVE("VFASDD")="",ZTSAVE("ORL")="" ;vfah
     71 S ZTSAVE("PSORX(")="",ZTSAVE("RXRP(")="",ZTSAVE("RXPR(")="",ZTSAVE("RXRS(")="",ZTSAVE("RXFL(")="",ZTSAVE("PCOMH(")=""
     72 D ^%ZISC,^%ZTLOAD K:$G(PSOSONE) RXRS W:$D(ZTSK)&('$G(SUSPT))&('$G(PSOEXREP)) !!,"LABEL(S) QUEUED TO PRINT",!!
     73 Q:$G(PSPARTXX)  K G,PDUZ K:'$G(SUSPT) ZTSK Q:$G(DG)
     74 G:'$G(PSNP) QUEUP G:$G(PSOPRFLG) QUEUP S HOLDRPAS=$G(PSOPRPAS),PSOPRPAS=$P(PSOPAR,"^",13)
     75PLBL S PSOION=ION
     76 I '$D(PSOPROP)!($G(PSOPROP)=ION) 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 QUEUP G:$E(IOST)["C"!(PSOION=ION) PLBL S PSOPROP=ION
     77QPRF S ZTRTN="DQ^PSOPRF",ZTIO=PSOPROP,ZTDESC="Outpatient Pharmacy "_$S($G(SUSPT):"SUSPENSE ",1:"")_"PATIENT PROFILES",ZTDTH=$S($G(PSOTIME):PSOTIME,1:$H)
     78 F G="PSOPAR","PSODTCUT","PSOPRPAS","DFN","PSOSITE","NEW1","NEW11","PSOBMST","PFIO","PPL" S:$D(@G) ZTSAVE(G)=""
     79 D ^%ZTLOAD W:$D(ZTSK)&('$G(SUSPT))&('$G(PSOEXREP)) !,"PROFILE IS QUEUED TO PRINT",!! K G K:'$G(SUSPT) ZTSK D ^%ZISC
     80QUEUP D:$G(POP)&($G(PSONOPRT))  Q:$G(PSOQFLAG)  S PSNP=0,PSOPRPAS=$G(HOLDRPAS) K:PSOPRPAS']"" PSOPRPAS K HOLDRPAS G D1
     81 .S PSOQFLAG=1
     82 Q
     83 ;
     84S G S^PSORXL1
     85SUS S X="IBACUS" X ^%ZOSF("TEST") K X I '$T G SUSL1
     86 N TRIDA S TRIDA=DA I '$$TRI^IBACUS() S DA=TRIDA G SUSL1
     87 I $G(RXRP(TRIDA))!($G(RXPR(TRIDA)))!($G(RXRH(TRIDA))) S DA=TRIDA G SUSL1
     88 N PBILL,PSTRD,PSTRDZ,PSTRF,PSTRP,GGG
     89 D DEV^PSOCPTRI
     90 I '$G(DT) S DT=$$DT^XLFDT
     91 S PSTRP=$P($G(^PSRX(+TRIDA,0)),"^",2),PSTRD=+$G(PSOSITE),PSTRDZ=+$G(DUZ)
     92 S PSTRF=0 F GGG=0:0 S GGG=$O(^PSRX(+TRIDA,1,GGG)) Q:'GGG  S PSTRF=GGG
     93 S PBILL=$$CHPUS^IBACUS(PSTRP,DT,TRIDA,PSTRF,PSOLAP,PSTRD,PSTRDZ)
     94 I '$G(PBILL) S DA=TRIDA G SUSL1
     95 S FLD(99)="99",FLD(99.1)="Awaiting CHAMPUS billing approval"
     96 N RSDT,ACT,PSUS,RXF,RFN,I,PSDA,NOW,IR,FDA
     97 S DA=TRIDA D H^PSOCPTRH
     98 Q
     99SUSL1 G SUS^PSORXL1
     100H1 S PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1))
     101 D:'$D(^TMP($J,"PSOBILL")) NOOR^PSOHLD I $D(DIRUT) K DIRUT G PSORXL
     102 I $D(^TMP($J,"PSOBILL")) S FLD(99)="99",FLD(99.1)="Awaiting CHAMPUS billing approval" G H
     103 G:$G(PPL)']"" D1 D FLD^PSOHLD I $D(DUOUT)!($D(DIRUT)) K DIRUT,DUOUT,FLD,DIR G LBL
     104H K SPPL G:$D(DTOUT) D1 S SPPL="" F PI=1:1 Q:$P(PPL,",",PI)=""  D
     105 .S DA=$P(PPL,",",PI) I $P(^PSRX(DA,"STA"),"^")<10,$P(^("STA"),"^")'=4 D @$S($D(^TMP($J,"PSOBILL")):"H^PSOCPTRH",1:"H^PSOHLD") Q
     106 .I $P(^PSRX(DA,"STA"),"^")=4 S SPPL=SPPL_DA_"," Q
     107 I $G(SPPL)]"" D
     108 .W !!,$C(7),"Drug Interaction Rx(s) " F I=1:1 Q:$P(SPPL,",",I)=""  W $P(^PSRX($P(SPPL,",",I),0),"^")_", "
     109 .S PPL=SPPL,DG=1 D Q K DG,SPPL
     110D1 K RXLTOP I $G(PPL1),$O(PSORX("PSOL",$G(PPL1))) S PPL1=$O(PSORX("PSOL",PPL1)),PPL=PSORX("PSOL",PPL1) G @$S(LBL="H":"H",LBL="L":"P1",1:"QLBL")
     111RXS I $D(RXRS),'$G(PSOKLRXS) I $G(SLBL)="H"!($G(SLBL)="S")!($G(SLBL)="^")!($G(SLBL)="") D  G:$G(PPL)'="" Q
     112 .K PPL,PSORX("PSOL") S PSOSONE=1 D PPLADD^PSOSUPOE
     113 .Q:$G(PPL)=""  W !!,"You have selected the following Rx(s) to be pulled from suspense:",!
     114 .F RXSS=0:0 S RXSS=$O(RXRS(RXSS)) Q:'RXSS  W !," Rx # ",$P($G(^PSRX(+$G(RXSS),0)),"^"),?23,$P($G(^PSDRUG(+$P($G(^PSRX(+$G(RXSS),0)),"^",6),0)),"^")
     115 .K DIR W ! S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you still want to pull these Rx(s) from suspense" D ^DIR K DIR I Y'=1 W !!,"Rx(s) will remain in Suspense!",! D RESET^PSOSUPOE K RXRS,PPL
     116 K:'$G(PSOKLRXS) RXRS K ^TMP($J,"PSOBILL"),RXPR,RXRP,RXRH,RXSS,LBL,PPL1,PPL,DIR,%DT,%,SD,COUNT,EXDT,L,PDUZ,REF,REPRINT,RFDATE,RFL1,RFLL,RXN,WARN,ZY,FLD,PI,ZD,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT Q
     117P S PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$G(PPL)']"" D1
     118 I $G(PSOLAP)']"" W ! K POP,ZTSK S %ZIS="M",%ZIS("A")="Select LABEL DEVICE: " D ^%ZIS K %ZIS("A") G:POP LBL S PSOLAP=ION
     119 S IOP=PSOLAP D ^%ZIS
     120 N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
     121P1 S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10),PDUZ=DUZ D DQ1^PSOLBL,^%ZISC
     122 G:'$P(PSOPAR,"^",8)!(+$G(REPRINT))!($G(PSOFROM)'="NEW") D1 I $G(PSOPROP)']"" S PSOION=ION,%ZIS="M",%ZIS("A")="Select PROFILE DEVICE: " D ^%ZIS K %ZIS("A") G:POP D1 S PSOPROP=ION
     123 S IOP=PSOPROP D ^%ZIS D DQ^PSOPRF,^%ZISC G D1
     124 Q
     125RXSQ K RXRS G RXS
     126 Q
     127RSAVE N PMX
     128 S PMX="" F  S PMX=$O(RXRP(PMX)) Q:PMX=""  S PSORSAVE(PMX)=RXRP(PMX)
     129 S PMX="" F  S PMX=$O(RXPR(PMX)) Q:PMX=""  S PSOPSAVE(PMX)=RXPR(PMX)
     130 S PMX="" F  S PMX=$O(RXRH(PMX)) Q:PMX=""  S PSOHSAVE(PMX)=RXRH(PMX)
     131 Q
     132RREST N PMXZ
     133 S PMXZ="" F  S PMXZ=$O(PSORSAVE(PMXZ)) Q:PMXZ=""  S RXRP(PMXZ)=PSORSAVE(PMXZ)
     134 S PMXZ="" F  S PMXZ=$O(PSOPSAVE(PMXZ)) Q:PMXZ=""  S RXPR(PMXZ)=PSOPSAVE(PMXZ)
     135 S PSMX="" F  S PMXZ=$O(PSOHSAVE(PMXZ)) Q:PMXZ=""  S RXRH(PMXZ)=PSOHSAVE(PMXZ)
     136 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL1.m

    r613 r623  
    1 PSORXL1 ;BIR/SAB-action to be taken on prescriptions ; 10/5/07 2:40pm
    2         ;;7.0;OUTPATIENT PHARMACY;**36,46,148,260,274**;DEC 1997;Build 8
    3 S       S SPPL="",PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1)) G:$G(PPL)']"" D1
    4 S1      F PI=1:1 Q:$P(PPL,",",PI)=""  S DA=$P(PPL,",",PI) D
    5         .I $P(^PSRX(DA,"STA"),"^")<10,$P(^("STA"),"^")'=4 D SUS Q
    6         .I $P(^PSRX(DA,"STA"),"^")=4 S SPPL=SPPL_DA_"," Q
    7         I $G(SPPL)]"" D  K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DUOUT,DTOUT,DIRUT
    8         .W !!,$C(7),"Drug Interaction Rx(s) " F I=1:1 Q:$P(SPPL,",",I)=""  W $P(^PSRX($P(SPPL,",",I),0),"^")_", "
    9         .I $G(PSOLAP)=""!($G(PSOLAP)=$G(ION)) W !,"Label device must be selected for Drug Interaction label!"
    10         .S PPL=SPPL,DG=1 N PPL1 D Q^PSORXL K DG,SPPL
    11         S SUSPT="SUSPENSE" G D1
    12         Q
    13 SUS     S ACT=1,RXN=DA,RX0=^PSRX(DA,0),SD=$S($G(ZD(DA)):$E(ZD(DA),1,7),1:$P(^(3),"^")),RXS=$O(^PS(52.5,"B",DA,0)) I RXS S RXCMOP=$P($G(^PS(52.5,RXS,0)),"^",7) D  Q:$G(DFLG)!($G(PSOWFLG))
    14         .;checks to see if future fill exists
    15         .S PSOWFLG=0 I '$G(RXPR(DA)),$P($G(^PS(52.5,RXS,"P")),"^")=0,$P($G(^PSRX(DA,"STA")),"^")=5 D SWARN Q:$G(PSOWFLG)
    16         .K PSOWFLG I $G(RXPR(DA)),'$P($G(^PS(52.5,RXS,"P")),"^") D WARN Q:$G(DFLG)
    17         .S DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN I $P($G(^PSRX(RXN,"STA")),"^")=5 S $P(^("STA"),"^")=0
    18         G:$G(RXRP(DA))!($G(RXPR(DA))) LOCK
    19         I $G(PSXSYS) D SUS1^PSOCMOP I $G(XFLAG)=1 K XFLAG Q
    20 LOCK    I $P($G(^PSRX(RXN,"STA")),"^")=3 G SUSQ
    21         S RXP=+$G(RXPR(DA)),DIC="^PS(52.5,",DIC(0)="L",X=RXN,DIC("DR")=".02///"_SD_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04///M;.05///"_RXP_";.06////"_PSOSITE_";2///0" K DD,DO D FILE^DICN D  I +Y,'$G(RXP),$G(RXRP(RXN)) S $P(^PS(52.5,+Y,0),"^",12)=1
    22         .K DD,DO I +Y,$G(PSOEXREP) S $P(^PS(52.5,+Y,0),"^",12)=1
    23         .I +Y S $P(^PS(52.5,+Y,0),"^",13)=$G(RXFL(RXN))
    24         S $P(^PSRX(RXN,"STA"),"^")=5,LFD=$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3) D ACT
    25         W !!,$S(RXP:"Partial ",1:"")_"RX# ",$P(^PSRX(RXN,0),"^")_" has been suspended until "_LFD_"."
    26         S VALMSG=$S(RXP:"Partial ",1:"")_"Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$S($G(RXRP(RXN))&('$G(RXP)):" (Reprint)",1:"")
    27         S COMM=$S(RXP:"Partial ",1:"")_"Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$S($G(RXRP(RXN))&('$G(RXP)):" (Reprint)",1:"")
    28         D:'$D(^TMP("PSORXN",$J,RXN)) EN^PSOHLSN1(RXN,"SC","ZS",COMM)
    29         S:$D(^TMP("PSORXN",$J,RXN)) $P(^TMP("PSORXN",$J,RXN),"^",4)=COMM
    30         ;
    31         ; - If not a PARTIAL, reverse ECME Claim, if necessary
    32         I '$G(RXP) D REVERSE^PSOBPSU1(RXN,,"DC",3)
    33         K COMM
    34 SUSQ    Q
    35         ;PSO*7*274 allways recalculate RXF
    36 ACT     S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S RXF=I S:I>5 RXF=I+1
    37         S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA  S IR=FDA
    38         S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
    39         D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^S^"_DUZ_"^"_RXF_"^"_$S(RXP:"Partial ",1:"")_"RX "_$S($G(RXRP(DA))&('$G(RXP)):"Reprint ",1:"")_"Placed on Suspense until "_LFD K RXF,I,FDA,DIC,DIE,DR,Y,X,%,%H,%I
    40         Q
    41 D1      I $O(PSORX("PSOL",$G(PPL1))) S PPL1=$O(PSORX("PSOL",$G(PPL1))),PPL=PSORX("PSOL",PPL1) G S1
    42         G:$D(RXRS) RXS^PSORXL
    43         K LBL,PPL1,PPL,DIR,%DT,%,SD,COUNT,EXDT,L,PDUZ,REF,REPRINT,RFDATE,RFL1,RFLL,RXN,WARN,ZY,FLD,PI,ZD,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT,DFLG,RXPD,PSOWFLG
    44         Q
    45 WARN    W ! K DIR,DIRUT,DUOUT,DTOUT,DFLG S Y=$P(^PS(52.5,RXS,0),"^",2) X ^DD("DD") S RXPD=Y,DIR(0)="SA^S:SUSPEND;Q:QUEUE;E:EXIT"
    46         S DIR("A",1)="Rx #"_$P(^PSRX(DA,0),"^")_" is suspended "_$S($G(RXCMOP)]"":"for CMOP ",1:"")_"until "_RXPD
    47         I $G(RXCMOP)]"" D  G WARN1
    48         .W !!,"A partial entered for this Rx cannot be suspended."
    49         .W !,"You may pull this fill from suspense or print the label now.",!!
    50         .S DIR("A",2)=" ",DIR("A",3)="   Do you want to Queue to print",DIR("A")="                or Exit: "
    51         S DIR("A",2)=" ",DIR("A",3)="   Do you want to: Suspend Partial",DIR("A",4)="                   Queue to print",DIR("A")="                or Exit:  "
    52 WARN1   S DIR("B")="EXIT",DIR("?")="^D HLP^PSORXL1" D ^DIR K DIR
    53         I Y="E"!($D(DIRUT))!(Y="S"&($G(RXCMOP)]"")) S DA(1)=DA,DA=RXPR(DA),DIK="^PSRX("_DA(1)_",""P""," D ^DIK S ^PSRX(DA(1),"TYPE")=0,DFLG=1 W $C(7)," Partial Removed!" Q
    54         I Y="Q" S DPPL=PPL,HOLDPPL1=$G(PPL1),DPI=PI,RXLTOP=1 S PPL=$G(RXN)_"," S PSPARTXX=1 D Q^PSORXL K PSPARTXX S DFLG=1,PPL=DPPL,PI=DPI,PPL1=$G(HOLDPPL1) K HOLDPPL1,DPPL,DPPI,DPI,RXLTOP Q
    55         Q
    56 HLP     I $G(RXCMOP)']"" W !!,"If you choose to suspend this partial Rx, the current suspended fill will",!,"be replaced by the partial.  You may want to pull this fill early instead.",!
    57         I $G(RXCMOP)]"" W !!,"You cannot suspend a partial when a CMOP fill is in suspense, because the partial will replace the CMOP fill in suspense."
    58         W !,"If you choose to queue this partial, the label will printout on the previous",!,"selected label printer.",!
    59         W !,"You may exit without printing or suspending this partial.  This will also delete",!,"the partial Rx entered."
    60         Q
    61 SWARN   ;
    62         S PSORXLDA=$G(DA),PSORXZD=$P($G(^PS(52.5,RXS,0)),"^",2)
    63         W $C(7),!!,"Rx "_$P($G(^PSRX(DA,0)),"^")_" is already suspended "_$S($G(RXCMOP)]"":"for CMOP ",1:"")_"until "_$E(PSORXZD,4,5)_"-"_$E(PSORXZD,6,7)_"-"_$E(PSORXZD,2,3)_"." K PSORXZD
    64         W !,"By suspending this fill, the fill that is already suspended will be overwritten",!,"and a label will not print for that fill!",!
    65         K DIR S DIR(0)="SA^Q:QUEUE;S:SUSPEND",DIR("B")="Q",DIR("A")="Do you want to Queue to print or Suspend Rx "_$P($G(^PSRX(DA,0)),"^")_": " D ^DIR K DIR
    66         I $G(Y)="S" K RXFL(PSORXLDA) G SWARNQ
    67         I $G(Y)="Q" D  G SWARNQ
    68         . S PSOKSPPL=$G(PPL),PSOZXPPL=$G(PPL1),PSOZXPI=$G(PI),RXLTOP=1
    69         . S PPL=$G(RXN)_"," D SWARS D Q^PSORXL S PSOWFLG=1,PPL=PSOKSPPL
    70         . S PI=PSOZXPI,PPL1=PSOZXPPL K PSOKSPPL,PSOZXPPL,PSOZXPI,RXLTOP,RXFL(+$G(PSORXLDA))
    71         W !!,"Nothing queued to print for Rx "_$P($G(^PSRX(PSORXLDA,0)),"^"),! S PSOWFLG=1
    72 SWARNQ  ;
    73         S DA=$G(PSORXLDA) K PSORXLDA
    74         Q
    75 SWARS   ;
    76         S PSOZXFL(PSORXLDA)=+$P($G(^PS(52.5,+$G(RXS),0)),"^",13) I '$G(PSOZXFL(PSORXLDA)) K PSOZXFL Q
    77         S PSOZXFPL=$P(PSOKSPPL,",",+$G(PI),99)
    78         S PSOZXFPN=$L(PSOZXFPL,PPL)-1
    79         I $G(PSOZXFL(PSORXLDA)),$G(PSOZXFPN) S RXFL(PSORXLDA)=$G(PSOZXFL(PSORXLDA))-$G(PSOZXFPN)
    80         K PSOZXFL,PSOZXFPL,PSOZXFPN
    81         Q
    82 ECME    ; - Looks for DUR/79 REJECTS and send Mail Rx's to ECME that have not been SUSPENDED
    83         N PSOI,PSOJ,PSORX,PSORF,PSOACT,BWH,PPLTMP
    84         S PPLTMP=$G(PPL)
    85         F PSOI=1:1 S PSORX=+$P($G(PPL),",",PSOI) Q:'PSORX  D
    86         . I $G(RXPR(PSORX)) Q
    87         . S PSOACT="",PSORF=$$LSTRFL^PSOBPSU1(PSORX)
    88         . S BWH=$S(PSORF:"RF",1:"OF")
    89         . I $$FIND^PSOREJUT(PSORX,PSORF) D  I PSOACT="Q" D RMV(PSORX,.PPLTMP) Q
    90         . . S PSOACT=$$HDLG^PSOREJU1(PSORX,PSORF,"79,88",BWH,"OIQ","Q")
    91         S:$G(PPLTMP)'="" PPL=PPLTMP
    92         Q
    93 RMV(RX,PPL)     ; Remove the Rx from the label print queue
    94         N XPPL,I
    95         S XPPL=PPL,PPL="" F I=1:1:$L(XPPL,",") I $P(XPPL,",",I)'="",$P(XPPL,",",I)'=RX S PPL=PPL_$P(XPPL,",",I)_","
    96         I PPL="" K PPL
    97         Q
     1PSORXL1 ;BIR/SAB-action to be taken on prescriptions ;03/01/96
     2 ;;7.0;OUTPATIENT PHARMACY;**36,46,148,260**;DEC 1997;Build 84
     3S S SPPL="",PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1)) G:$G(PPL)']"" D1
     4S1 F PI=1:1 Q:$P(PPL,",",PI)=""  S DA=$P(PPL,",",PI) D
     5 .I $P(^PSRX(DA,"STA"),"^")<10,$P(^("STA"),"^")'=4 D SUS Q
     6 .I $P(^PSRX(DA,"STA"),"^")=4 S SPPL=SPPL_DA_"," Q
     7 I $G(SPPL)]"" D  K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DUOUT,DTOUT,DIRUT
     8 .W !!,$C(7),"Drug Interaction Rx(s) " F I=1:1 Q:$P(SPPL,",",I)=""  W $P(^PSRX($P(SPPL,",",I),0),"^")_", "
     9 .I $G(PSOLAP)=""!($G(PSOLAP)=$G(ION)) W !,"Label device must be selected for Drug Interaction label!"
     10 .S PPL=SPPL,DG=1 N PPL1 D Q^PSORXL K DG,SPPL
     11 S SUSPT="SUSPENSE" G D1
     12 Q
     13SUS S ACT=1,RXN=DA,RX0=^PSRX(DA,0),SD=$S($G(ZD(DA)):$E(ZD(DA),1,7),1:$P(^(3),"^")),RXS=$O(^PS(52.5,"B",DA,0)) I RXS S RXCMOP=$P($G(^PS(52.5,RXS,0)),"^",7) D  Q:$G(DFLG)!($G(PSOWFLG))
     14 .;checks to see if future fill exists
     15 .S PSOWFLG=0 I '$G(RXPR(DA)),$P($G(^PS(52.5,RXS,"P")),"^")=0,$P($G(^PSRX(DA,"STA")),"^")=5 D SWARN Q:$G(PSOWFLG)
     16 .K PSOWFLG I $G(RXPR(DA)),'$P($G(^PS(52.5,RXS,"P")),"^") D WARN Q:$G(DFLG)
     17 .S DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN I $P($G(^PSRX(RXN,"STA")),"^")=5 S $P(^("STA"),"^")=0
     18 G:$G(RXRP(DA))!($G(RXPR(DA))) LOCK
     19 I $G(PSXSYS) D SUS1^PSOCMOP I $G(XFLAG)=1 K XFLAG Q
     20LOCK I $P($G(^PSRX(RXN,"STA")),"^")=3 G SUSQ
     21 S RXP=+$G(RXPR(DA)),DIC="^PS(52.5,",DIC(0)="L",X=RXN,DIC("DR")=".02///"_SD_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04///M;.05///"_RXP_";.06////"_PSOSITE_";2///0" K DD,DO D FILE^DICN D  I +Y,'$G(RXP),$G(RXRP(RXN)) S $P(^PS(52.5,+Y,0),"^",12)=1
     22 .K DD,DO I +Y,$G(PSOEXREP) S $P(^PS(52.5,+Y,0),"^",12)=1
     23 .I +Y S $P(^PS(52.5,+Y,0),"^",13)=$G(RXFL(RXN))
     24 S $P(^PSRX(RXN,"STA"),"^")=5,LFD=$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3) D ACT
     25 W !!,$S(RXP:"Partial ",1:"")_"RX# ",$P(^PSRX(RXN,0),"^")_" has been suspended until "_LFD_"."
     26 S VALMSG=$S(RXP:"Partial ",1:"")_"Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$S($G(RXRP(RXN))&('$G(RXP)):" (Reprint)",1:"")
     27 S COMM=$S(RXP:"Partial ",1:"")_"Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$S($G(RXRP(RXN))&('$G(RXP)):" (Reprint)",1:"")
     28 D:'$D(^TMP("PSORXN",$J,RXN)) EN^PSOHLSN1(RXN,"SC","ZS",COMM)
     29 S:$D(^TMP("PSORXN",$J,RXN)) $P(^TMP("PSORXN",$J,RXN),"^",4)=COMM
     30 ;
     31 ; - If not a PARTIAL, reverse ECME Claim, if necessary
     32 I '$G(RXP) D REVERSE^PSOBPSU1(RXN,,"DC",3)
     33 K COMM
     34SUSQ Q
     35ACT I '$D(RXF) S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S RXF=I S:I>5 RXF=I+1
     36 S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA  S IR=FDA
     37 S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
     38 D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^S^"_DUZ_"^"_RXF_"^"_$S(RXP:"Partial ",1:"")_"RX "_$S($G(RXRP(DA))&('$G(RXP)):"Reprint ",1:"")_"Placed on Suspense until "_LFD K RXF,I,FDA,DIC,DIE,DR,Y,X,%,%H,%I
     39 Q
     40D1 I $O(PSORX("PSOL",$G(PPL1))) S PPL1=$O(PSORX("PSOL",$G(PPL1))),PPL=PSORX("PSOL",PPL1) G S1
     41 G:$D(RXRS) RXS^PSORXL
     42 K LBL,PPL1,PPL,DIR,%DT,%,SD,COUNT,EXDT,L,PDUZ,REF,REPRINT,RFDATE,RFL1,RFLL,RXN,WARN,ZY,FLD,PI,ZD,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT,DFLG,RXPD,PSOWFLG
     43 Q
     44WARN W ! K DIR,DIRUT,DUOUT,DTOUT,DFLG S Y=$P(^PS(52.5,RXS,0),"^",2) X ^DD("DD") S RXPD=Y,DIR(0)="SA^S:SUSPEND;Q:QUEUE;E:EXIT"
     45 S DIR("A",1)="Rx #"_$P(^PSRX(DA,0),"^")_" is suspended "_$S($G(RXCMOP)]"":"for CMOP ",1:"")_"until "_RXPD
     46 I $G(RXCMOP)]"" D  G WARN1
     47 .W !!,"A partial entered for this Rx cannot be suspended."
     48 .W !,"You may pull this fill from suspense or print the label now.",!!
     49 .S DIR("A",2)=" ",DIR("A",3)="   Do you want to Queue to print",DIR("A")="                or Exit: "
     50 S DIR("A",2)=" ",DIR("A",3)="   Do you want to: Suspend Partial",DIR("A",4)="                   Queue to print",DIR("A")="                or Exit:  "
     51WARN1 S DIR("B")="EXIT",DIR("?")="^D HLP^PSORXL1" D ^DIR K DIR
     52 I Y="E"!($D(DIRUT))!(Y="S"&($G(RXCMOP)]"")) S DA(1)=DA,DA=RXPR(DA),DIK="^PSRX("_DA(1)_",""P""," D ^DIK S ^PSRX(DA(1),"TYPE")=0,DFLG=1 W $C(7)," Partial Removed!" Q
     53 I Y="Q" S DPPL=PPL,HOLDPPL1=$G(PPL1),DPI=PI,RXLTOP=1 S PPL=$G(RXN)_"," S PSPARTXX=1 D Q^PSORXL K PSPARTXX S DFLG=1,PPL=DPPL,PI=DPI,PPL1=$G(HOLDPPL1) K HOLDPPL1,DPPL,DPPI,DPI,RXLTOP Q
     54 Q
     55HLP I $G(RXCMOP)']"" W !!,"If you choose to suspend this partial Rx, the current suspended fill will",!,"be replaced by the partial.  You may want to pull this fill early instead.",!
     56 I $G(RXCMOP)]"" W !!,"You cannot suspend a partial when a CMOP fill is in suspense, because the partial will replace the CMOP fill in suspense."
     57 W !,"If you choose to queue this partial, the label will printout on the previous",!,"selected label printer.",!
     58 W !,"You may exit without printing or suspending this partial.  This will also delete",!,"the partial Rx entered."
     59 Q
     60SWARN ;
     61 S PSORXLDA=$G(DA),PSORXZD=$P($G(^PS(52.5,RXS,0)),"^",2)
     62 W $C(7),!!,"Rx "_$P($G(^PSRX(DA,0)),"^")_" is already suspended "_$S($G(RXCMOP)]"":"for CMOP ",1:"")_"until "_$E(PSORXZD,4,5)_"-"_$E(PSORXZD,6,7)_"-"_$E(PSORXZD,2,3)_"." K PSORXZD
     63 W !,"By suspending this fill, the fill that is already suspended will be overwritten",!,"and a label will not print for that fill!",!
     64 K DIR S DIR(0)="SA^Q:QUEUE;S:SUSPEND",DIR("B")="Q",DIR("A")="Do you want to Queue to print or Suspend Rx "_$P($G(^PSRX(DA,0)),"^")_": " D ^DIR K DIR
     65 I $G(Y)="S" K RXFL(PSORXLDA) G SWARNQ
     66 I $G(Y)="Q" D  G SWARNQ
     67 . S PSOKSPPL=$G(PPL),PSOZXPPL=$G(PPL1),PSOZXPI=$G(PI),RXLTOP=1
     68 . S PPL=$G(RXN)_"," D SWARS D Q^PSORXL S PSOWFLG=1,PPL=PSOKSPPL
     69 . S PI=PSOZXPI,PPL1=PSOZXPPL K PSOKSPPL,PSOZXPPL,PSOZXPI,RXLTOP,RXFL(+$G(PSORXLDA))
     70 W !!,"Nothing queued to print for Rx "_$P($G(^PSRX(PSORXLDA,0)),"^"),! S PSOWFLG=1
     71SWARNQ ;
     72 S DA=$G(PSORXLDA) K PSORXLDA
     73 Q
     74SWARS ;
     75 S PSOZXFL(PSORXLDA)=+$P($G(^PS(52.5,+$G(RXS),0)),"^",13) I '$G(PSOZXFL(PSORXLDA)) K PSOZXFL Q
     76 S PSOZXFPL=$P(PSOKSPPL,",",+$G(PI),99)
     77 S PSOZXFPN=$L(PSOZXFPL,PPL)-1
     78 I $G(PSOZXFL(PSORXLDA)),$G(PSOZXFPN) S RXFL(PSORXLDA)=$G(PSOZXFL(PSORXLDA))-$G(PSOZXFPN)
     79 K PSOZXFL,PSOZXFPL,PSOZXFPN
     80 Q
     81ECME ; - Looks for DUR/79 REJECTS and send Mail Rx's to ECME that have not been SUSPENDED
     82 N PSOI,PSOJ,PSORX,PSORF,PSOACT,BWH,PPLTMP
     83 S PPLTMP=$G(PPL)
     84 F PSOI=1:1 S PSORX=+$P($G(PPL),",",PSOI) Q:'PSORX  D
     85 . I $G(RXPR(PSORX)) Q
     86 . S PSOACT="",PSORF=$$LSTRFL^PSOBPSU1(PSORX)
     87 . S BWH=$S(PSORF:"RF",1:"OF")
     88 . I $$FIND^PSOREJUT(PSORX,PSORF) D  I PSOACT="Q" D RMV(PSORX,.PPLTMP) Q
     89 . . S PSOACT=$$HDLG^PSOREJU1(PSORX,PSORF,"79,88",BWH,"OIQ","Q")
     90 S:$G(PPLTMP)'="" PPL=PPLTMP
     91 Q
     92RMV(RX,PPL) ; Remove the Rx from the label print queue
     93 N XPPL,I
     94 S XPPL=PPL,PPL="" F I=1:1:$L(XPPL,",") I $P(XPPL,",",I)'="",$P(XPPL,",",I)'=RX S PPL=PPL_$P(XPPL,",",I)_","
     95 I PPL="" K PPL
     96 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXPA1.m

    r613 r623  
    1 PSORXPA1        ;BIR/SAB - listman partial prescriptions ; 1/15/07 5:42pm
    2         ;;7.0;OUTPATIENT PHARMACY;**11,27,56,77,130,152,181,174,208**;DEC 1997;Build 41
    3         ; Modified from FOIA VISTA,
    4         ; Copyright (C) 2007 WorldVistA
    5         ;
    6         ; This program is free software; you can redistribute it and/or modify
    7         ; it under the terms of the GNU General Public License as published by
    8         ; the Free Software Foundation; either version 2 of the License, or
    9         ; (at your option) any later version.
    10         ;
    11         ; This program is distributed in the hope that it will be useful,
    12         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ; GNU General Public License for more details.
    15         ;
    16         ; You should have received a copy of the GNU General Public License
    17         ; along with this program; if not, write to the Free Software
    18         ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    19         ;External references L,UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
    20         ;External reference to ^PSDRUG supported by DBIA 221
    21         ;External reference to ^DD(52 supported by DBIA 999
    22         S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
    23         D ^DIC K DIC ;vfah
    24         S PSOZAF=+Y  ;vfah Quits if AUTOFINISH,RX not a user
    25         I $P($G(^PSRX(RXN,"OR1")),"^",5)=$G(PSOZAF) S VALMBCK="",VALMSG="Partial option is not available for Autofinshed Rxs" K PSOZAF Q  ;vfah
    26         I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!" Q
    27         ;I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial has already been requested!" Q
    28         I $D(RXRS($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="Rx is being pulled from suspense!" Q
    29         S PSORPDFN=+$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^",2)
    30         S PSOPLCK=$$L^PSSLOCK(PSORPDFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK,PSORPDFN D  Q
    31         .S VALMBCK=""
    32         K PSOPLCK D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) D UL^PSSLOCK(PSORPDFN) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG,PSORPDFN Q
    33         I '$G(RXPR($P(PSOLST(ORN),"^",2))) S RX=$P(PSOLST(ORN),"^",2) D VALID^PSORXRP1 I $G(QFLG) S VALMBCK="",VALMSG="A New Label has been requested already!" K QFLG,RX D ULK Q
    34         D FULL^VALM1 I '$D(PSOPAR) D ^PSOLSET D:'$D(PSOPAR) ULK G:'$D(PSOPAR) KL
    35         S DA=$P(PSOLST(ORN),"^",2),RX0=^PSRX(DA,0),J=DA,RX2=$G(^(2)),R3=$G(^(3)) S:'$G(BBFLG) BBRX(1)=""
    36         I +$P($G(^PSRX(DA,2)),"^",6)<DT D
    37         .S:$P($G(^PSRX(DA,"STA")),"^")<12 $P(^PSRX(DA,"STA"),"^")=11
    38         .S COMM="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"/"_$E($P(^(2),"^",6),6,7)_"/"_$E($P(^(2),"^",6),2,3)
    39         .S STAT="SC",PHARMST="ZE" D EN^PSOHLSN1(DA,STAT,PHARMST,COMM) K STAT,PHARMST,COMM,RX0,J,RX2,R3
    40         ;I +$P($G(^PSRX(DA,2)),"^",6)<PSODTCUT D  K DA S VALMBCK="R" Q
    41         ;.S VALMSG="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"/"_$E($P(^(2),"^",6),6,7)_"/"_$E($P(^(2),"^",6),2,3)
    42         I +^PSRX(DA,"STA"),+^("STA")'=5,+^("STA")'=11 D  K DA S VALMBCK="R" D ULK Q
    43         .S C=";"_+^PSRX(DA,"STA")_":",X=$P(^DD(52,100,0),"^",3),E=$F(X,C),D=$P($E(X,E,999),";")
    44         .S VALMSG="Prescription is in a "_D_" status."
    45         I $G(PSXSYS),($O(^PS(52.5,"B",DA,""))) S PSOZ1=$O(^PS(52.5,"B",DA,"")) D
    46         .I $P($G(^PS(52.5,PSOZ1,0)),"^",7)="Q"!($P($G(^(0)),"^",7)="L") D
    47         ..W !!,"A partial entered for this Rx cannot be suspended."
    48         ..W !,"A fill for this Rx is already suspended for CMOP transmission."
    49         ..W !,"You may pull this fill from suspense or enter a partial and print the label.",!!
    50         ;..S PSOZZ=1 K PSOZ1
    51 CLC     S PSOCLC=DUZ,PHYS=$P(^PSRX(DA,0),"^",4),DRG=$P(^(0),"^",6)
    52         I 'PHYS,$O(^PSRX(DA,1,0)) F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S PHYS=$S($P(^PSRX(DA,1,I,0),"^",17):$P(^PSRX(DA,1,I,0),"^",17),1:PHYS)
    53         S PSOPRZ=0 I $O(^PSRX(DA,"P",0)) N Z2 F Z2=0:0 S Z2=$O(^PSRX(DA,"P",Z2)) Q:'Z2  S PSOPRZ=Z2
    54         K Z1,PRMK S PM=1,RXN=DA,RXF=6,DIE("NO^")="BACKOUTOK",DIE=52
    55         ;DR="[PSO PARTIAL]"
    56         S DR="K PM,PQ;60;Q;S:$O(Y(1))]""""!($G(PM)) Y=""@1"";35;@1;K PM;"
    57         S DR(2,52.2)=".01;S Z1=D1;.02;S:X=""M""!('$P($G(PSOPAR),U,12)) PM=1;.04;S:X=U PQ=1;.041R;S:X=U PQ=1;.05;.07////^S X=DUZ;6////^S X=PHYS;Q;.08///^S X=""NOW"";S PDT=X;.09////^S X=PSOSITE;.03;S:X=U PQ=1;S PRMK=X"
    58         D ^DIE
    59         I $D(RXPR(DA)),'$D(^PSRX(DA,"P",$G(RXPR(DA)))) D RMP^PSOCAN3
    60         G:'$G(Z1) CLCX
    61         I $G(PRMK)']"",Z1>PSOPRZ D ULK G KILL
    62         I Z1,$G(PRMK)]"" D  D:$T(EN^PSOHDR)]"" EN^PSOHDR("PPAR",RXN) K DIE,RXN,RXF
    63         .D ACT S:$P($G(^PSRX(RXN,"P",Z1,0)),"^",2)["W" PSODFN=$P(^PSRX(RXN,0),"^",2),BINGRTE="W",BBFLG=1,BBRX(1)=$G(BBRX(1))_RXN_","
    64         .S ZD(RXN)=+^PSRX(RXN,"P",Z1,0),^PSRX(RXN,"TYPE")=Z1,$P(^PSRX(RXN,"P",Z1,0),"^",11)=$P($G(^PSDRUG(DRG,660)),"^",6),RXF=6,RXP=Z1,RXPR(RXN)=RXP
    65         .;I $G(PSOZZ)=1,($G(Z1)) D Q1^PSORXL K Z1,PSOZZ Q
    66         .I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=RXN_"," Q
    67         .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  Q:PSORX("PSOL",PSOX1)[RXN_","  S PSOX2=PSOX1
    68         .I PSOX1 Q
    69         .I $L(PSORX("PSOL",PSOX2))+$L(RXN)<220 S:PSORX("PSOL",PSOX2)'[RXN_"," PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RXN_","
    70         .E  S PSORX("PSOL",PSOX2+1)=RXN_","
    71         S:'$D(PSOFROM) PSOFROM="PARTIAL" S BINGCRT=1 ;D:$D(BINGRTE)&($D(DISGROUP)) ^PSOBING1 K BINGRTE,TM,TM1
    72 CLCX    D ULK K DR,DIE,DRG,PPL,RXP,IOP,DA,PHYS,PSOPRZ S VALMBCK="R" Q
    73         ;
    74 KILL    S DA=Z1,DIK="^PSRX("_RXN_",""P""," D ^DIK S ^PSRX(RXN,"TYPE")=0
    75         D ULK S VALMSG="No Partial Fill Dispensed",VALMBCK="R" Q
    76 KL      K DFN,RFDAT,RLL,%,PRMK,PM,%Y,%X,D0,D1,DA,DI,DIC,DIE,DLAYGO,DQ,DR,I,II,J,JJJ,N,PHYS,PS,PSDATE,RFL,RFL1,RXF,ST,ST0,Z,Z1,X,Y,PDT,PSL,PSNP
    77         K PSOM,PSOP,PSOD,PSOU,DIK,DUOUT,IFN,RXN,DRG,HRX,I1,PSOCLC,PSOLIST,PSOLST,PSPAR,RXP D KVA^VADPT Q
    78 ACT     ;adds activity info for partial rx
    79         S RXF=0 F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I  S RXF=I S:I>5 RXF=I+1
    80         S DA=0 F FDA=0:0 S FDA=$O(^PSRX(RXN,"A",FDA)) Q:'FDA  S DA=FDA
    81         S DA=DA+1,^PSRX(RXN,"A",0)="^52.3DA^"_DA_"^"_DA,^PSRX(RXN,"A",DA,0)=DT_"^"_"P"_"^"_DUZ_"^"_RXF_"^"_PRMK
    82 EX      K RXF,I,FDA S DA=RXN
    83         Q
    84 ULK     ;
    85         D UL^PSSLOCK(+$G(PSORPDFN))
    86         D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
    87         K PSOMSG,PSOPLCK,PSORPDFN
    88         Q
     1PSORXPA1 ;BIR/SAB - listman partial prescriptions ; 1/15/07 5:42pm
     2 ;;7.0;OUTPATIENT PHARMACY;**11,27,56,77,130,152,181,174,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 ;External references L,UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
     20 ;External reference to ^PSDRUG supported by DBIA 221
     21 ;External reference to ^DD(52 supported by DBIA 999
     22 S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
     23 D ^DIC K DIC ;vfah
     24 S PSOZAF=+Y  ;vfah Quits if AUTOFINISH,RX not a user
     25 I $P($G(^PSRX(RXN,"OR1")),"^",5)=$G(PSOZAF) S VALMBCK="",VALMSG="Partial option is not available for Autofinshed Rxs" K PSOZAF Q  ;vfah
     26 I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!" Q
     27 ;I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial has already been requested!" Q
     28 I $D(RXRS($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="Rx is being pulled from suspense!" Q
     29 S PSORPDFN=+$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^",2)
     30 S PSOPLCK=$$L^PSSLOCK(PSORPDFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK,PSORPDFN D  Q
     31 .S VALMBCK=""
     32 K PSOPLCK D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) D UL^PSSLOCK(PSORPDFN) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG,PSORPDFN Q
     33 I '$G(RXPR($P(PSOLST(ORN),"^",2))) S RX=$P(PSOLST(ORN),"^",2) D VALID^PSORXRP1 I $G(QFLG) S VALMBCK="",VALMSG="A New Label has been requested already!" K QFLG,RX D ULK Q
     34 D FULL^VALM1 I '$D(PSOPAR) D ^PSOLSET D:'$D(PSOPAR) ULK G:'$D(PSOPAR) KL
     35 S DA=$P(PSOLST(ORN),"^",2),RX0=^PSRX(DA,0),J=DA,RX2=$G(^(2)),R3=$G(^(3)) S:'$G(BBFLG) BBRX(1)=""
     36 I +$P($G(^PSRX(DA,2)),"^",6)<DT D
     37 .S:$P($G(^PSRX(DA,"STA")),"^")<12 $P(^PSRX(DA,"STA"),"^")=11
     38 .S COMM="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"/"_$E($P(^(2),"^",6),6,7)_"/"_$E($P(^(2),"^",6),2,3)
     39 .S STAT="SC",PHARMST="ZE" D EN^PSOHLSN1(DA,STAT,PHARMST,COMM) K STAT,PHARMST,COMM,RX0,J,RX2,R3
     40 ;I +$P($G(^PSRX(DA,2)),"^",6)<PSODTCUT D  K DA S VALMBCK="R" Q
     41 ;.S VALMSG="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"/"_$E($P(^(2),"^",6),6,7)_"/"_$E($P(^(2),"^",6),2,3)
     42 I +^PSRX(DA,"STA"),+^("STA")'=5,+^("STA")'=11 D  K DA S VALMBCK="R" D ULK Q
     43 .S C=";"_+^PSRX(DA,"STA")_":",X=$P(^DD(52,100,0),"^",3),E=$F(X,C),D=$P($E(X,E,999),";")
     44 .S VALMSG="Prescription is in a "_D_" status."
     45 I $G(PSXSYS),($O(^PS(52.5,"B",DA,""))) S PSOZ1=$O(^PS(52.5,"B",DA,"")) D
     46 .I $P($G(^PS(52.5,PSOZ1,0)),"^",7)="Q"!($P($G(^(0)),"^",7)="L") D
     47 ..W !!,"A partial entered for this Rx cannot be suspended."
     48 ..W !,"A fill for this Rx is already suspended for CMOP transmission."
     49 ..W !,"You may pull this fill from suspense or enter a partial and print the label.",!!
     50 ;..S PSOZZ=1 K PSOZ1
     51CLC S PSOCLC=DUZ,PHYS=$P(^PSRX(DA,0),"^",4),DRG=$P(^(0),"^",6)
     52 I 'PHYS,$O(^PSRX(DA,1,0)) F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S PHYS=$S($P(^PSRX(DA,1,I,0),"^",17):$P(^PSRX(DA,1,I,0),"^",17),1:PHYS)
     53 S PSOPRZ=0 I $O(^PSRX(DA,"P",0)) N Z2 F Z2=0:0 S Z2=$O(^PSRX(DA,"P",Z2)) Q:'Z2  S PSOPRZ=Z2
     54 K Z1,PRMK S PM=1,RXN=DA,RXF=6,DIE("NO^")="BACKOUTOK",DIE=52
     55 ;DR="[PSO PARTIAL]"
     56 S DR="K PM,PQ;60;Q;S:$O(Y(1))]""""!($G(PM)) Y=""@1"";35;@1;K PM;"
     57 S DR(2,52.2)=".01;S Z1=D1;.02;S:X=""M""!('$P($G(PSOPAR),U,12)) PM=1;.04;S:X=U PQ=1;.041R;S:X=U PQ=1;.05;.07////^S X=DUZ;6////^S X=PHYS;Q;.08///^S X=""NOW"";S PDT=X;.09////^S X=PSOSITE;.03;S:X=U PQ=1;S PRMK=X"
     58 D ^DIE
     59 I $D(RXPR(DA)),'$D(^PSRX(DA,"P",$G(RXPR(DA)))) D RMP^PSOCAN3
     60 G:'$G(Z1) CLCX
     61 I $G(PRMK)']"",Z1>PSOPRZ D ULK G KILL
     62 I Z1,$G(PRMK)]"" D  D:$T(EN^PSOHDR)]"" EN^PSOHDR("PPAR",RXN) K DIE,RXN,RXF
     63 .D ACT S:$P($G(^PSRX(RXN,"P",Z1,0)),"^",2)["W" PSODFN=$P(^PSRX(RXN,0),"^",2),BINGRTE="W",BBFLG=1,BBRX(1)=$G(BBRX(1))_RXN_","
     64 .S ZD(RXN)=+^PSRX(RXN,"P",Z1,0),^PSRX(RXN,"TYPE")=Z1,$P(^PSRX(RXN,"P",Z1,0),"^",11)=$P($G(^PSDRUG(DRG,660)),"^",6),RXF=6,RXP=Z1,RXPR(RXN)=RXP
     65 .;I $G(PSOZZ)=1,($G(Z1)) D Q1^PSORXL K Z1,PSOZZ Q
     66 .I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=RXN_"," Q
     67 .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  Q:PSORX("PSOL",PSOX1)[RXN_","  S PSOX2=PSOX1
     68 .I PSOX1 Q
     69 .I $L(PSORX("PSOL",PSOX2))+$L(RXN)<220 S:PSORX("PSOL",PSOX2)'[RXN_"," PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RXN_","
     70 .E  S PSORX("PSOL",PSOX2+1)=RXN_","
     71 S:'$D(PSOFROM) PSOFROM="PARTIAL" S BINGCRT=1 ;D:$D(BINGRTE)&($D(DISGROUP)) ^PSOBING1 K BINGRTE,TM,TM1
     72CLCX D ULK K DR,DIE,DRG,PPL,RXP,IOP,DA,PHYS,PSOPRZ S VALMBCK="R" Q
     73 ;
     74KILL S DA=Z1,DIK="^PSRX("_RXN_",""P""," D ^DIK S ^PSRX(RXN,"TYPE")=0
     75 D ULK S VALMSG="No Partial Fill Dispensed",VALMBCK="R" Q
     76KL K DFN,RFDAT,RLL,%,PRMK,PM,%Y,%X,D0,D1,DA,DI,DIC,DIE,DLAYGO,DQ,DR,I,II,J,JJJ,N,PHYS,PS,PSDATE,RFL,RFL1,RXF,ST,ST0,Z,Z1,X,Y,PDT,PSL,PSNP
     77 K PSOM,PSOP,PSOD,PSOU,DIK,DUOUT,IFN,RXN,DRG,HRX,I1,PSOCLC,PSOLIST,PSOLST,PSPAR,RXP D KVA^VADPT Q
     78ACT ;adds activity info for partial rx
     79 S RXF=0 F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I  S RXF=I S:I>5 RXF=I+1
     80 S DA=0 F FDA=0:0 S FDA=$O(^PSRX(RXN,"A",FDA)) Q:'FDA  S DA=FDA
     81 S DA=DA+1,^PSRX(RXN,"A",0)="^52.3DA^"_DA_"^"_DA,^PSRX(RXN,"A",DA,0)=DT_"^"_"P"_"^"_DUZ_"^"_RXF_"^"_PRMK
     82EX K RXF,I,FDA S DA=RXN
     83 Q
     84ULK ;
     85 D UL^PSSLOCK(+$G(PSORPDFN))
     86 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
     87 K PSOMSG,PSOPLCK,PSORPDFN
     88 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRP1.m

    r613 r623  
    1 PSORXRP1        ;BIR/SAB-rx speed reprint listman ; 12/10/06 9:50pm
    2         ;;7.0;OUTPATIENT PHARMACY;**11,27,120,156,148,208**;DEC 1997;Build 41
    3         ; Modified from FOIA VISTA,
    4         ; Copyright (C) 2007 WorldVistA
    5         ;
    6         ; This program is free software; you can redistribute it and/or modify
    7         ; it under the terms of the GNU General Public License as published by
    8         ; the Free Software Foundation; either version 2 of the License, or
    9         ; (at your option) any later version.
    10         ;
    11         ; This program is distributed in the hope that it will be useful,
    12         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ; GNU General Public License for more details.
    15         ;
    16         ; You should have received a copy of the GNU General Public License
    17         ; along with this program; if not, write to the Free Software
    18         ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    19         ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
    20 SEL     N PSODISP,VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
    21         S RXCNT=0 K PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR S LST=Y I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" Q
    22         K DIR,DIRUT,DTOUT,PSOOELSE,PSOREPX I +LST S PSOOELSE=1 D
    23         .D FULL^VALM1 K DIR S DIR("A")="Number of Copies? ",DIR(0)="N^1:99:0",DIR("?")="Enter the number of copies you want (1 TO 99)",DIR("B")=1
    24         .D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT)  S COPIES=Y
    25         .K DIR S DIR("A")="Print adhesive portion of label only? ",DIR(0)="Y",DIR("B")="No",DIR("?",1)="If entire label, including trailers are to print press RETURN for default."
    26         .S DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES." D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT)  S SIDE=Y
    27         .I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D  Q:$G(PSOREPX)
    28         ..K DIR,DIRUT S DIR("A")="Do you want to resend to Dispensing System Device",DIR(0)="Y",DIR("B")="No"
    29         ..D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT)  S PSODISP=$S(Y:0,1:1)
    30         .K DIRUT,DIR S DIR("A")="Comments: ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX)
    31         .D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT)  S (PCOM,PCOMX)=Y
    32         .S PSOCLC=DUZ
    33         .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""  S ORN=$P(LST,",",ORD),QFLG=0 D:+PSOLST(ORN)=52 RX
    34         .S VALMBCK="R"
    35         I $G(PSOREPX) S VALMBCK="R",VALMSG="No Labels Reprinted."
    36         K PSOREPX
    37         I '$G(PSOOELSE) S VALMBCK=""
    38         D ^PSOBUILD
    39         K PSOMSG,PSORPSRX,QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,I,J,JJJ,K,RX,RXF,X,Y,Z,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSOOELSE,ORD,LST,ORN D KVA^VADPT
    40         Q
    41         ;
    42 RX      ;process reprint request
    43         ;
    44         S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
    45         D ^DIC K DIC ;vfah
    46         S PSOZAF=+Y ;vfah
    47         I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"OR1")),"^",5)=$G(PSOZAF) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" is an Autofinish,Rx and labels can not be reprinted." K PSOZAF D PAUSE^VALM1 Q  ;vfah
    48         ;
    49         Q:$P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^")>11
    50         I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Rejects!" K DIR D PAUSE^VALM1 Q
    51         S PSORPSRX=$P(PSOLST(ORN),"^",2) D PSOL^PSSLOCK(PSORPSRX) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P($G(^PSRX(PSORPSRX,0)),"^")),! D PAUSE^VALM1 K PSORPSRX,PSOMSG Q
    52         S RX=$P(PSOLST(ORN),"^",2),STA=$P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^") D CHK I $G(QFLG) D ULR Q
    53         S RXF=0,ZD(RX)=DT,REPRINT=1
    54         S RXRP($P(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE
    55         I $G(PSODISP)=1 S RXRP($P(PSOLST(ORN),"^",2),"RP")=1
    56         S RXFL($P(PSOLST(ORN),"^",2))=0 F ZZZ=0:0 S ZZZ=$O(^PSRX($P(PSOLST(ORN),"^",2),1,ZZZ)) Q:'ZZZ  S RXFL($P(PSOLST(ORN),"^",2))=ZZZ
    57         K ZZZ
    58         I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=RX_"," S ST="" D ACT1,ULR Q
    59         F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
    60         I $L(PSORX("PSOL",PSOX2))+$L(RX)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RX_","
    61         E  S PSORX("PSOL",PSOX2+1)=RX_","
    62         S ST="" D ACT1
    63         D ULR
    64         Q
    65 CHK     ;check for valid reprint
    66         I DT>$P(^PSRX(RX,2),"^",6) D  S QFLG=1 Q
    67         .I $P(^PSRX(RX,"STA"),"^")<11 S $P(^PSRX(RX,"STA"),"^")=11 D
    68         ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(RX,"SC","ZE",COMM) K COMM
    69         S DFN=PSODFN D DEM^VADPT I $P(VADM(6),"^",2)]"" D  S QFLG=1 Q
    70         .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A")
    71         .D ACT1
    72         I $D(RXPR($P(PSOLST(ORN),"^",2)))!$D(RXRP($P(PSOLST(ORN),"^",2))) S QFLG=1 Q
    73         D VALID Q:$G(QFLG)
    74         S X=$O(^PS(52.5,"B",RX,0)) I X,'$G(^PS(52.5,X,"P")) S QFLG=1 Q
    75         I $G(X)'>0 G GOOD
    76         I $P($G(^PS(52.5,X,0)),"^",7)']"" G GOOD
    77         I $P($G(^PS(52.5,X,0)),"^",7)="Q" K X,XX S QFLG=1 Q
    78         I $P($G(^PS(52.5,X,0)),"^",7)="L" K X,XX S QFLG=1 Q
    79 GOOD    K X
    80         I $D(^PS(52.4,RX)) S QFLG=1 Q
    81         I $D(^PS(52.4,"AREF",PSODFN,RX)) S QFLG=1 Q
    82         I $G(PSODIV),$D(^PSRX(RX,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=RX D CHK1^PSOUTLA I $G(POERR)&(PSPOP) S QFLG=1 Q
    83         I STA=3!(STA=4)!(STA=12) S QFLG=1 Q
    84         Q
    85 ACT1    S RXF=0 F J=0:0 S J=$O(^PSRX(RX,1,J)) Q:'J  S RXF=J S:J>5 RXF=J+1
    86         S IR=0 F J=0:0 S J=$O(^PSRX(RX,"A",J)) Q:'J  S IR=J
    87         S IR=IR+1,^PSRX(RX,"A",0)="^52.3DA^"_IR_"^"_IR
    88         D NOW^%DTC S ^PSRX(RX,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,XX,%,%H,%I,RXF
    89         S:$P(^PSRX(RX,2),"^",15)&($G(ST)'="C") $P(^PSRX(RX,2),"^",14)=1
    90         Q
    91 VALID   ;check for rx in label array
    92         I $O(PSORX("PSOL",0)) D
    93         .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  I PSORX("PSOL",PSOX1)[RX_"," S QFLG=1 Q
    94         Q
    95 ULR     ;
    96         I $G(PSORPSRX) D PSOUL^PSSLOCK(PSORPSRX)
    97         Q
     1PSORXRP1 ;BIR/SAB-rx speed reprint listman ; 12/10/06 9:50pm
     2 ;;7.0;OUTPATIENT PHARMACY;**11,27,120,156,148,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
     20SEL N PSODISP,VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
     21 S RXCNT=0 K PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR S LST=Y I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" Q
     22 K DIR,DIRUT,DTOUT,PSOOELSE,PSOREPX I +LST S PSOOELSE=1 D
     23 .D FULL^VALM1 K DIR S DIR("A")="Number of Copies? ",DIR(0)="N^1:99:0",DIR("?")="Enter the number of copies you want (1 TO 99)",DIR("B")=1
     24 .D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT)  S COPIES=Y
     25 .K DIR S DIR("A")="Print adhesive portion of label only? ",DIR(0)="Y",DIR("B")="No",DIR("?",1)="If entire label, including trailers are to print press RETURN for default."
     26 .S DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES." D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT)  S SIDE=Y
     27 .I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D  Q:$G(PSOREPX)
     28 ..K DIR,DIRUT S DIR("A")="Do you want to resend to Dispensing System Device",DIR(0)="Y",DIR("B")="No"
     29 ..D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT)  S PSODISP=$S(Y:0,1:1)
     30 .K DIRUT,DIR S DIR("A")="Comments: ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX)
     31 .D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT)  S (PCOM,PCOMX)=Y
     32 .S PSOCLC=DUZ
     33 .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""  S ORN=$P(LST,",",ORD),QFLG=0 D:+PSOLST(ORN)=52 RX
     34 .S VALMBCK="R"
     35 I $G(PSOREPX) S VALMBCK="R",VALMSG="No Labels Reprinted."
     36 K PSOREPX
     37 I '$G(PSOOELSE) S VALMBCK=""
     38 D ^PSOBUILD
     39 K PSOMSG,PSORPSRX,QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,I,J,JJJ,K,RX,RXF,X,Y,Z,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSOOELSE,ORD,LST,ORN D KVA^VADPT
     40 Q
     41 ;
     42RX ;process reprint request
     43 ;
     44 S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
     45 D ^DIC K DIC ;vfah
     46 S PSOZAF=+Y ;vfah
     47 I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"OR1")),"^",5)=$G(PSOZAF) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" is an Autofinish,Rx and labels can not be reprinted." K PSOZAF D PAUSE^VALM1 Q  ;vfah
     48 ;
     49 Q:$P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^")>11
     50 I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Rejects!" K DIR D PAUSE^VALM1 Q
     51 S PSORPSRX=$P(PSOLST(ORN),"^",2) D PSOL^PSSLOCK(PSORPSRX) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P($G(^PSRX(PSORPSRX,0)),"^")),! D PAUSE^VALM1 K PSORPSRX,PSOMSG Q
     52 S RX=$P(PSOLST(ORN),"^",2),STA=$P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^") D CHK I $G(QFLG) D ULR Q
     53 S RXF=0,ZD(RX)=DT,REPRINT=1
     54 S RXRP($P(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE
     55 I $G(PSODISP)=1 S RXRP($P(PSOLST(ORN),"^",2),"RP")=1
     56 S RXFL($P(PSOLST(ORN),"^",2))=0 F ZZZ=0:0 S ZZZ=$O(^PSRX($P(PSOLST(ORN),"^",2),1,ZZZ)) Q:'ZZZ  S RXFL($P(PSOLST(ORN),"^",2))=ZZZ
     57 K ZZZ
     58 I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=RX_"," S ST="" D ACT1,ULR Q
     59 F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
     60 I $L(PSORX("PSOL",PSOX2))+$L(RX)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RX_","
     61 E  S PSORX("PSOL",PSOX2+1)=RX_","
     62 S ST="" D ACT1
     63 D ULR
     64 Q
     65CHK ;check for valid reprint
     66 I DT>$P(^PSRX(RX,2),"^",6) D  S QFLG=1 Q
     67 .I $P(^PSRX(RX,"STA"),"^")<11 S $P(^PSRX(RX,"STA"),"^")=11 D
     68 ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(RX,"SC","ZE",COMM) K COMM
     69 S DFN=PSODFN D DEM^VADPT I $P(VADM(6),"^",2)]"" D  S QFLG=1 Q
     70 .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A")
     71 .D ACT1
     72 I $D(RXPR($P(PSOLST(ORN),"^",2)))!$D(RXRP($P(PSOLST(ORN),"^",2))) S QFLG=1 Q
     73 D VALID Q:$G(QFLG)
     74 S X=$O(^PS(52.5,"B",RX,0)) I X,'$G(^PS(52.5,X,"P")) S QFLG=1 Q
     75 I $G(X)'>0 G GOOD
     76 I $P($G(^PS(52.5,X,0)),"^",7)']"" G GOOD
     77 I $P($G(^PS(52.5,X,0)),"^",7)="Q" K X,XX S QFLG=1 Q
     78 I $P($G(^PS(52.5,X,0)),"^",7)="L" K X,XX S QFLG=1 Q
     79GOOD K X
     80 I $D(^PS(52.4,RX)) S QFLG=1 Q
     81 I $D(^PS(52.4,"AREF",PSODFN,RX)) S QFLG=1 Q
     82 I $G(PSODIV),$D(^PSRX(RX,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=RX D CHK1^PSOUTLA I $G(POERR)&(PSPOP) S QFLG=1 Q
     83 I STA=3!(STA=4)!(STA=12) S QFLG=1 Q
     84 Q
     85ACT1 S RXF=0 F J=0:0 S J=$O(^PSRX(RX,1,J)) Q:'J  S RXF=J S:J>5 RXF=J+1
     86 S IR=0 F J=0:0 S J=$O(^PSRX(RX,"A",J)) Q:'J  S IR=J
     87 S IR=IR+1,^PSRX(RX,"A",0)="^52.3DA^"_IR_"^"_IR
     88 D NOW^%DTC S ^PSRX(RX,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,XX,%,%H,%I,RXF
     89 S:$P(^PSRX(RX,2),"^",15)&($G(ST)'="C") $P(^PSRX(RX,2),"^",14)=1
     90 Q
     91VALID ;check for rx in label array
     92 I $O(PSORX("PSOL",0)) D
     93 .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  I PSORX("PSOL",PSOX1)[RX_"," S QFLG=1 Q
     94 Q
     95ULR ;
     96 I $G(PSORPSRX) D PSOUL^PSSLOCK(PSORPSRX)
     97 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRP2.m

    r613 r623  
    1 PSORXRP2        ;BIR/SAB-main menu entry reprint of a Rx label ;7:37 AM  31 Dec 2008
    2         ;;7.0;OUTPATIENT PHARMACY;**11,27,120,138,135,156,185,280,208**;DEC 1997;Build 41;WorldVistA 30-Jan-08
    3         ;
    4         ;Modified from FOIA VISTA,
    5         ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    6         ;General Public License See attached copy of the License.
    7         ;
    8         ;This program is free software; you can redistribute it and/or modify
    9         ;it under the terms of the GNU General Public License as published by
    10         ;the Free Software Foundation; either version 2 of the License, or
    11         ;(at your option) any later version.
    12         ;
    13         ;This program is distributed in the hope that it will be useful,
    14         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    15         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    16         ;GNU General Public License for more details.
    17         ;
    18         ;You should have received a copy of the GNU General Public License along
    19         ;with this program; if not, write to the Free Software Foundation, Inc.,
    20         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    21         ;
    22         ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
    23         ;External reference ^PS(55 supported by DBIA 2228
    24         ;External reference to ^PSDRUG supported by DBIA 221
    25         I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) G KILL
    26 LRP     N PSODISP
    27         K REPRINT W !! S DIC("S")="I $P($G(^(0)),""^"",2),$D(^(""STA"")),$P($G(^(""STA"")),""^"")<10",DIC="^PSRX(",DIC("A")="Reprint Prescription Label: ",DIC(0)="QEAZ" D ^DIC K P,DIC("A") I Y<0!("^"[X) K PCOM,PCOMX G KILL
    28         S (PPL,DA,RX,PSORPRX)=+Y,PDA=Y(0),RXF=0,ZD(DA)=DT,REPRINT=1,STA=+$G(^PSRX(+Y,"STA"))
    29         D PSOL^PSSLOCK(PSORPRX) I '$G(PSOMSG) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),! K PSOMSG G LRP
    30         ;WVEHR ;begin p208
    31         S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
    32         D ^DIC K DIC ;vfah
    33         S PSOZAF=+Y ;vfah
    34         I $P(^PSRX(RX,"OR1"),"^",5)=$G(PSOZAF) W $C(7),!,"Cannot Reprint Labels for Autofinished Rxs" D ULR,KILL Q  ;vfah
    35         ;WVEHR ;end p208
    36         I $P(^PSRX(RX,"STA"),"^")=14 W $C(7),!,"Cannot Reprint! Discontinued by Provider." D ULR,KILL Q
    37         I $P(^PSRX(RX,"STA"),"^")=15 W $C(7),!,"Cannot Reprint! Discontinued due to editing." D ULR,KILL Q
    38         I $P(^PSRX(RX,"STA"),"^")=16 W $C(7),!,"Cannot Reprint! Placed on HOLD by Provider." D ULR,KILL Q
    39         I DT>$P(^PSRX(RX,2),"^",6) D  D ULR,KILL G LRP
    40         .W !,$C(7),"Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 D
    41         ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM) K COMM
    42         S DFN=$P(PDA,"^",2) D DEM^VADPT I $P(VADM(6),"^",2)]"" D  G LRP
    43         .W $C(7),!!,$P(^DPT($P(PDA,"^",2),0),"^")_" Died "_$P(VADM(6),"^",2)_".",!
    44         .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A")
    45         .D ACT1,ULR,KILL
    46         S X=$O(^PS(52.5,"B",DA,0)) I X,'$G(^PS(52.5,X,"P")) W !,$C(7),"Rx may NOT be printed using this option, use SUSPENSE FUNCTIONS Options." K X D ULR,KILL G LRP
    47         I $G(X)'>0 G GOOD
    48         S XX=$P($G(^PS(52.5,X,0)),U,7) I $G(XX)']"" G GOOD
    49         I $G(XX)="Q" W !,"RX CAN NOT BE PRINTED using this option, use SUSPENSE FUNCTIONS Options." K X,XX D ULR,KILL G LRP
    50         I $G(XX)="L" W !,"RX is being transmitted to the CMOP and can not be reprinted now." K X,XX D ULR,KILL G LRP
    51 GOOD    K X
    52         I $D(^PS(52.4,DA)) W !,"Prescription is Non-Verified",!! D ULR,KILL G LRP
    53         S DFN=$P(^PSRX(DA,0),"^",2) I $D(^PS(52.4,"AREF",DFN,DA)) W !,"Prescription is waiting for others to be verified",!! D ULR,KILL G LRP
    54         I $G(PSODIV),$D(^PSRX(DA,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=DA D CHK1^PSOUTLA I PSPOP D ULR,KILL G LRP
    55         I STA=3 W !?3,"Prescription is on Hold" D ULR,KILL G LRP
    56         I STA=4 W !?3,"Prescription is Pending Due to Drug Interactions" D ULR,KILL G LRP
    57         I STA=12 W !?3,"Prescription is Discontinued" D ULR,KILL G LRP
    58         I $G(^PS(55,"ASTALK",DFN)) W !,"Patient is a ScripTalk patient. Use ScripTalk label for prescription bottle.",!
    59         D ICN^PSODPT(DFN)
    60         S COPIES=$S($P(PDA,"^",18)]"":$P(PDA,"^",18),1:1)
    61         K DIR S DIR("A")="Number of Copies? ",DIR("B")=COPIES,DIR(0)="N^1:99:0",DIR("?")="Enter the number of copies you want (1 TO 99)"
    62         D ^DIR K DIR I $D(DIRUT) D ULR,KILL G LRP
    63         S COPIES=Y
    64         K DIR S DIR("A")="Print adhesive portion of label only? ",DIR(0)="Y",DIR("B")="No",DIR("?",1)="If entire label, including trailers are to print press RETURN for default."
    65         S DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES." D ^DIR K DIR I $D(DUOUT) D ULR,KILL G LRP
    66         I $D(DIRUT) D ULR G KILL
    67         S SIDE=Y
    68         I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D
    69         .I $S($P(PSOPAR,"^",30)=3:1,$P(PSOPAR,"^",30)=4:1,1:0),'$$GET1^DIQ(50,$P(PDA,"^",6),28,"I") Q
    70         .K DIR,DIRUT S DIR("A")="Do you want to resend to Dispensing System Device",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR Q:$D(DIRUT)  S PSODISP=$S(Y:0,1:1)
    71         I $D(DIRUT) D ULR,KILL G LRP
    72         D ACT I $D(DIRUT) D ULR,KILL G LRP
    73         I $D(PCOM) D ULR,KILL G LRP
    74         F I=1,2,4,6,7,9,13,16 S P(I)=$P(PDA,"^",I)
    75         S P(6)=+P(6) I $D(^PSRX(DA,"TN")),^("TN")]"" S P(6)=^("TN")
    76         W !!,"Rx # "_P(1),?23,$E(P(13),4,5)_"/"_$E(P(13),6,7)_"/"_$E(P(13),2,3),!,$S($D(^DPT(+P(2),0)):$P(^(0),"^"),1:"Not on File"),?30,"#"_P(7),!
    77         I $P($G(^PSRX(DA,"SIG")),"^",2) S D=0 D  K D,FSIG
    78         .D FSIG^PSOUTLA("R",DA,75) F  S D=$O(FSIG(D)) W !,FSIG(D) Q:'$O(FSIG(D))
    79         E  D EN3^PSOUTLA1(DA,75) S D=0 F  S D=$O(BSIG(D)) W !,BSIG(D) Q:'$O(BSIG(D))
    80         K D,BSIG
    81         ;PSO*7*280 If Trade name, don't lookup in ^PSDRUG
    82         W !!,$S($G(^PSRX(DA,"TN"))]"":P(6),(P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! S PHYS=$S($D(^VA(200,+P(4),0)):$P(^(0),"^"),1:"Unknown") W PHYS K PHYS
    83         W ?25,$S($D(^VA(200,+P(16),0)):$P(^(0),"^"),1:"Unknown"),!,"# of Refills: "_$G(P(9))
    84         I $G(RX) D
    85         .S RXRP(RX)=1_"^"_COPIES_"^"_SIDE
    86         .I $G(PSODISP)=1 S RXRP(RX,"RP")=1
    87         .S RXFL(RX)=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(RX,1,ZZZ)) Q:'ZZZ  S RXFL(RX)=ZZZ
    88         D @$S($P($G(PSOPAR),"^",26):"^PSORXL",1:"Q^PSORXL") K PSPOP,PPL,COPIES,SIDE,REPRINT,PCOM,IOP,PSL,PSNP,ZZZ,RXFL(+$G(RX)) D ULR,KILL G LRP
    89         ;
    90 ACT     K DIR S DIR("A")="Comments: ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX)
    91         D ^DIR K DIR Q:$D(DIRUT)!($D(DIROUT))  S (PCOM,PCOMX)=X
    92         I '$D(PSOCLC) S PSOCLC=DUZ
    93 ACT1    S RXF=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J  S RXF=J S:J>5 RXF=J+1
    94         S IR=0 F J=0:0 S J=$O(^PSRX(DA,"A",J)) Q:'J  S IR=J
    95         S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
    96         D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,PCOM,XX,%,%H,%I,RXF
    97         S:$P(^PSRX(DA,2),"^",15)&($G(ST)'="C") $P(^PSRX(DA,2),"^",14)=1
    98         Q
    99         ;
    100 KILL    K %,DIR,DUOUT,DTOUT,DIROUT,DIRUT,C,DA,DIC,I,J,JJJ,K,RX,RXF,X,Y,Z,ZD,DFN,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSXSTAT,PSORPRX,PSOMSG D KVA^VADPT Q
    101         ;
    102 ULR     ;
    103         I $G(PSORPRX) D PSOUL^PSSLOCK(PSORPRX)
    104         Q
     1PSORXRP2 ;BIR/SAB-main menu entry reprint of a Rx label ; 12/10/06 9:51pm
     2 ;;7.0;OUTPATIENT PHARMACY;**11,27,120,138,135,156,185,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
     20 ;External reference ^PS(55 supported by DBIA 2228
     21 ;External reference to ^PSDRUG supported by DBIA 221
     22 I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) G KILL
     23LRP N PSODISP
     24 K REPRINT W !! S DIC("S")="I $P($G(^(0)),""^"",2),$D(^(""STA"")),$P($G(^(""STA"")),""^"")<10",DIC="^PSRX(",DIC("A")="Reprint Prescription Label: ",DIC(0)="QEAZ" D ^DIC K P,DIC("A") I Y<0!("^"[X) K PCOM,PCOMX G KILL
     25 S (PPL,DA,RX,PSORPRX)=+Y,PDA=Y(0),RXF=0,ZD(DA)=DT,REPRINT=1,STA=+$G(^PSRX(+Y,"STA"))
     26 D PSOL^PSSLOCK(PSORPRX) I '$G(PSOMSG) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),! K PSOMSG G LRP
     27 S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
     28 D ^DIC K DIC ;vfah
     29 S PSOZAF=+Y ;vfah
     30 I $P(^PSRX(RX,"OR1"),"^",5)=$G(PSOZAF) W $C(7),!,"Cannot Reprint Labels for Autofinished Rxs" D ULR,KILL Q  ;vfah
     31 I $P(^PSRX(RX,"STA"),"^")=14 W $C(7),!,"Cannot Reprint! Discontinued by Provider." D ULR,KILL Q
     32 I $P(^PSRX(RX,"STA"),"^")=15 W $C(7),!,"Cannot Reprint! Discontinued due to editing." D ULR,KILL Q
     33 I $P(^PSRX(RX,"STA"),"^")=16 W $C(7),!,"Cannot Reprint! Placed on HOLD by Provider." D ULR,KILL Q
     34 I DT>$P(^PSRX(RX,2),"^",6) D  D ULR,KILL G LRP
     35 .W !,$C(7),"Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 D
     36 ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM) K COMM
     37 S DFN=$P(PDA,"^",2) D DEM^VADPT I $P(VADM(6),"^",2)]"" D  G LRP
     38 .W $C(7),!!,$P(^DPT($P(PDA,"^",2),0),"^")_" Died "_$P(VADM(6),"^",2)_".",!
     39 .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A")
     40 .D ACT1,ULR,KILL
     41 S X=$O(^PS(52.5,"B",DA,0)) I X,'$G(^PS(52.5,X,"P")) W !,$C(7),"Rx may NOT be printed using this option, use SUSPENSE FUNCTIONS Options." K X D ULR,KILL G LRP
     42 I $G(X)'>0 G GOOD
     43 S XX=$P($G(^PS(52.5,X,0)),U,7) I $G(XX)']"" G GOOD
     44 I $G(XX)="Q" W !,"RX CAN NOT BE PRINTED using this option, use SUSPENSE FUNCTIONS Options." K X,XX D ULR,KILL G LRP
     45 I $G(XX)="L" W !,"RX is being transmitted to the CMOP and can not be reprinted now." K X,XX D ULR,KILL G LRP
     46GOOD K X
     47 I $D(^PS(52.4,DA)) W !,"Prescription is Non-Verified",!! D ULR,KILL G LRP
     48 S DFN=$P(^PSRX(DA,0),"^",2) I $D(^PS(52.4,"AREF",DFN,DA)) W !,"Prescription is waiting for others to be verified",!! D ULR,KILL G LRP
     49 I $G(PSODIV),$D(^PSRX(DA,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=DA D CHK1^PSOUTLA I PSPOP D ULR,KILL G LRP
     50 I STA=3 W !?3,"Prescription is on Hold" D ULR,KILL G LRP
     51 I STA=4 W !?3,"Prescription is Pending Due to Drug Interactions" D ULR,KILL G LRP
     52 I STA=12 W !?3,"Prescription is Discontinued" D ULR,KILL G LRP
     53 I $G(^PS(55,"ASTALK",DFN)) W !,"Patient is a ScripTalk patient. Use ScripTalk label for prescription bottle.",!
     54 D ICN^PSODPT(DFN)
     55 S COPIES=$S($P(PDA,"^",18)]"":$P(PDA,"^",18),1:1)
     56 K DIR S DIR("A")="Number of Copies? ",DIR("B")=COPIES,DIR(0)="N^1:99:0",DIR("?")="Enter the number of copies you want (1 TO 99)"
     57 D ^DIR K DIR I $D(DIRUT) D ULR,KILL G LRP
     58 S COPIES=Y
     59 K DIR S DIR("A")="Print adhesive portion of label only? ",DIR(0)="Y",DIR("B")="No",DIR("?",1)="If entire label, including trailers are to print press RETURN for default."
     60 S DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES." D ^DIR K DIR I $D(DUOUT) D ULR,KILL G LRP
     61 I $D(DIRUT) D ULR G KILL
     62 S SIDE=Y
     63 I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D
     64 .I $S($P(PSOPAR,"^",30)=3:1,$P(PSOPAR,"^",30)=4:1,1:0),'$$GET1^DIQ(50,$P(PDA,"^",6),28,"I") Q
     65 .K DIR,DIRUT S DIR("A")="Do you want to resend to Dispensing System Device",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR Q:$D(DIRUT)  S PSODISP=$S(Y:0,1:1)
     66 I $D(DIRUT) D ULR,KILL G LRP
     67 D ACT I $D(DIRUT) D ULR,KILL G LRP
     68 I $D(PCOM) D ULR,KILL G LRP
     69 F I=1,2,4,6,7,9,13,16 S P(I)=$P(PDA,"^",I)
     70 S P(6)=+P(6) I $D(^PSRX(DA,"TN")),^("TN")]"" S P(6)=^("TN")
     71 W !!,"Rx # "_P(1),?23,$E(P(13),4,5)_"/"_$E(P(13),6,7)_"/"_$E(P(13),2,3),!,$S($D(^DPT(+P(2),0)):$P(^(0),"^"),1:"Not on File"),?30,"#"_P(7),!
     72 I $P($G(^PSRX(DA,"SIG")),"^",2) S D=0 D  K D,FSIG
     73 .D FSIG^PSOUTLA("R",DA,75) F  S D=$O(FSIG(D)) W !,FSIG(D) Q:'$O(FSIG(D))
     74 E  D EN3^PSOUTLA1(DA,75) S D=0 F  S D=$O(BSIG(D)) W !,BSIG(D) Q:'$O(BSIG(D))
     75 K D,BSIG
     76 W !!,$S((P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! S PHYS=$S($D(^VA(200,+P(4),0)):$P(^(0),"^"),1:"Unknown") W PHYS K PHYS
     77 W ?25,$S($D(^VA(200,+P(16),0)):$P(^(0),"^"),1:"Unknown"),!,"# of Refills: "_$G(P(9))
     78 I $G(RX) D
     79 .S RXRP(RX)=1_"^"_COPIES_"^"_SIDE
     80 .I $G(PSODISP)=1 S RXRP(RX,"RP")=1
     81 .S RXFL(RX)=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(RX,1,ZZZ)) Q:'ZZZ  S RXFL(RX)=ZZZ
     82 D @$S($P($G(PSOPAR),"^",26):"^PSORXL",1:"Q^PSORXL") K PSPOP,PPL,COPIES,SIDE,REPRINT,PCOM,IOP,PSL,PSNP,ZZZ,RXFL(+$G(RX)) D ULR,KILL G LRP
     83 ;
     84ACT K DIR S DIR("A")="Comments: ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX)
     85 D ^DIR K DIR Q:$D(DIRUT)!($D(DIROUT))  S (PCOM,PCOMX)=X
     86 I '$D(PSOCLC) S PSOCLC=DUZ
     87ACT1 S RXF=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J  S RXF=J S:J>5 RXF=J+1
     88 S IR=0 F J=0:0 S J=$O(^PSRX(DA,"A",J)) Q:'J  S IR=J
     89 S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
     90 D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,PCOM,XX,%,%H,%I,RXF
     91 S:$P(^PSRX(DA,2),"^",15)&($G(ST)'="C") $P(^PSRX(DA,2),"^",14)=1
     92 Q
     93 ;
     94KILL K %,DIR,DUOUT,DTOUT,DIROUT,DIRUT,C,DA,DIC,I,J,JJJ,K,RX,RXF,X,Y,Z,ZD,DFN,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSXSTAT,PSORPRX,PSOMSG D KVA^VADPT Q
     95 ;
     96ULR ;
     97 I $G(PSORPRX) D PSOUL^PSSLOCK(PSORPRX)
     98 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRPT.m

    r613 r623  
    1 PSORXRPT        ;BIR/SAB-reprint of a prescription label ;7:48 AM  31 Dec 2008
    2         ;;7.0;OUTPATIENT PHARMACY;**3,21,27,34,120,138,156,148,280,208**;DEC 1997;Build 41;WorldVistA 30-Jan-08
    3         ;
    4         ;Modified from FOIA VISTA,
    5         ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    6         ;General Public License See attached copy of the License.
    7         ;
    8         ;This program is free software; you can redistribute it and/or modify
    9         ;it under the terms of the GNU General Public License as published by
    10         ;the Free Software Foundation; either version 2 of the License, or
    11         ;(at your option) any later version.
    12         ;
    13         ;This program is distributed in the hope that it will be useful,
    14         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    15         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    16         ;GNU General Public License for more details.
    17         ;
    18         ;You should have received a copy of the GNU General Public License along
    19         ;with this program; if not, write to the Free Software Foundation, Inc.,
    20         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    21         ;
    22         ;External reference to ^PSDRUG supported by DBIA 221
    23         ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
    24 BCK     I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q
    25         N PSODISP S PSORPLRX=$P(PSOLST(ORN),"^",2)
    26         I $$LMREJ^PSOREJU1(PSORPLRX,,.VALMSG,.VALMBCK) Q
    27         D PSOL^PSSLOCK(PSORPLRX) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG Q
    28         I $G(POERR) K QFLG D  I $G(QFLG) D ULR G KILL
    29         .D FULL^VALM1 S X=$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),Y=$P(PSOLST(ORN),"^",2)_"^"_X,Y(0)=$G(^PSRX($P(PSOLST(ORN),"^",2),0))
    30         .I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial Rx has been requested!",QFLG=1 Q
    31         .I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!",QFLG=1 Q
    32         .I $D(RXRS($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="Rx is being pulled from suspense!",QFLG=1 Q
    33         .S RX=$P(PSOLST(ORN),"^",2) D VALID^PSORXRP1 S:$G(QFLG) VALMBCK="",VALMSG="A New Label has been requested already!"
    34         S (PPL,DA,RX)=+Y,PDA=Y(0),RXF=0,ZD(DA)=DT,REPRINT=1,STA=+$G(^PSRX(+Y,"STA"))
    35         ;WVERH ;begin p208
    36         ;
    37         S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
    38         D ^DIC K DIC ;vfah
    39         S PSOZAF=+Y ;vfah
    40         I $P($G(^PSRX(RX,"OR1")),"^",5)=$G(PSOZAF) S VALMBCK="",VALMSG="This reprint option is not available for Autofinshed Rxs",QFLG=1 K PSOZAF D ULR,KILL Q  ;vfah
    41         ;WVEHR ;end p208
    42         ;
    43         I $P(^PSRX(RX,"STA"),"^")=14 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued by Provider.",QFLG=1 D ULR,KILL Q
    44         I $P(^PSRX(RX,"STA"),"^")=15 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued due to editing.",QFLG=1 D ULR,KILL Q
    45         I $P(^PSRX(RX,"STA"),"^")=16 S VALMBCK="",VALMSG="Cannot Reprint! Placed on HOLD by Provider.",QFLG=1 D ULR,KILL Q
    46         I DT>$P(^PSRX(RX,2),"^",6) D  G PAUSE
    47         .W !,$C(7),"Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 D
    48         ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM) K COMM
    49         S DFN=$P(PDA,"^",2) D DEM^VADPT I $P(VADM(6),"^",2)]"" D  G PAUSE
    50         .W $C(7),!!,$P(^DPT($P(PDA,"^",2),0),"^")_" Died "_$P(VADM(6),"^",2)_".",!
    51         .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A")
    52         .D ACT1,ULR,KILL
    53         S X=$O(^PS(52.5,"B",DA,0)) I X,'$G(^PS(52.5,X,"P")) W !,$C(7),"RX MAY NOT BE PRINTED using this option, use SUSPENSE FUNCTIONS Options." K X G PAUSE
    54         S PSX=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J  S PSX=J
    55         K X
    56         I $D(^PS(52.4,DA)) W !,"Prescription is Non-Verified",!! G PAUSE
    57         S DFN=$P(^PSRX(DA,0),"^",2) I $D(^PS(52.4,"AREF",DFN,DA)) W !,"Prescription is waiting for others to be verified",!! G PAUSE
    58         I $G(PSODIV),$D(^PSRX(DA,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=DA D CHK1^PSOUTLA G:$G(POERR)&(PSPOP) PAUSE G:PSPOP PAUSE
    59         I STA=3 W !?3,"Prescription is on Hold" G PAUSE
    60         I STA=4 W !?3,"Prescription is Pending Due to Drug Interactions" G PAUSE
    61         I STA=12 W !?3,"Prescription is Discontinued" G PAUSE
    62         S COPIES=$S($P(PDA,"^",18)]"":$P(PDA,"^",18),1:1)
    63         K DIR S DIR("A")="Number of Copies? ",DIR("B")=COPIES,DIR(0)="N^1:99:0",DIR("?")="Enter the number of copies you want (1 to 99)"
    64         D ^DIR K DIR I $D(DIRUT) D ULR G KILL
    65         S COPIES=Y
    66         K DIR S DIR("A")="Print adhesive portion of label only? ",DIR(0)="Y",DIR("B")="No",DIR("?",1)="If entire label, including trailers are to print press RETURN for default."
    67         S DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES." D ^DIR K DIR I $D(DUOUT) D ULR,KILL G PAUSE
    68         I $D(DIRUT) D ULR G KILL
    69         S SIDE=Y
    70         I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D
    71         .I $S($P(PSOPAR,"^",30)=3:1,$P(PSOPAR,"^",30)=4:1,1:0),'$$GET1^DIQ(50,$P(PDA,"^",6),28,"I") Q
    72         .K DIR,DIRUT S DIR("A")="Do you want to resend to Dispensing System Device",DIR(0)="Y",DIR("B")="No"
    73         .D ^DIR K DIR Q:$D(DIRUT)  S PSODISP=$S(Y:0,1:1)
    74         I $D(DIRUT) D ULR G KILL
    75         D ACT I $D(DIRUT) D ULR,KILL G PAUSE
    76         Q:$G(POERR)&($D(PCOM))  G PAUSE:$D(PCOM)
    77         F I=1,2,4,6,7,9,13,16 S P(I)=$P(PDA,"^",I)
    78         S P(6)=+P(6) I $D(^PSRX(DA,"TN")),^("TN")]"" S P(6)=^("TN")
    79         W !!,"Rx # "_P(1),?23,$E(P(13),4,5)_"/"_$E(P(13),6,7)_"/"_$E(P(13),2,3),!,$S($D(^DPT(+P(2),0)):$P(^(0),"^"),1:"Not on File"),?30,"#"_P(7),!
    80         I $P($G(^PSRX(DA,"SIG")),"^",2) S D=0 D  K D,FSIG
    81         .D FSIG^PSOUTLA("R",DA,75) F  S D=$O(FSIG(D)) W !,FSIG(D) Q:'$O(FSIG(D))
    82         E  D EN3^PSOUTLA1(DA,75) S D=0 F  S D=$O(BSIG(D)) W !,BSIG(D) Q:'$O(BSIG(D))
    83         K D,BSIG
    84         ;PSO*7*280 If trade name is used Stop the DRUG Lookup.
    85         W !!,$S($G(^PSRX(DA,"TN"))]"":P(6),(P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! S PHYS=$S($D(^VA(200,+P(4),0)):$P(^(0),"^"),1:"Unknown") W PHYS K PHYS
    86         W ?25,$S($D(^VA(200,+P(16),0)):$P(^(0),"^"),1:"Unknown"),!,"# of Refills: "_$G(P(9))
    87         I $G(RX) S RXFL(RX)=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(RX,1,ZZZ)) Q:'ZZZ  S RXFL(RX)=ZZZ
    88         K PSOELSE I '$G(POERR) S PSOELSE=1 D @$S($P($G(PSOPAR),"^",26):"^PSORXL",1:"Q^PSORXL")
    89         I '$G(PSOELSE) D
    90         .S RXRP($P(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE
    91         .I $G(PSODISP)=1 S RXRP($P(PSOLST(ORN),"^",2),"RP")=1
    92         .I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=DA_"," Q
    93         .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
    94         .I $L(PSORX("PSOL",PSOX2))+$L(DA)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_DA_","
    95         .E  S PSORX("PSOL",PSOX2+1)=DA_","
    96         K PCOMX,PSPOP,PPL,COPIES,SIDE,PCOM,IOP,PSL,PSNP,PSOELSE,ZZZ
    97 PAUSE   K RX,PPL,ZD(+$G(DA)),DA I $G(POERR) K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E",DIR("A",1)=" ",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DUOUT,DTOUT S VALMBCK="R"
    98         D ULR K PSORPLRX
    99         Q
    100         ;
    101 ACT     K DIR S DIR("A")="Comments: ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX)
    102         D ^DIR K DIR Q:$D(DIRUT)!($D(DIROUT))  S (PCOM,PCOMX)=X
    103         I '$D(PSOCLC) S PSOCLC=DUZ
    104 ACT1    S RXF=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J  S RXF=J S:J>5 RXF=J+1
    105         S IR=0 F J=0:0 S J=$O(^PSRX(DA,"A",J)) Q:'J  S IR=J
    106         S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
    107         D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,PCOM,XX,%,%H,%I,RXF
    108         S:$P(^PSRX(DA,2),"^",15)&($G(ST)'="C") $P(^PSRX(DA,2),"^",14)=1
    109         Q
    110         ;
    111 KILL    K QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,DA,DIC,I,J,JJJ,K,RX,RXF,X,Y,Z,DFN,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSOMSG,PSORPLRX D KVA^VADPT Q
    112         ;
    113 ULR     ;
    114         I $G(PSORPLRX) D PSOUL^PSSLOCK(PSORPLRX)
    115         Q
     1PSORXRPT ;BIR/SAB-reprint of a prescription label ; 12/10/06 8:42pm
     2 ;;7.0;OUTPATIENT PHARMACY;**3,21,27,34,120,138,156,148,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 ;External reference to ^PSDRUG supported by DBIA 221
     20 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
     21BCK I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q
     22 N PSODISP S PSORPLRX=$P(PSOLST(ORN),"^",2)
     23 I $$LMREJ^PSOREJU1(PSORPLRX,,.VALMSG,.VALMBCK) Q
     24 D PSOL^PSSLOCK(PSORPLRX) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG Q
     25 I $G(POERR) K QFLG D  I $G(QFLG) D ULR G KILL
     26 .D FULL^VALM1 S X=$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),Y=$P(PSOLST(ORN),"^",2)_"^"_X,Y(0)=$G(^PSRX($P(PSOLST(ORN),"^",2),0))
     27 .I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial Rx has been requested!",QFLG=1 Q
     28 .I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!",QFLG=1 Q
     29 .I $D(RXRS($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="Rx is being pulled from suspense!",QFLG=1 Q
     30 .S RX=$P(PSOLST(ORN),"^",2) D VALID^PSORXRP1 S:$G(QFLG) VALMBCK="",VALMSG="A New Label has been requested already!"
     31 S (PPL,DA,RX)=+Y,PDA=Y(0),RXF=0,ZD(DA)=DT,REPRINT=1,STA=+$G(^PSRX(+Y,"STA"))
     32 ;
     33 S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
     34 D ^DIC K DIC ;vfah
     35 S PSOZAF=+Y ;vfah
     36 I $P($G(^PSRX(RX,"OR1")),"^",5)=$G(PSOZAF) S VALMBCK="",VALMSG="This reprint option is not available for Autofinshed Rxs",QFLG=1 K PSOZAF D ULR,KILL Q  ;vfah
     37 ;
     38 I $P(^PSRX(RX,"STA"),"^")=14 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued by Provider.",QFLG=1 D ULR,KILL Q
     39 I $P(^PSRX(RX,"STA"),"^")=15 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued due to editing.",QFLG=1 D ULR,KILL Q
     40 I $P(^PSRX(RX,"STA"),"^")=16 S VALMBCK="",VALMSG="Cannot Reprint! Placed on HOLD by Provider.",QFLG=1 D ULR,KILL Q
     41 I DT>$P(^PSRX(RX,2),"^",6) D  G PAUSE
     42 .W !,$C(7),"Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 D
     43 ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM) K COMM
     44 S DFN=$P(PDA,"^",2) D DEM^VADPT I $P(VADM(6),"^",2)]"" D  G PAUSE
     45 .W $C(7),!!,$P(^DPT($P(PDA,"^",2),0),"^")_" Died "_$P(VADM(6),"^",2)_".",!
     46 .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A")
     47 .D ACT1,ULR,KILL
     48 S X=$O(^PS(52.5,"B",DA,0)) I X,'$G(^PS(52.5,X,"P")) W !,$C(7),"RX MAY NOT BE PRINTED using this option, use SUSPENSE FUNCTIONS Options." K X G PAUSE
     49 S PSX=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J  S PSX=J
     50 K X
     51 I $D(^PS(52.4,DA)) W !,"Prescription is Non-Verified",!! G PAUSE
     52 S DFN=$P(^PSRX(DA,0),"^",2) I $D(^PS(52.4,"AREF",DFN,DA)) W !,"Prescription is waiting for others to be verified",!! G PAUSE
     53 I $G(PSODIV),$D(^PSRX(DA,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=DA D CHK1^PSOUTLA G:$G(POERR)&(PSPOP) PAUSE G:PSPOP PAUSE
     54 I STA=3 W !?3,"Prescription is on Hold" G PAUSE
     55 I STA=4 W !?3,"Prescription is Pending Due to Drug Interactions" G PAUSE
     56 I STA=12 W !?3,"Prescription is Discontinued" G PAUSE
     57 S COPIES=$S($P(PDA,"^",18)]"":$P(PDA,"^",18),1:1)
     58 K DIR S DIR("A")="Number of Copies? ",DIR("B")=COPIES,DIR(0)="N^1:99:0",DIR("?")="Enter the number of copies you want (1 to 99)"
     59 D ^DIR K DIR I $D(DIRUT) D ULR G KILL
     60 S COPIES=Y
     61 K DIR S DIR("A")="Print adhesive portion of label only? ",DIR(0)="Y",DIR("B")="No",DIR("?",1)="If entire label, including trailers are to print press RETURN for default."
     62 S DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES." D ^DIR K DIR I $D(DUOUT) D ULR,KILL G PAUSE
     63 I $D(DIRUT) D ULR G KILL
     64 S SIDE=Y
     65 I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D
     66 .I $S($P(PSOPAR,"^",30)=3:1,$P(PSOPAR,"^",30)=4:1,1:0),'$$GET1^DIQ(50,$P(PDA,"^",6),28,"I") Q
     67 .K DIR,DIRUT S DIR("A")="Do you want to resend to Dispensing System Device",DIR(0)="Y",DIR("B")="No"
     68 .D ^DIR K DIR Q:$D(DIRUT)  S PSODISP=$S(Y:0,1:1)
     69 I $D(DIRUT) D ULR G KILL
     70 D ACT I $D(DIRUT) D ULR,KILL G PAUSE
     71 Q:$G(POERR)&($D(PCOM))  G PAUSE:$D(PCOM)
     72 F I=1,2,4,6,7,9,13,16 S P(I)=$P(PDA,"^",I)
     73 S P(6)=+P(6) I $D(^PSRX(DA,"TN")),^("TN")]"" S P(6)=^("TN")
     74 W !!,"Rx # "_P(1),?23,$E(P(13),4,5)_"/"_$E(P(13),6,7)_"/"_$E(P(13),2,3),!,$S($D(^DPT(+P(2),0)):$P(^(0),"^"),1:"Not on File"),?30,"#"_P(7),!
     75 I $P($G(^PSRX(DA,"SIG")),"^",2) S D=0 D  K D,FSIG
     76 .D FSIG^PSOUTLA("R",DA,75) F  S D=$O(FSIG(D)) W !,FSIG(D) Q:'$O(FSIG(D))
     77 E  D EN3^PSOUTLA1(DA,75) S D=0 F  S D=$O(BSIG(D)) W !,BSIG(D) Q:'$O(BSIG(D))
     78 K D,BSIG
     79 W !!,$S((P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! S PHYS=$S($D(^VA(200,+P(4),0)):$P(^(0),"^"),1:"Unknown") W PHYS K PHYS
     80 W ?25,$S($D(^VA(200,+P(16),0)):$P(^(0),"^"),1:"Unknown"),!,"# of Refills: "_$G(P(9))
     81 I $G(RX) S RXFL(RX)=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(RX,1,ZZZ)) Q:'ZZZ  S RXFL(RX)=ZZZ
     82 K PSOELSE I '$G(POERR) S PSOELSE=1 D @$S($P($G(PSOPAR),"^",26):"^PSORXL",1:"Q^PSORXL")
     83 I '$G(PSOELSE) D
     84 .S RXRP($P(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE
     85 .I $G(PSODISP)=1 S RXRP($P(PSOLST(ORN),"^",2),"RP")=1
     86 .I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=DA_"," Q
     87 .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
     88 .I $L(PSORX("PSOL",PSOX2))+$L(DA)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_DA_","
     89 .E  S PSORX("PSOL",PSOX2+1)=DA_","
     90 K PCOMX,PSPOP,PPL,COPIES,SIDE,PCOM,IOP,PSL,PSNP,PSOELSE,ZZZ
     91PAUSE K RX,PPL,ZD(+$G(DA)),DA I $G(POERR) K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E",DIR("A",1)=" ",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DUOUT,DTOUT S VALMBCK="R"
     92 D ULR K PSORPLRX
     93 Q
     94 ;
     95ACT K DIR S DIR("A")="Comments: ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX)
     96 D ^DIR K DIR Q:$D(DIRUT)!($D(DIROUT))  S (PCOM,PCOMX)=X
     97 I '$D(PSOCLC) S PSOCLC=DUZ
     98ACT1 S RXF=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J  S RXF=J S:J>5 RXF=J+1
     99 S IR=0 F J=0:0 S J=$O(^PSRX(DA,"A",J)) Q:'J  S IR=J
     100 S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
     101 D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,PCOM,XX,%,%H,%I,RXF
     102 S:$P(^PSRX(DA,2),"^",15)&($G(ST)'="C") $P(^PSRX(DA,2),"^",14)=1
     103 Q
     104 ;
     105KILL K QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,DA,DIC,I,J,JJJ,K,RX,RXF,X,Y,Z,DFN,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSOMSG,PSORPLRX D KVA^VADPT Q
     106 ;
     107ULR ;
     108 I $G(PSORPLRX) D PSOUL^PSSLOCK(PSORPLRX)
     109 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXVW.m

    r613 r623  
    1 PSORXVW ;BHAM ISC/SAB - listman view of a prescription ;5/25/05 2:10pm
    2         ;;7.0;OUTPATIENT PHARMACY;**14,35,46,96,103,88,117,131,146,156,185,210,148,233,260,264,281**;DEC 1997;Build 41
    3         ;External reference to File ^PS(55 supported by DBIA 2228
    4         ;External reference to ^PS(50.7 supported by DBIA 2223
    5         ;External reference ^PSDRUG( supported by DBIA 221
    6         ;External reference to ^VA(200 supported by DBIA 10060
    7         ;External reference to ^SC supported by DBIA 10040
    8         ;External reference to ^DPT supported by DBIA 10035
    9         ;External reference to ^PS(50.606 supported by DBIA 2174
    10         ;External reference to GMRADPT supported by DBIA 10099
    11         ;
    12         S PS="VIEW"
    13 A1      ; - Prescription prompt
    14         S DIR(0)="FAO^1:30",DIR("A")=PS_" PRESCRIPTION: ",(DIR("?"),DIR("??"))="^D HLP^PSORXVW1"
    15         W ! D ^DIR I X=""!$D(DIRUT) G KILL
    16         S X=$$UP^XLFSTR(X),QUIT=0
    17         I $E(X,1,2)'="E." S (DA,PSOVDA)=+$$LKP^PSORXVW1(X) I DA<0 G A1
    18         I $E(X,1,2)="E." D  I QUIT G A1
    19         . I $L(X)'=9 W !?5,"The ECME# must be 7 digits long!",$C(7) S QUIT=1 Q
    20         . S (DA,PSOVDA)=+$$RXNUM^PSOBPSU2($E(X,3,9)) I DA<0 W " ??" S QUIT=1
    21         ;
    22 DP      S (PSODFN,DFN)=+$P(^PSRX(DA,0),"^",2) S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD
    23         D ICN^PSODPT(PSODFN)
    24         K ^TMP("PSOHDR",$J) D ^VADPT,ADD^VADPT
    25         S ^TMP("PSOHDR",$J,1,0)=VADM(1)
    26         N PSOBADR,PSOTEMP
    27         S PSOBADR=$$BADADR^DGUTL3(DFN) I PSOBADR S PSOTEMP=$$CHKTEMP^PSOBAI(DFN) D
    28         .S ^TMP("PSOHDR",$J,1,0)=^TMP("PSOHDR",$J,1,0)_" ** BAD ADDRESS INDICATED-("_$S(PSOBADR=1:"UNDELIVERABLE",PSOBADR=2:"HOMELESS",1:"OTHER")_")"_$S(PSOTEMP:" Active Temporary Address",1:"")
    29         S ^TMP("PSOHDR",$J,2,0)=$P(VADM(2),"^",2)
    30         S ^TMP("PSOHDR",$J,3,0)=$P(VADM(3),"^",2),^TMP("PSOHDR",$J,4,0)=VADM(4),^TMP("PSOHDR",$J,5,0)=$P(VADM(5),"^",2)
    31         S POERR=1 D RE^PSODEM K PSOERR
    32         S ^TMP("PSOHDR",$J,6,0)=$S(+$P(WT,"^",8):$P(WT,"^",9)_" ("_$P(WT,"^")_")",1:"_______ (______)")
    33         S ^TMP("PSOHDR",$J,7,0)=$S($P(HT,"^",8):$P(HT,"^",9)_" ("_$P(HT,"^")_")",1:"_______ (______)") K VM,WT,HT S PSOHD=7
    34         S GMRA="0^0^111" D EN1^GMRADPT S ^TMP("PSOHDR",$J,8,0)=+$G(GMRAL)
    35         D DEM^VADPT I +VADM(6) D
    36         .S SSN=$P(^DPT(PSODFN,0),"^",9) W !,$C(7),?10,$P(^DPT(PSODFN,0),"^")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_") DIED "_$P(VADM(6),"^",2),!
    37         .W "All Active Medications will be Autocanceled!",! H 2 S PSODEATH=1
    38         .S ACOM="Date of Death "_$P(VADM(6),"^",2)_".",ZTRTN="CAN^PSOCAN3",ZTDESC="Outpatient Pharmacy Autocancel Due to Death of Patient",ZTSAVE("ACOM")="",ZTSAVE("PSODFN")="",ZTSAVE("PSODEATH")=""
    39         .S ZTIO="",PSOCLC=DUZ,ZTSAVE("PSOCLC")="",ZTDTH=$H D ^%ZTLOAD K ACOM,ZTSK,PSODEATH
    40         K ^TMP("PSOAL",$J),PCOMX,PDA,PHI,PRC,ACOM,ANS
    41         S (DA,RXN)=PSOVDA K PSOVDA S RX0=^PSRX(RXN,0),RX2=$G(^(2)),RX3=$G(^(3)),ST=+$G(^("STA")),RXOR=$G(^("OR1"))
    42         I 'RXOR,$P(^PSDRUG($P(RX0,"^",6),2),"^") S $P(^PSRX(RXN,"OR1"),"^")=$P(^PSDRUG($P(RX0,"^",6),2),"^"),RXOR=$P(^PSDRUG($P(RX0,"^",6),2),"^")
    43         S IEN=0,$P(RN," ",12)=" "
    44         N APPND S APPND=$S($G(^PSRX(RXN,"IB")):"$",1:"")
    45         I $$ECMENUM^PSOBPSU2(RXN)'="" S APPND=APPND_$$ECME^PSOBPSUT(RXN)_"  (ECME#: "_$$ECMENUM^PSOBPSU2(RXN)_")"
    46         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$S($P($G(^PSRX(RXN,"TPB")),"^"):"            TPB Rx #: ",1:"                Rx #: ")_$P(RX0,"^")_APPND_$E(RN,$L($P(RX0,"^")_APPND)+1,12)
    47         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="      Orderable Item: "_$S($D(^PS(50.7,$P(+RXOR,"^"),0)):$P(^PS(50.7,$P(+RXOR,"^"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^"),1:"No Pharmacy Orderable Item")
    48         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$S($D(^PSDRUG("AQ",$P(RX0,"^",6))):"           CMOP ",1:"                ")_"Drug: "_$P(^PSDRUG($P(RX0,"^",6),0),"^")
    49         S:$G(^PSRX(RXN,"TN"))]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="          Trade Name: "_$G(^PSRX(RXN,"TN"))
    50         I $$STATUS^PSOBPSUT(RXN,0)'="",$$RXRLDT^PSOBPSUT(RXN,0) D
    51         . S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="                 NDC: "_$$GETNDC^PSONDCUT(RXN,0)
    52         D DOSE^PSORXVW1
    53         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Patient Instructions:" I $O(^PSRX(RXN,"INS1",0)) D
    54         . F I=0:0 S I=$O(^PSRX(RXN,"INS1",I)) Q:'I  D
    55         .. S MIG=^PSRX(RXN,"INS1",I,0)
    56         .. D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAL",$J)),21)
    57         K MIG,SG
    58         I $P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="  Other Pat. Instruc: "_$S($G(^PSRX(RXN,"INSS"))]"":^PSRX(RXN,"INSS"),1:"")
    59         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="                 SIG:"
    60         I '$P($G(^PSRX(RXN,"SIG")),"^",2) D  G PTST
    61         . S X=$P($G(^PSRX(RXN,"SIG")),"^") D SIGONE^PSOHELP S SIG=$E($G(INS1),2,250)
    62         . D WORDWRAP^PSOUTLA2(SIG,.IEN,$NA(^TMP("PSOAL",$J)),21)
    63         S SIGOK=1
    64         F I=0:0 S I=$O(^PSRX(RXN,"SIG1",I)) Q:'I  D
    65         . S MIG=^PSRX(RXN,"SIG1",I,0)
    66         . D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAL",$J)),21)
    67         S SIGOK=1 K MIG,SG
    68 PTST    S $P(RN," ",25)=" ",PTST=$S($G(^PS(53,+$P(RX0,"^",3),0))]"":$P($G(^PS(53,+$P(RX0,"^",3),0)),"^"),1:""),IEN=IEN+1
    69         S ^TMP("PSOAL",$J,IEN,0)="      Patient Status: "_PTST_$E(RN,$L(PTST)+1,25)
    70         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="          Issue Date: "_$E($P(RX0,"^",13),4,5)_"/"_$E($P(RX0,"^",13),6,7)_"/"_$E($P(RX0,"^",13),2,3)
    71         S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"                 Fill Date: "_$E($P(RX2,"^",2),4,5)_"/"_$E($P(RX2,"^",2),6,7)_"/"_$E($P(RX2,"^",2),2,3)
    72         S ROU=$S($P(RX0,"^",11)="W":"Window",1:"Mail")
    73         S REFL=$P(RX0,"^",9),I=0 F  S I=$O(^PSRX(RXN,1,I)) Q:'I  S REFL=REFL-1,ROU=$S($P(^PSRX(RXN,1,I,0),"^",2)="W":"Window",1:"Mail")
    74         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="      Last Fill Date: "_$E($P(RX3,"^"),4,5)_"/"_$E($P(RX3,"^"),6,7)_"/"_$E($P(RX3,"^"),2,3)
    75         D CMOP^PSOORNE3 S DA=RXN
    76         S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" ("_ROU_$S($G(PSOCMOP)]"":", "_PSOCMOP,1:"")_")" K ROU,PSOCMOP
    77         S IEN=IEN+1 I $P(RX2,"^",15) S ^TMP("PSOAL",$J,IEN,0)="   Returned to Stock: "_$E($P(RX2,"^",15),4,5)_"/"_$E($P(RX2,"^",15),6,7)_"/"_$E($P(RX2,"^",15),2,3)
    78         E  S ^TMP("PSOAL",$J,IEN,0)="   Last Release Date: " D
    79         .S RLD=$S($P(RX2,"^",13):$E($P(RX2,"^",13),4,5)_"/"_$E($P(RX2,"^",13),6,7)_"/"_$E($P(RX2,"^",13),2,3),1:"")
    80         .I $O(^PSRX(RXN,1,0)) F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I  D
    81         ..I $P(^PSRX(RXN,1,I,0),"^",18) S RLD=$E($P(^(0),"^",18),4,5)_"/"_$E($P(^(0),"^",18),6,7)_"/"_$E($P(^(0),"^",18),2,3)
    82         .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_$S($G(RLD)]"":RLD,1:"        ")
    83         S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"                     Lot #: "_$P(RX2,"^",4)
    84         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="             Expires: "_$E($P(RX2,"^",6),4,5)_"/"_$E($P(RX2,"^",6),6,7)_"/"_$E($P(RX2,"^",6),2,3)
    85         S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"                       MFG: "_$P($G(RX2),"^",8)
    86         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="         Days Supply: "_$P(RX0,"^",8)_$S($L($P(RX0,"^",8))=1:" ",1:"")
    87         S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"                        QTY"_$S($P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)]"":" ("_$P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)_")",1:" (  )")_": "_$P(RX0,"^",7)
    88         I $P($G(^PSDRUG($P(RX0,"^",6),5)),"^")]"" D
    89         .S $P(RN," ",79)=" ",IEN=IEN+1
    90         .S ^TMP("PSOAL",$J,IEN,0)=$E(RN,$L("QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^"))+1,79)_"QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^") K RN
    91         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="        # of Refills: "_$P(RX0,"^",9)_$S($L($P(RX0,"^",9))=1:" ",1:"")_"                       Remaining: "_REFL
    92         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="            Provider: "_$S($D(^VA(200,$P(RX0,"^",4),0)):$P(^VA(200,$P(RX0,"^",4),0),"^"),1:"UNKNOWN")
    93         I $P(RX3,"^",3) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="        Cos-Provider: "_$P(^VA(200,$P(RX3,"^",3),0),"^")
    94         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="             Routing: "_$S($P(RX0,"^",11)="W":"Window",1:"Mail")
    95         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="              Copies: "_$S($P(RX0,"^",18):$P(RX0,"^",18),1:1)
    96         S:$P(RX0,"^",11)="W" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="    Method of Pickup: "_$G(^PSRX(RXN,"MP"))
    97         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="              Clinic: "_$S($D(^SC(+$P(RX0,"^",5),0)):$P(^SC($P(RX0,"^",5),0),"^"),1:"Not on File")
    98         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="            Division: "_$P(^PS(59,$P(RX2,"^",9),0),"^")_" ("_$P(^(0),"^",6)_")"
    99         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="          Pharmacist: "_$S($P(RX2,"^",3):$P(^VA(200,$P(RX2,"^",3),0),"^"),1:"")
    100         S:$P(RX2,"^",10)&('$G(PSOCOPY)) IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="         Verified By: "_$P(^VA(200,$P(RX2,"^",10),0),"^")
    101         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="  Patient Counseling: "_$S($P($G(^PSRX(RXN,"PC")),"^"):"YES",1:"NO")_"                      "_$S($P($G(^PSRX(RXN,"PC")),"^"):"Was Counseling Understood: "_$S($P($G(^PSRX(RXN,"PC")),"^",2):"YES",1:"NO"),1:"")
    102         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="             Remarks: "_$P(RX3,"^",7)
    103         D PC^PSORXVW1
    104         I $P($G(^PSRX(DA,"OR1")),"^",5) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="         Finished By: "_$P(^VA(200,$P(^PSRX(DA,"OR1"),"^",5),0),"^")
    105         D ^PSORXVW1 S PSOAL=IEN K IEN,ACT,LBL,LOG
    106         I ST<12,$P(RX2,"^",6)<DT S ST=11
    107         S VALM("TITLE")="Rx View "_"("_$P("Error^Active^Non-Verified^Refill^Hold^Non-Verified^Suspended^^^^^Done^Expired^Discontinued^Deleted^Discontinued^Discontinued (Edit)^Provider Hold^","^",ST+2)_")"
    108         S:$P($G(^PSRX(DA,"PKI")),"^") VALMSG="Digitally Signed Order"
    109         D EN^PSOORAL,KILL I $G(PS)="VIEW" G PSORXVW
    110         Q
    111         ;
    112 KILL    K ^TMP("PSOAL",$J),PSOAL,IEN,^TMP("PSOHDR",$J) I $G(PS)="VIEW" K DA
    113         K ST,RFL,RFLL,RFL1,ST,II,J,N,PHYS,L1,DIRUT,PSDIV,PSEXDT,MED,M1,FFX,DTT,DAT,RX0,RX2,R3,RTN,SIG,STA,P1,PL,P0,Z0,Z1,EXDT,IFN,DIR,DUOUT,DTOUT,PSOELSE
    114         K LBL,I,RFDATE,%H,%I,RN,RFT,%,%I,DFN,GMRA,GMRAL,HDR,POERR,PTST,REFL,RF,RLD,RX3
    115         K RXN,RXOR,SG,VA,VADM,VAERR,VALMBCK,VAPA,X,DIC,REA,ZD,PSOHD,PSOBCK,PSODFN
    116         Q
     1PSORXVW ;BHAM ISC/SAB - listman view of a prescription ;5/25/05 2:10pm
     2 ;;7.0;OUTPATIENT PHARMACY;**14,35,46,96,103,88,117,131,146,156,185,210,148,233,260,264**;DEC 1997;Build 19
     3 ;External reference to File ^PS(55 supported by DBIA 2228
     4 ;External reference to ^PS(50.7 supported by DBIA 2223
     5 ;External reference ^PSDRUG( supported by DBIA 221
     6 ;External reference to ^VA(200 supported by DBIA 10060
     7 ;External reference to ^SC supported by DBIA 10040
     8 ;External reference to ^DPT supported by DBIA 10035
     9 ;External reference to ^PS(50.606 supported by DBIA 2174
     10 ;External reference to GMRADPT supported by DBIA 10099
     11 ;
     12 S PS="VIEW"
     13A1 ; - Prescription prompt
     14 S DIR(0)="FAO^1:30",DIR("A")=PS_" PRESCRIPTION: ",(DIR("?"),DIR("??"))="^D HLP^PSORXVW1"
     15 W ! D ^DIR I X=""!$D(DIRUT) G KILL
     16 S X=$$UP^XLFSTR(X),QUIT=0
     17 I $E(X,1,2)'="E." S (DA,PSOVDA)=+$$LKP^PSORXVW1(X) I DA<0 G A1
     18 I $E(X,1,2)="E." D  I QUIT G A1
     19 . I $L(X)'=9 W !?5,"The ECME# must be 7 digits long!",$C(7) S QUIT=1 Q
     20 . S (DA,PSOVDA)=+$$RXNUM^PSOBPSU2($E(X,3,9)) I DA<0 W " ??" S QUIT=1
     21 ;
     22DP S (PSODFN,DFN)=+$P(^PSRX(DA,0),"^",2) S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD
     23 D ICN^PSODPT(PSODFN)
     24 K ^TMP("PSOHDR",$J) D ^VADPT,ADD^VADPT
     25 S ^TMP("PSOHDR",$J,1,0)=VADM(1)
     26 N PSOBADR,PSOTEMP
     27 S PSOBADR=$$BADADR^DGUTL3(DFN) I PSOBADR S PSOTEMP=$$CHKTEMP^PSOBAI(DFN) D
     28 .S ^TMP("PSOHDR",$J,1,0)=^TMP("PSOHDR",$J,1,0)_" ** BAD ADDRESS INDICATED-("_$S(PSOBADR=1:"UNDELIVERABLE",PSOBADR=2:"HOMELESS",1:"OTHER")_")"_$S(PSOTEMP:" Active Temporary Address",1:"")
     29 S ^TMP("PSOHDR",$J,2,0)=$P(VADM(2),"^",2)
     30 S ^TMP("PSOHDR",$J,3,0)=$P(VADM(3),"^",2),^TMP("PSOHDR",$J,4,0)=VADM(4),^TMP("PSOHDR",$J,5,0)=$P(VADM(5),"^",2)
     31 S POERR=1 D RE^PSODEM K PSOERR
     32 S ^TMP("PSOHDR",$J,6,0)=$S(+$P(WT,"^",8):$P(WT,"^",9)_" ("_$P(WT,"^")_")",1:"_______ (______)")
     33 S ^TMP("PSOHDR",$J,7,0)=$S($P(HT,"^",8):$P(HT,"^",9)_" ("_$P(HT,"^")_")",1:"_______ (______)") K VM,WT,HT S PSOHD=7
     34 S GMRA="0^0^111" D EN1^GMRADPT S ^TMP("PSOHDR",$J,8,0)=+$G(GMRAL)
     35 D DEM^VADPT I +VADM(6) D
     36 .S SSN=$P(^DPT(PSODFN,0),"^",9) W !,$C(7),?10,$P(^DPT(PSODFN,0),"^")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_") DIED "_$P(VADM(6),"^",2),!
     37 .W "All Active Medications will be Autocanceled!",! H 2 S PSODEATH=1
     38 .S ACOM="Date of Death "_$P(VADM(6),"^",2)_".",ZTRTN="CAN^PSOCAN3",ZTDESC="Outpatient Pharmacy Autocancel Due to Death of Patient",ZTSAVE("ACOM")="",ZTSAVE("PSODFN")="",ZTSAVE("PSODEATH")=""
     39 .S ZTIO="",PSOCLC=DUZ,ZTSAVE("PSOCLC")="",ZTDTH=$H D ^%ZTLOAD K ACOM,ZTSK,PSODEATH
     40 K ^TMP("PSOAL",$J),PCOMX,PDA,PHI,PRC,ACOM,ANS
     41 S (DA,RXN)=PSOVDA K PSOVDA S RX0=^PSRX(RXN,0),RX2=$G(^(2)),RX3=$G(^(3)),ST=+$G(^("STA")),RXOR=$G(^("OR1"))
     42 I 'RXOR,$P(^PSDRUG($P(RX0,"^",6),2),"^") S $P(^PSRX(RXN,"OR1"),"^")=$P(^PSDRUG($P(RX0,"^",6),2),"^"),RXOR=$P(^PSDRUG($P(RX0,"^",6),2),"^")
     43 S IEN=0,$P(RN," ",12)=" "
     44 N APPND S APPND=$S($G(^PSRX(RXN,"IB")):"$",1:"")
     45 I $$ECMENUM^PSOBPSU2(RXN)'="" S APPND=APPND_$$ECME^PSOBPSUT(RXN)_"  (ECME#: "_$$ECMENUM^PSOBPSU2(RXN)_")"
     46 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$S($P($G(^PSRX(RXN,"TPB")),"^"):"            TPB Rx #: ",1:"                Rx #: ")_$P(RX0,"^")_APPND_$E(RN,$L($P(RX0,"^")_APPND)+1,12)
     47 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="      Orderable Item: "_$S($D(^PS(50.7,$P(+RXOR,"^"),0)):$P(^PS(50.7,$P(+RXOR,"^"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^"),1:"No Pharmacy Orderable Item")
     48 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$S($D(^PSDRUG("AQ",$P(RX0,"^",6))):"           CMOP ",1:"                ")_"Drug: "_$P(^PSDRUG($P(RX0,"^",6),0),"^")
     49 S:$G(^PSRX(RXN,"TN"))]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="          Trade Name: "_$G(^PSRX(RXN,"TN"))
     50 I $$STATUS^PSOBPSUT(RXN,0)'="",$$RXRLDT^PSOBPSUT(RXN,0) D
     51 . S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="                 NDC: "_$$GETNDC^PSONDCUT(RXN,0)
     52 D DOSE^PSORXVW1
     53 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Patient Instructions:" I $O(^PSRX(RXN,"INS1",0)) D
     54 . F I=0:0 S I=$O(^PSRX(RXN,"INS1",I)) Q:'I  D
     55 .. S MIG=^PSRX(RXN,"INS1",I,0)
     56 .. D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAL",$J)),21)
     57 K MIG,SG
     58 I $P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="  Other Pat. Instruc: "_$S($G(^PSRX(RXN,"INSS"))]"":^PSRX(RXN,"INSS"),1:"")
     59 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="                 SIG:"
     60 I '$P($G(^PSRX(RXN,"SIG")),"^",2) D  G PTST
     61 . S X=$P($G(^PSRX(RXN,"SIG")),"^") D SIGONE^PSOHELP S SIG=$E($G(INS1),2,250)
     62 . D WORDWRAP^PSOUTLA2(SIG,.IEN,$NA(^TMP("PSOAL",$J)),21)
     63 S SIGOK=1
     64 F I=0:0 S I=$O(^PSRX(RXN,"SIG1",I)) Q:'I  D
     65 . S MIG=^PSRX(RXN,"SIG1",I,0)
     66 . D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAL",$J)),21)
     67 S SIGOK=1 K MIG,SG
     68PTST S $P(RN," ",25)=" ",PTST=$S($G(^PS(53,+$P(RX0,"^",3),0))]"":$P($G(^PS(53,+$P(RX0,"^",3),0)),"^"),1:""),IEN=IEN+1
     69 S ^TMP("PSOAL",$J,IEN,0)="      Patient Status: "_PTST_$E(RN,$L(PTST)+1,25)
     70 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="          Issue Date: "_$E($P(RX0,"^",13),4,5)_"/"_$E($P(RX0,"^",13),6,7)_"/"_$E($P(RX0,"^",13),2,3)
     71 S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"                 Fill Date: "_$E($P(RX2,"^",2),4,5)_"/"_$E($P(RX2,"^",2),6,7)_"/"_$E($P(RX2,"^",2),2,3)
     72 S ROU=$S($P(RX0,"^",11)="W":"Window",1:"Mail")
     73 S REFL=$P(RX0,"^",9),I=0 F  S I=$O(^PSRX(RXN,1,I)) Q:'I  S REFL=REFL-1,ROU=$S($P(^PSRX(RXN,1,I,0),"^",2)="W":"Window",1:"Mail")
     74 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="      Last Fill Date: "_$E($P(RX3,"^"),4,5)_"/"_$E($P(RX3,"^"),6,7)_"/"_$E($P(RX3,"^"),2,3)
     75  D CMOP^PSOORNE3 S DA=RXN
     76 S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" ("_ROU_$S($G(PSOCMOP)]"":", "_PSOCMOP,1:"")_")" K ROU,PSOCMOP
     77 S IEN=IEN+1 I $P(RX2,"^",15) S ^TMP("PSOAL",$J,IEN,0)="   Returned to Stock: "_$E($P(RX2,"^",15),4,5)_"/"_$E($P(RX2,"^",15),6,7)_"/"_$E($P(RX2,"^",15),2,3)
     78 E  S ^TMP("PSOAL",$J,IEN,0)="   Last Release Date: " D
     79 .S RLD=$S($P(RX2,"^",13):$E($P(RX2,"^",13),4,5)_"/"_$E($P(RX2,"^",13),6,7)_"/"_$E($P(RX2,"^",13),2,3),1:"")
     80 .I $O(^PSRX(RXN,1,0)) F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I  D
     81 ..I $P(^PSRX(RXN,1,I,0),"^",18) S RLD=$E($P(^(0),"^",18),4,5)_"/"_$E($P(^(0),"^",18),6,7)_"/"_$E($P(^(0),"^",18),2,3)
     82 .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_$S($G(RLD)]"":RLD,1:"        ")
     83 S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"                     Lot #: "_$P(RX2,"^",4)
     84 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="             Expires: "_$E($P(RX2,"^",6),4,5)_"/"_$E($P(RX2,"^",6),6,7)_"/"_$E($P(RX2,"^",6),2,3)
     85 S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"                       MFG: "_$P($G(RX2),"^",8)
     86 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="         Days Supply: "_$P(RX0,"^",8)_$S($L($P(RX0,"^",8))=1:" ",1:"")
     87 S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"                        QTY"_$S($P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)]"":" ("_$P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)_")",1:" (  )")_": "_$P(RX0,"^",7)
     88 I $P($G(^PSDRUG($P(RX0,"^",6),5)),"^")]"" D
     89 .S $P(RN," ",79)=" ",IEN=IEN+1
     90 .S ^TMP("PSOAL",$J,IEN,0)=$E(RN,$L("QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^"))+1,79)_"QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^") K RN
     91 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="        # of Refills: "_$P(RX0,"^",9)_$S($L($P(RX0,"^",9))=1:" ",1:"")_"                       Remaining: "_REFL
     92 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="            Provider: "_$S($D(^VA(200,$P(RX0,"^",4),0)):$P(^VA(200,$P(RX0,"^",4),0),"^"),1:"UNKNOWN")
     93 I $P(RX3,"^",3) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="        Cos-Provider: "_$P(^VA(200,$P(RX3,"^",3),0),"^")
     94 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="             Routing: "_$S($P(RX0,"^",11)="W":"Window",1:"Mail")
     95 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="              Copies: "_$S($P(RX0,"^",18):$P(RX0,"^",18),1:1)
     96 S:$P(RX0,"^",11)="W" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="    Method of Pickup: "_$G(^PSRX(RXN,"MP"))
     97 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="              Clinic: "_$S($D(^SC(+$P(RX0,"^",5),0)):$P(^SC($P(RX0,"^",5),0),"^"),1:"Not on File")
     98 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="            Division: "_$P(^PS(59,$P(RX2,"^",9),0),"^")_" ("_$P(^(0),"^",6)_")"
     99 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="          Pharmacist: "_$S($P(RX2,"^",3):$P(^VA(200,$P(RX2,"^",3),0),"^"),1:"")
     100 S:$P(RX2,"^",10)&('$G(PSOCOPY)) IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="         Verified By: "_$P(^VA(200,$P(RX2,"^",10),0),"^")
     101 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="  Patient Counseling: "_$S($P($G(^PSRX(RXN,"PC")),"^"):"YES",1:"NO")_"                      "_$S($P($G(^PSRX(RXN,"PC")),"^"):"Was Counseling Understood: "_$S($P($G(^PSRX(RXN,"PC")),"^",2):"YES",1:"NO"),1:"")
     102 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="             Remarks: "_$P(RX3,"^",7)
     103 D PC^PSORXVW1
     104 I $P($G(^PSRX(DA,"OR1")),"^",5) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="         Finished By: "_$P(^VA(200,$P(^PSRX(DA,"OR1"),"^",5),0),"^")
     105 D ^PSORXVW1 S PSOAL=IEN K IEN,ACT,LBL,LOG
     106 I ST<12,$P(RX2,"^",6)<DT S ST=11
     107 S VALM("TITLE")="Rx View "_"("_$P("Error^Active^Non-Verified^Refill^Hold^Non-Verified^Suspended^^^^^Done^Expired^Discontinued^Deleted^Discontinued^Discontinued (Edit)^Provider Hold^","^",ST+2)_")"
     108 S:$P($G(^PSRX(DA,"PKI")),"^") VALMSG="Digitally Signed Order"
     109 D EN^PSOORAL,KILL G:PS="VIEW" PSORXVW
     110 Q
     111 ;
     112KILL K ^TMP("PSOAL",$J),PSOAL,IEN,^TMP("PSOHDR",$J) K:PS="VIEW" DA
     113 K ST,RFL,RFLL,RFL1,ST,II,J,N,PHYS,L1,DIRUT,PSDIV,PSEXDT,MED,M1,FFX,DTT,DAT,RX0,RX2,R3,RTN,SIG,STA,P1,PL,P0,Z0,Z1,EXDT,IFN,DIR,DUOUT,DTOUT,PSOELSE
     114 K LBL,I,RFDATE,%H,%I,RN,RFT,%,%I,DFN,GMRA,GMRAL,HDR,POERR,PTST,REFL,RF,RLD,RX3
     115 K RXN,RXOR,SG,VA,VADM,VAERR,VALMBCK,VAPA,X,DIC,REA,ZD,PSOHD,PSOBCK,PSODFN
     116 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXVW1.m

    r613 r623  
    1 PSORXVW1        ;BIR/SAB-view prescription con't ; 12/4/07 12:28pm
    2         ;;7.0;OUTPATIENT PHARMACY;**35,47,46,71,99,117,156,193,210,148,258,260,240,281**;DEC 1997;Build 41
    3         ;External reference to ^DD(52 supported by DBIA 999
    4         ;External reference to ^VA(200 supported by DBIA 10060
    5         ;PSO*210 add call to WORDWRAP api
    6         ;
    7         I $P($G(^PSRX(RXN,"OR1")),"^",6) D
    8         .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(^PSRX(RXN,"OR1"),"^",6) D ^DIC
    9         .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="           Filled By: "_$P(Y,"^",2) K DIC,X,Y
    10         I $P($G(^PSRX(RXN,"OR1")),"^",7) D
    11         .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(^PSRX(RXN,"OR1"),"^",7) D ^DIC
    12         .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="          Checked By: "_$P(Y,"^",2) K DIC,X,Y
    13         K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(RX0,"^",16) D ^DIC
    14         S $P(RN," ",35)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="   Entry By: "_$P(Y,"^",2)_$E(RN,$L($P(Y,"^",2))+1,35)
    15         S Y=$P(RX2,"^") X ^DD("DD")
    16         S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"Entry Date: "_$E($P(RX2,"^"),4,5)_"/"_$E($P(RX2,"^"),6,7)_"/"_$E($P(RX2,"^"),2,3)_" "_$P(Y,"@",2) K RN
    17         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" " ;,IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
    18         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Original Fill Released: " I $P(RX2,"^",13) S DTT=$P(RX2,"^",13) D DAT S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_DAT K DAT,DTT
    19         I $P(RX2,"^",15) S DTT=$P(RX2,"^",15) D DAT S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"(Returned to Stock "_DAT_")" K DAT,DTT
    20         S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"      Routing: "_$S($P(RX0,"^",11)="W":"Window",1:"Mail")
    21         I $G(^PSRX(DA,"H"))]"",$P(^("STA"),"^")=3 D HLD
    22         D RF,PAR,ACT,COPAY^PSORXVW2,LBL,ECME^PSOORAL1,^PSORXVW2:$O(^PSRX(DA,4,0))
    23         Q
    24 ACT     ;activity log
    25         N CNT
    26         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Activity Log:"
    27         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="#   Date        Reason         Rx Ref         Initiator Of Activity",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
    28         I '$O(^PSRX(DA,"A",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There's NO Activity to report" Q
    29         S CNT=0
    30         F N=0:0 S N=$O(^PSRX(DA,"A",N)) Q:'N  S P1=^(N,0),DTT=P1\1 D DAT D
    31         .I $P(P1,"^",2)="M" Q
    32         .S IEN=IEN+1,CNT=CNT+1,^TMP("PSOAL",$J,IEN,0)=CNT_"   "_DAT_"    ",$P(RN," ",15)=" ",REA=$P(P1,"^",2)
    33         .S REA=$F("HUCELPRWSIVDABXGKNM",REA)-1
    34         .I REA D
    35         ..S STA=$P("HOLD^UNHOLD^DISCONTINUED^EDIT^RENEWED^PARTIAL^REINSTATE^REPRINT^SUSPENSE^RETURNED^INTERVENTION^DELETED^DRUG INTERACTION^PROCESSED^X-INTERFACE^PATIENT INSTR.^PKI/DEA^DISP COMPLETED^ECME^","^",REA)
    36         ..S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA_$E(RN,$L(STA)+1,15)
    37         .E  S $P(STA," ",15)=" ",^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA
    38         .K STA,RN S $P(RN," ",15)=" ",RF=+$P(P1,"^",4)
    39         .S RFT=$S(RF>0&(RF<6):"REFILL "_RF,RF=6:"PARTIAL",RF>6:"REFILL "_(RF-1),1:"ORIGINAL")
    40         .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(P1,"^",3) D ^DIC
    41         .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$E(RN,$L(RFT)+1,15)_$S(+Y:$P(Y,"^",2),1:$P(P1,"^",3))
    42         .;S:$P(P1,"^",5)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$P(P1,"^",5)
    43         .I $P(P1,"^",5)]"" N PSOACBRK,PSOACBRV D
    44         ..S PSOACBRV=$P(P1,"^",5)
    45         ..;PSO*7*240 Use fileman to format
    46         ..K ^UTILITY($J,"W") S X="Comments: "_PSOACBRV,(DIWR,DIWL)=1,DIWF="C80" D ^DIWP F I=1:1:^UTILITY($J,"W",1) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$G(^UTILITY($J,"W",1,I,0))
    47         .I $G(^PSRX(DA,"A",N,1))]"" S IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",5)=$P(^PSRX(DA,"A",N,1),"^") I $P(^PSRX(DA,"A",N,1),"^",2)]"" S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_":"_$P(^PSRX(DA,"A",N,1),"^",2)
    48         .I $O(^PSRX(DA,"A",N,2,0)) F I=0:0 S I=$O(^PSRX(RXN,"A",N,2,I)) Q:'I  S MIG=^PSRX(RXN,"A",N,2,I,0) D
    49         ..F SG=1:1:$L(MIG) S:$L(^TMP("PSOAL",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",9)=" " S:$P(MIG," ",SG)'="" ^TMP("PSOAL",$J,IEN,0)=$G(^TMP("PSOAL",$J,IEN,0))_" "_$P(MIG," ",SG)
    50         K MIG,SG,I,^UTILITY($J,"W"),DIWF,DIWL,DIWR
    51         Q
    52 LBL     ;label log
    53         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Label Log:"
    54         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="#   Date        Rx Ref                    Printed By",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
    55         I '$O(^PSRX(DA,"L",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There are NO Labels printed." Q
    56         F L1=0:0 S L1=$O(^PSRX(DA,"L",L1)) Q:'L1  S LBL=^PSRX(DA,"L",L1,0),DTT=$P(^(0),"^") D DAT D
    57         .S $P(RN," ",26)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=L1_"   "_DAT_"    ",RFT=$S($P(LBL,"^",2):"REFILL "_$P(LBL,"^",2),1:"ORIGINAL"),RFT=RFT_$E(RN,$L(RFT)+1,26)
    58         .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(LBL,"^",4) D ^DIC
    59         .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$P(Y,"^",2),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$P(LBL,"^",3)
    60         K DIC,X,Y Q
    61 RF      ;refill log
    62         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Refill Log:"
    63         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="#  Log Date   Refill Date  Qty               Routing  Lot #       Pharmacist",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
    64         S (RF,PL)=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF  S PL=PL+1
    65         I 'PL S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There are NO Refills For this  Prescription" Q
    66         F N=0:0 S N=$O(^PSRX(DA,1,N)) Q:'N  S P1=^(N,0) D
    67         .S DTT=$P(P1,"^",8)\1 D DAT S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=N_"   "_DAT_"   "
    68         .S DTT=$P(P1,"^"),$P(RN," ",10)=" " D DAT
    69         .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_DAT_"     "_$P(P1,"^",4)_$E("               ",$L($P(P1,"^",4))+1,15)_"  "_$S($P(P1,"^",2)="M":"Mail",1:"Window")_" "_$P(P1,"^",6)_$E(RN,$L($P(P1,"^",6))+1,12)
    70         .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=+$P(P1,"^",5) D ^DIC
    71         .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_$E($S(+Y:$P(Y,"^",2),1:""),1,16) K DIC,X,Y
    72         .S PSDIV=$S($D(^PS(59,+$P(P1,"^",9),0)):$P(^(0),"^",6),1:"Unknown"),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Division: "_PSDIV_$E("        ",$L(PSDIV)+1,8)_"  "
    73         .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"Dispensed: "_$S($P(P1,"^",19):$E($P(P1,"^",19),4,5)_"/"_$E($P(P1,"^",19),6,7)_"/"_$E($P(P1,"^",19),2,3),1:"")_"  "
    74         .S RTS=$S($P(P1,"^",16):" Returned to Stock: "_$E($P(P1,"^",16),4,5)_"/"_$E($P(P1,"^",16),6,7)_"/"_$E($P(P1,"^",16),2,3),1:" Released: "_$S($$RXRLDT^PSOBPSUT(DA,N):$$FMTE^XLFDT($$RXRLDT^PSOBPSUT(DA,N)\1,2),1:""))
    75         .I $$STATUS^PSOBPSUT(DA,N)'="",$$RXRLDT^PSOBPSUT(DA,N) S RTS=RTS_"  NDC: "_$$GETNDC^PSONDCUT(DA,N)
    76         .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RTS
    77         .S:$P(P1,"^",3)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="   Remarks: "_$P(P1,"^",3)
    78         K RTS Q
    79 PAR     ;partial log
    80         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Partial Fills:"
    81         S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="#   Log Date   Date     Qty              Routing    Lot #        Pharmacist",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
    82         I '$O(^PSRX(DA,"P",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There are NO Partials for this Prescription" Q
    83         S N=0 F  S N=$O(^PSRX(DA,"P",N)) Q:'N  S P1=^(N,0),DTT=$P(P1,"^",8)\1 D DAT D
    84         .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=N_"   "_DAT_"  ",QTY=$P(P1,"^",4)_$E("               ",$L($P(P1,"^",4))+1,15)
    85         .S DTT=$P(P1,"^") D DAT S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_DAT_"  "_QTY_"  "
    86         .S PSDIV=$S($D(^PS(59,+$P(P1,"^",9),0)):$P(^(0),"^",6),1:"UNKNOWN"),PSDIV=PSDIV_$E("        ",$L(PSDIV)+1,8)
    87         .S MW=$S($P(P1,"^",2)="M":"Mail",1:"Window"),MW=MW_$E("          ",$L(MW)+1,10)
    88         .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=+$P(P1,"^",16) D ^DIC
    89         .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_MW_"  "_$P(P1,"^",6)_$E("            ",$L($P(P1,"^",6))+1,10)_$E($S(+Y:$P(Y,"^",2),1:""),1,16)
    90         .S RTS=$S($P(P1,"^",16):" RETURNED TO STOCK: "_$E($P(P1,"^",16),4,5)_"/"_$E($P(P1,"^",16),6,7)_"/"_$E($P(P1,"^",16),2,3),1:" RELEASED: "_$S($P(P1,"^",19):$E($P(P1,"^",19),4,5)_"/"_$E($P(P1,"^",19),6,7)_"/"_$E($P(P1,"^",19),2,3),1:""))
    91         .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(P1,"^",7) D ^DIC
    92         .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Division: "_PSDIV_" "_RTS ;_"      Entry By: "_$P(Y,"^",2) K DIC,X,Y
    93         .S:$P(P1,"^",3)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="  REMARKS: "_$P(P1,"^",3) K RTS
    94         Q
    95 HLD     ;hold info
    96         S DTT=$P(^PSRX(DA,"H"),"^",3) D DAT S HLDR=$P(^DD(52,99,0),"^",3),HLDR=$S($P(^PSRX(DA,"H"),"^")'>8:$P(HLDR,";",$P(^PSRX(DA,"H"),"^")),1:$P(HLDR,";",9)),HLDR=$P(HLDR,":",2)
    97         S $P(RN," ",60)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Hold Reason: "_HLDR_$E(RN,$L("Hold Reason: "_HLDR)+1,60)_"Hold Date: "_DAT S:$P(^PSRX(DA,"H"),"^",2)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Hold Comments: "_$P(^PSRX(DA,"H"),"^",2)
    98         K RN,DAT,DTT,HLDR
    99         Q
    100 DAT     S DAT="",DTT=DTT\1 Q:DTT'?7N  S DAT=$E(DTT,4,5)_"/"_$E(DTT,6,7)_"/"_$E(DTT,2,3)
    101         Q
    102 INST    ;formats instruction from front door
    103         I $O(^PSRX(DA,"PI",0)) D
    104         .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="        Instructions:"
    105         .S T=0 F  S T=$O(^PSRX(RXN,"PI",T)) Q:'T  D                  ;PSO*210
    106         ..S MIG=^PSRX(RXN,"PI",T,0)
    107         ..D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAL",$J)),21)
    108         K T,TY,MIG,SG
    109         Q
    110 PC      ;displays provider comments
    111         I $O(^PSRX(DA,"PRC",0)) D
    112         .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="   Provider Comments:"
    113         .S T=0 F  S T=$O(^PSRX(RXN,"PRC",T)) Q:'T  D                 ;PSO*210
    114         ..S MIG=^PSRX(RXN,"PRC",T,0)
    115         ..D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAL",$J)),21)
    116         K T,TY,MIG,SG
    117         Q
    118 DOSE    ;displays dosing instruction for both simple and complex Rxs.
    119         D DOSE^PSORXVW2
    120         Q
    121         ;
    122 HLP     ; Help Text for the VIEW PRESCRIPTION prompt
    123         W !," A prescription number or ECME # may be entered.  The ECME"
    124         W !," number must be entered in E.NNNNNNN format, where NNNNNNN"
    125         W !," is the prescription ECME # (example: E.0289332).  Or just"
    126         D LKP("?")
    127         Q
    128 LKP(INPUT)      ; - Peforms Lookup on the PRESCRIPTION file
    129         N DIC,X,Y
    130         S DIC="^PSRX(",DIC(0)="QE",D="B",X=INPUT
    131         S DIC("S")="I $P($G(^(0)),""^"",2),$D(^(""STA"")),$P($G(^(""STA"")),""^"")'=13"
    132         D IX^DIC
    133         Q Y
     1PSORXVW1 ;BIR/SAB-view prescription con't ;5/26/05 10:07am
     2 ;;7.0;OUTPATIENT PHARMACY;**35,47,46,71,99,117,156,193,210,148,258,260**;DEC 1997;Build 84
     3 ;External reference to ^DD(52 supported by DBIA 999
     4 ;External reference to ^VA(200 supported by DBIA 10060
     5 ;PSO*210 add call to WORDWRAP api
     6 ;
     7 I $P($G(^PSRX(RXN,"OR1")),"^",6) D
     8 .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(^PSRX(RXN,"OR1"),"^",6) D ^DIC
     9 .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="           Filled By: "_$P(Y,"^",2) K DIC,X,Y
     10 I $P($G(^PSRX(RXN,"OR1")),"^",7) D
     11 .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(^PSRX(RXN,"OR1"),"^",7) D ^DIC
     12 .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="          Checked By: "_$P(Y,"^",2) K DIC,X,Y
     13 K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(RX0,"^",16) D ^DIC
     14 S $P(RN," ",35)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="   Entry By: "_$P(Y,"^",2)_$E(RN,$L($P(Y,"^",2))+1,35)
     15 S Y=$P(RX2,"^") X ^DD("DD")
     16 S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"Entry Date: "_$E($P(RX2,"^"),4,5)_"/"_$E($P(RX2,"^"),6,7)_"/"_$E($P(RX2,"^"),2,3)_" "_$P(Y,"@",2) K RN
     17 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" " ;,IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
     18 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Original Fill Released: " I $P(RX2,"^",13) S DTT=$P(RX2,"^",13) D DAT S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_DAT K DAT,DTT
     19 I $P(RX2,"^",15) S DTT=$P(RX2,"^",15) D DAT S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"(Returned to Stock "_DAT_")" K DAT,DTT
     20 S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"      Routing: "_$S($P(RX0,"^",11)="W":"Window",1:"Mail")
     21 I $G(^PSRX(DA,"H"))]"",$P(^("STA"),"^")=3 D HLD
     22 D RF,PAR,ACT,COPAY^PSORXVW2,LBL,ECME^PSOORAL1,^PSORXVW2:$O(^PSRX(DA,4,0))
     23 Q
     24ACT ;activity log
     25 N CNT
     26 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Activity Log:"
     27 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="#   Date        Reason         Rx Ref         Initiator Of Activity",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
     28 I '$O(^PSRX(DA,"A",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There's NO Activity to report" Q
     29 S CNT=0
     30 F N=0:0 S N=$O(^PSRX(DA,"A",N)) Q:'N  S P1=^(N,0),DTT=P1\1 D DAT D
     31 .I $P(P1,"^",2)="M" Q
     32 .S IEN=IEN+1,CNT=CNT+1,^TMP("PSOAL",$J,IEN,0)=CNT_"   "_DAT_"    ",$P(RN," ",15)=" ",REA=$P(P1,"^",2)
     33 .S REA=$F("HUCELPRWSIVDABXGKNM",REA)-1
     34 .I REA D
     35 ..S STA=$P("HOLD^UNHOLD^DISCONTINUED^EDIT^RENEWED^PARTIAL^REINSTATE^REPRINT^SUSPENSE^RETURNED^INTERVENTION^DELETED^DRUG INTERACTION^PROCESSED^X-INTERFACE^PATIENT INSTR.^PKI/DEA^DISP COMPLETED^ECME^","^",REA)
     36 ..S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA_$E(RN,$L(STA)+1,15)
     37 .E  S $P(STA," ",15)=" ",^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA
     38 .K STA,RN S $P(RN," ",15)=" ",RF=+$P(P1,"^",4)
     39 .S RFT=$S(RF>0&(RF<6):"REFILL "_RF,RF=6:"PARTIAL",RF>6:"REFILL "_(RF-1),1:"ORIGINAL")
     40 .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(P1,"^",3) D ^DIC
     41 .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$E(RN,$L(RFT)+1,15)_$S(+Y:$P(Y,"^",2),1:$P(P1,"^",3))
     42 .;S:$P(P1,"^",5)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$P(P1,"^",5)
     43 .I $P(P1,"^",5)]"" N PSOACBRK,PSOACBRV D
     44 ..S PSOACBRV=$P(P1,"^",5)
     45 ..I $L(PSOACBRV)<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_PSOACBRV Q
     46 ..I $E(PSOACBRV,1,70)'[" " S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$E(PSOACBRV,1,70),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$E(PSOACBRV,71,245) Q
     47 ..F PSOACBRK=245:-1 Q:PSOACBRK=0  I $E(PSOACBRV,PSOACBRK)=" ",PSOACBRK<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$E(PSOACBRV,1,PSOACBRK),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$E(PSOACBRV,PSOACBRK,245) Q
     48 .I $G(^PSRX(DA,"A",N,1))]"" S IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",5)=$P(^PSRX(DA,"A",N,1),"^") I $P(^PSRX(DA,"A",N,1),"^",2)]"" S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_":"_$P(^PSRX(DA,"A",N,1),"^",2)
     49 .I $O(^PSRX(DA,"A",N,2,0)) F I=0:0 S I=$O(^PSRX(RXN,"A",N,2,I)) Q:'I  S MIG=^PSRX(RXN,"A",N,2,I,0) D
     50 ..F SG=1:1:$L(MIG) S:$L(^TMP("PSOAL",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",9)=" " S:$P(MIG," ",SG)'="" ^TMP("PSOAL",$J,IEN,0)=$G(^TMP("PSOAL",$J,IEN,0))_" "_$P(MIG," ",SG)
     51 K MIG,SG,I Q
     52LBL ;label log
     53 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Label Log:"
     54 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="#   Date        Rx Ref                    Printed By",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
     55 I '$O(^PSRX(DA,"L",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There are NO Labels printed." Q
     56 F L1=0:0 S L1=$O(^PSRX(DA,"L",L1)) Q:'L1  S LBL=^PSRX(DA,"L",L1,0),DTT=$P(^(0),"^") D DAT D
     57 .S $P(RN," ",26)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=L1_"   "_DAT_"    ",RFT=$S($P(LBL,"^",2):"REFILL "_$P(LBL,"^",2),1:"ORIGINAL"),RFT=RFT_$E(RN,$L(RFT)+1,26)
     58 .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(LBL,"^",4) D ^DIC
     59 .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$P(Y,"^",2),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$P(LBL,"^",3)
     60 K DIC,X,Y Q
     61RF ;refill log
     62 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Refill Log:"
     63 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="#  Log Date   Refill Date  Qty               Routing  Lot #       Pharmacist",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
     64 S (RF,PL)=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF  S PL=PL+1
     65 I 'PL S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There are NO Refills For this  Prescription" Q
     66 F N=0:0 S N=$O(^PSRX(DA,1,N)) Q:'N  S P1=^(N,0) D
     67 .S DTT=$P(P1,"^",8)\1 D DAT S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=N_"   "_DAT_"   "
     68 .S DTT=$P(P1,"^"),$P(RN," ",10)=" " D DAT
     69 .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_DAT_"     "_$P(P1,"^",4)_$E("               ",$L($P(P1,"^",4))+1,15)_"  "_$S($P(P1,"^",2)="M":"Mail",1:"Window")_" "_$P(P1,"^",6)_$E(RN,$L($P(P1,"^",6))+1,12)
     70 .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=+$P(P1,"^",5) D ^DIC
     71 .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_$E($S(+Y:$P(Y,"^",2),1:""),1,16) K DIC,X,Y
     72 .S PSDIV=$S($D(^PS(59,+$P(P1,"^",9),0)):$P(^(0),"^",6),1:"Unknown"),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Division: "_PSDIV_$E("        ",$L(PSDIV)+1,8)_"  "
     73 .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"Dispensed: "_$S($P(P1,"^",19):$E($P(P1,"^",19),4,5)_"/"_$E($P(P1,"^",19),6,7)_"/"_$E($P(P1,"^",19),2,3),1:"")_"  "
     74 .S RTS=$S($P(P1,"^",16):" Returned to Stock: "_$E($P(P1,"^",16),4,5)_"/"_$E($P(P1,"^",16),6,7)_"/"_$E($P(P1,"^",16),2,3),1:" Released: "_$S($$RXRLDT^PSOBPSUT(DA,N):$$FMTE^XLFDT($$RXRLDT^PSOBPSUT(DA,N)\1,2),1:""))
     75 .I $$STATUS^PSOBPSUT(DA,N)'="",$$RXRLDT^PSOBPSUT(DA,N) S RTS=RTS_"  NDC: "_$$GETNDC^PSONDCUT(DA,N)
     76 .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RTS
     77 .S:$P(P1,"^",3)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="   Remarks: "_$P(P1,"^",3)
     78 K RTS Q
     79PAR ;partial log
     80 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Partial Fills:"
     81 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="#   Log Date   Date     Qty              Routing    Lot #        Pharmacist",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
     82 I '$O(^PSRX(DA,"P",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There are NO Partials for this Prescription" Q
     83 S N=0 F  S N=$O(^PSRX(DA,"P",N)) Q:'N  S P1=^(N,0),DTT=$P(P1,"^",8)\1 D DAT D
     84 .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=N_"   "_DAT_"  ",QTY=$P(P1,"^",4)_$E("               ",$L($P(P1,"^",4))+1,15)
     85 .S DTT=$P(P1,"^") D DAT S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_DAT_"  "_QTY_"  "
     86 .S PSDIV=$S($D(^PS(59,+$P(P1,"^",9),0)):$P(^(0),"^",6),1:"UNKNOWN"),PSDIV=PSDIV_$E("        ",$L(PSDIV)+1,8)
     87 .S MW=$S($P(P1,"^",2)="M":"Mail",1:"Window"),MW=MW_$E("          ",$L(MW)+1,10)
     88 .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=+$P(P1,"^",16) D ^DIC
     89 .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_MW_"  "_$P(P1,"^",6)_$E("            ",$L($P(P1,"^",6))+1,10)_$E($S(+Y:$P(Y,"^",2),1:""),1,16)
     90 .S RTS=$S($P(P1,"^",16):" RETURNED TO STOCK: "_$E($P(P1,"^",16),4,5)_"/"_$E($P(P1,"^",16),6,7)_"/"_$E($P(P1,"^",16),2,3),1:" RELEASED: "_$S($P(P1,"^",19):$E($P(P1,"^",19),4,5)_"/"_$E($P(P1,"^",19),6,7)_"/"_$E($P(P1,"^",19),2,3),1:""))
     91 .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(P1,"^",7) D ^DIC
     92 .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Division: "_PSDIV_" "_RTS ;_"      Entry By: "_$P(Y,"^",2) K DIC,X,Y
     93 .S:$P(P1,"^",3)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="  REMARKS: "_$P(P1,"^",3) K RTS
     94 Q
     95HLD ;hold info
     96 S DTT=$P(^PSRX(DA,"H"),"^",3) D DAT S HLDR=$P(^DD(52,99,0),"^",3),HLDR=$S($P(^PSRX(DA,"H"),"^")'>8:$P(HLDR,";",$P(^PSRX(DA,"H"),"^")),1:$P(HLDR,";",9)),HLDR=$P(HLDR,":",2)
     97 S $P(RN," ",60)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Hold Reason: "_HLDR_$E(RN,$L("Hold Reason: "_HLDR)+1,60)_"Hold Date: "_DAT S:$P(^PSRX(DA,"H"),"^",2)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Hold Comments: "_$P(^PSRX(DA,"H"),"^",2)
     98 K RN,DAT,DTT,HLDR
     99 Q
     100DAT S DAT="",DTT=DTT\1 Q:DTT'?7N  S DAT=$E(DTT,4,5)_"/"_$E(DTT,6,7)_"/"_$E(DTT,2,3)
     101 Q
     102INST ;formats instruction from front door
     103 I $O(^PSRX(DA,"PI",0)) D
     104 .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="        Instructions:"
     105 .S T=0 F  S T=$O(^PSRX(RXN,"PI",T)) Q:'T  D                  ;PSO*210
     106 ..S MIG=^PSRX(RXN,"PI",T,0)
     107 ..D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAL",$J)),21)
     108 K T,TY,MIG,SG
     109 Q
     110PC ;displays provider comments
     111 I $O(^PSRX(DA,"PRC",0)) D
     112 .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="   Provider Comments:"
     113 .S T=0 F  S T=$O(^PSRX(RXN,"PRC",T)) Q:'T  D                 ;PSO*210
     114 ..S MIG=^PSRX(RXN,"PRC",T,0)
     115 ..D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAL",$J)),21)
     116 K T,TY,MIG,SG
     117 Q
     118DOSE ;displays dosing instruction for both simple and complex Rxs.
     119 D DOSE^PSORXVW2
     120 Q
     121 ;
     122HLP ; Help Text for the VIEW PRESCRIPTION prompt
     123 W !," You may enter E.NNNNNNN, where NNNNNNN is the"
     124 W !," prescription ECME# (e.g., E.0289332) or,"
     125 D LKP("?")
     126 Q
     127LKP(INPUT) ; - Peforms Lookup on the PRESCRIPTION file
     128 N DIC,X,Y
     129 S DIC="^PSRX(",DIC(0)="QE",D="B",X=INPUT
     130 S DIC("S")="I $P($G(^(0)),""^"",2),$D(^(""STA"")),$P($G(^(""STA"")),""^"")'=13"
     131 D IX^DIC
     132 Q Y

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSD0.m

    r613 r623  
    1 PSOSD0  ;BHAM ISC/SAB - action or informational profile cont. ;6/21/07 8:20am
    2         ;;7.0;OUTPATIENT PHARMACY;**2,19,40,66,107,110,258,206**;DEC 1997;Build 39
    3         ;External reference to ^PS(50.605 supported by DBIA 696
    4         ;External reference to ^SC supported by DBIA 10040
    5         ;External reference to ^PSDRUG supported by DBIA 221
    6 CLASS   S (ZCLASS,CLASS)="",RXCNT=0 F Z0=0:0 S CLASS=$O(^TMP($J,"PRF",CLASS)) Q:CLASS=""  S PCLASS=$S($D(^PS(50.605,+$O(^PS(50.605,"B",CLASS,0)),0)):CLASS_" - "_$P(^(0),"^",2),1:"UNCLASSIFIED") D DRUG Q:$D(DTOUT)!($D(DUOUT))
    7         Q
    8 DRUG    S DRUG="" F Z1=0:0 S DRUG=$O(^TMP($J,"PRF",CLASS,DRUG)) Q:DRUG=""  S FDT="" F Z3=0:0 S FDT=$O(^TMP($J,"PRF",CLASS,DRUG,FDT)) Q:'FDT  D RXN Q:$D(DTOUT)!($D(DUOUT))
    9         Q
    10 RXN     I PSORM D
    11         .D:$S($P($G(PSOPAR),"^")&($G(PSTYPE))&('$D(DOD(DFN))):RXCNT=3,'$G(PSTYPE)!($D(DOD(DFN))):RXCNT=6,1:RXCNT=4) HD1^PSOSD2
    12         I 'PSORM D
    13         .D:$S($P($G(PSOPAR),"^")&($G(PSTYPE))&('$D(DOD(DFN))):RXCNT=2,1:RXCNT=5) HD1^PSOSD2
    14         S RXN=0 F Z2=0:0 S RXN=$O(^TMP($J,"PRF",CLASS,DRUG,FDT,RXN)) Q:'RXN  D   Q:$D(DTOUT)!($D(DUOUT))
    15         .S RX0=^TMP($J,"PRF",CLASS,DRUG,FDT,RXN),J=RXN,RX2=$S($D(^PSRX(J,2)):^(2),1:""),RX3=$G(^(3)),RXNO=RXN
    16         .S RXNODE=^PSRX(RXN,0),$P(RXNODE,"^",15)=+$G(^("STA")) D ENSAVE^PSODACT,RXN1
    17         Q
    18 RXN1    S RFL=1,FILL(9999999-$P(RX2,"^",2))=+$P(RX2,"^",2)_"^"_$S($P(RX2,"^",15):"(R)",1:""),FILLS=+$P(RX0,"^",9)
    19         F II=0:0 S II=$O(^PSRX(J,1,II)) Q:'II  S FILL(9999999-^PSRX(J,1,II,0))=+^PSRX(J,1,II,0)_"^"_$S($P(^(0),"^",16):"(R)",1:"") S RFL=RFL+1
    20         S PHYS=$S($D(^VA(200,+$P(RX0,"^",4),0)):$P(^(0),"^"),1:"UNKNOWN")
    21         I 'PSTYPE,ZCLASS=CLASS,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR Q:$D(DTOUT)!($D(DUOUT))  W !
    22         I $S($G(PSTYPE):$Y>48,1:$Y>60)!(ZCLASS]""&(ZCLASS'=CLASS)&($S($G(PSTYPE):$Y+16>IOSL,1:$Y+8>IOSL))) D HD1^PSOSD2 Q:$D(DTOUT)!($D(DUOUT))
    23         I ZCLASS'=CLASS D:$S($G(PSTYPE):$Y>48,1:$Y>60) HD1^PSOSD2 W !,$S('PSORM:"Class: ",1:"Classification: ")_PCLASS,! S ZCLASS=CLASS
    24         I 'PSORM D EIGHTY Q
    25         W !,$S('$D(^PSDRUG(+$P(RX0,"^",6),0)):"",+$P(^PSDRUG(+$P(RX0,"^",6),0),"^",9):"N/F",1:"")," ",$S($D(^PSDRUG(+$P(RX0,"^",6),0)):$P(^(0),"^"),1:"NOT ON FILE")
    26         N ACTS D ACTS
    27         W ?45,"Qty: "_$P(RX0,"^",7)_" for "_$P(RX0,"^",8)_" Days ",?74,$P(RX0,"^"),?84," ",ACTS,?99,$E($P(RX2,"^",6),4,5)_"-"_$E($P(RX2,"^",6),6,7)_"-"_($E($P(RX2,"^",6),1,3)+1700)
    28         W ?110,$E(PHYS,1,30) D COS^PSOSDP
    29         I $G(^PSDRUG(+$P(RX0,"^",6),"PSO"))]"" W !," Message: "_$G(^PSDRUG(+$P(RX0,"^",6),"PSO"))
    30         S RXCNT=RXCNT+1 D SIG W !?9,"Sig: ",$G(BSIG(1))
    31         I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV  W !?14,$G(BSIG(PSREV))
    32         K BSIG,PSREV
    33         S RFS=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF  S RFS=RFS+1
    34         W !?10,"Filled: " F PSIII=0:0 S PSIII=$O(FILL(PSIII)) Q:'PSIII  S Y=FILL(PSIII) W:Y " ",$E($P(Y,"^"),4,5),"-",$E($P(Y,"^"),6,7),"-",($E($P(Y,"^"),1,3)+1700)_$P(Y,"^",2)
    35         S DUPD=$O(^TMP($J,"PRF",CLASS,DRUG,FDT)) I DUPD,RFL<6 D
    36         .S OLDRX2=RX2,OLDJ=J,OLDFILL=FDT,OLDRX=RXN W "  Past Fills:" D DUP S FDT=OLDFILL,J=OLDJ,RX2=OLDRX2,RXN=OLDRX K OLDJ,OLDRX2,OLDFILL,OLDRX
    37         W !?10,"Remaining Refills: "_($P(RX0,"^",9)-RFS),?45,"Clinic: ",$S($D(^SC(+$P(RX0,"^",5),0)):$E($P(^(0),"^"),1,30),1:"UNKNOWN")
    38         W ?105,"Price: " S PRICE=$S($D(^PSDRUG($P(RX0,"^",6),660)):$P(^(660),"^",6),1:0),COST=$P(RX0,"^",7)*PRICE S:COST<1 COST="0"_COST W "$",$J(COST,3,2),! K COST
    39         I 'PSTYPE D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") ^PSOLAB G RXN2
    40         G:$G(DOD(DFN))]"" RXN2
    41         D:+$G(PSOBAR4) BAR S PSRENW=0,PSODEA=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^",3) I PSODEA'["1",PSODEA'["2",PSODEA'["W",$P($G(^PS(53,+$P(RX0,"^",3),0)),"^",5) S PSRENW=1
    42         S PSOIFSUP=$S(PSODEA']"":0,PSODEA["S":1,1:0),RXX=$P(RX0,"^"),RXX(1)="",RXX=$O(^PSRX("B",RXX,RXX(1)))
    43         W:$P($G(^PSRX(RXX,"IB")),"^") !?11,"****COPAY****" D PSRENW^PSOSD2
    44         I PSRENW W !?1,$S(PSOIFSUP:"",'$D(PSOPRINT):"",PSOPRINT]"":PSOPRINT,1:""),?11,"RENEW/MD:" F T=1:1:30 W "_" I T=30 W "VA#:" F I=1:1:10 W "_" I I=10 D
    45         .W "DATE__________ REFILL"
    46         .W $S($P(RX0,"^",8)'<60&($P(RX0,"^",8)'>89):" 0 1 2"_$S('CS:" 3 4 5",1:""),$P(RX0,"^",8)<60:" 0 1 2 3 4 5"_$S('CS:" 6 7 8 9 10 11",1:""),1:" 0 1"_$S('CS:" 2 3",1:"")),!
    47         I "ASH"[$E($P(RX0,"^",15)),PSTYPE D
    48         .W !?21,"DISCONTINUE/MD:" F T=1:1:30 W "_" I T=30 W "VA#:" F I=1:1:10 W "_" I I=10 W "DATE__________",!
    49         D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") PRINT^PSOLAB
    50 RXN2    W ! K RX0,RX3,RX2,PRDT,LABEL,PHYS,PSI,PSII,PSIII,II,Y,SIG,X,FILL,FILLS,PHYS,Z9,PRICE,I,T,RXX
    51         Q
    52 SIG     K FSIG,BSIG I $P($G(^PSRX(RXN,"SIG")),"^",2) D FSIG^PSOUTLA("R",RXN,$S('PSORM:64,$E(IOST)="C":64,1:114)) F PSREV=1:1 Q:'$D(FSIG(PSREV))  S BSIG(PSREV)=FSIG(PSREV)
    53         K FSIG,PSREV I '$P($G(^PSRX(RXN,"SIG")),"^",2) D EN3^PSOUTLA1(RXN,$S('PSORM:64,$E(IOST)="C":64,1:114))
    54         Q
    55 DUP     ;DUP DRUG
    56         F Z4=0:0 Q:RFL>9  S FDT=$O(^TMP($J,"PRF",CLASS,DRUG,FDT)) Q:'FDT  D
    57         .F Z5=0:0 S Z5=$O(^TMP($J,"PRF",CLASS,DRUG,FDT,Z5)) Q:'Z5  S RX2=$S($D(^PSRX(Z5,2)):^(2),1:"") D:"DE"[$E($P(^TMP($J,"PRF",CLASS,DRUG,FDT,Z5),"^",15))
    58         ..K FILL S FILL(9999999-$P(RX2,"^",2))=+$P(RX2,"^",2)_"^"_$S($P(RX2,"^",15):"(R)",1:"") F II=0:0 S II=$O(^PSRX(Z5,1,II)) Q:'II  S FILL(9999999-$P(^PSRX(Z5,1,II,0),"^"))=$P(^PSRX(Z5,1,II,0),"^")_"^"_$S($P(^(0),"^",16):"(R)",1:"")
    59         ..F PSII=0:0 S PSII=$O(FILL(PSII)) Q:'PSII  W:($X+8)>$S('PSORM:80,1:IOM) !?9 S Y=FILL(PSII) W " ",$E($P(Y,"^"),4,5)_"-"_$E($P(Y,"^"),6,7)_"-"_($E($P(Y,"^"),1,3)+1700)_$P(Y,"^",2)
    60         ..K ^TMP($J,"PRF",CLASS,DRUG,FDT,Z5)
    61         Q
    62 BAR     ;barcode
    63         I PSOBAR4 S X="S",X2=PSOINST_"-"_RXN W !?15 S X1=$X W @PSOBAR3,X2,@PSOBAR2,$C(13) S $X=0
    64         Q
    65 EIGHTY  ;prints profile in 80 column format
    66         W !,$S('$D(^PSDRUG(+$P(RX0,"^",6),0)):"",+$P(^PSDRUG(+$P(RX0,"^",6),0),"^",9):"N/F",1:"")," ",$S($D(^PSDRUG(+$P(RX0,"^",6),0)):$P(^(0),"^"),1:"NOT ON FILE"),?45,"Rx #: "_$P(RX0,"^")
    67         I $G(^PSDRUG(+$P(RX0,"^",6),"PSO"))]"" W !," Message: "_$G(^PSDRUG(+$P(RX0,"^",6),"PSO"))
    68         N ACTS D ACTS
    69         W !?1,"Qty: "_$P(RX0,"^",7)_" for "_$P(RX0,"^",8)_" Days  "_ACTS,"  Exp: "_$E($P(RX2,"^",6),4,5)_"-"_$E($P(RX2,"^",6),6,7)_"-"_($E($P(RX2,"^",6),1,3)+1700)
    70         W ?48," Prov: "_$E(PHYS,1,30) I $P($G(^PSRX(J,3)),"^",3),$D(^VA(200,+$P($G(^(3)),"^",3),0)) W !,?43,"COSIGNER: "_$P($G(^VA(200,+$P(^PSRX(J,3),"^",3),0)),"^")
    71         S RXCNT=RXCNT+1 D SIG W !?9,"Sig: ",$G(BSIG(1))
    72         I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV  W !?14,$G(BSIG(PSREV))
    73         K BSIG,PSREV
    74         S RFS=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF  S RFS=RFS+1
    75         W !?10,"Filled: " F PSIII=0:0 S PSIII=$O(FILL(PSIII)) Q:'PSIII  S Y=FILL(PSIII) W:Y " ",$E($P(Y,"^"),4,5),"-",$E($P(Y,"^"),6,7),"-",($E($P(Y,"^"),1,3)+1700)_$P(Y,"^",2)
    76         S DUPD=$O(^TMP($J,"PRF",CLASS,DRUG,FDT)) I DUPD,RFL<6 D
    77         .S OLDRX2=RX2,OLDJ=J,OLDFILL=FDT,OLDRX=RXN W "  Past Fills:" D DUP S FDT=OLDFILL,J=OLDJ,RX2=OLDRX2,RXN=OLDRX K OLDJ,OLDRX2,OLDFILL,OLDRX
    78         W !?10,"Remaining Refills: "_($P(RX0,"^",9)-RFS),?45,"Clinic: ",$S($D(^SC(+$P(RX0,"^",5),0)):$E($P(^(0),"^"),1,30),1:"UNKNOWN")
    79         W !?10,"Price: " S PRICE=$S($D(^PSDRUG($P(RX0,"^",6),660)):$P(^(660),"^",6),1:0),COST=$P(RX0,"^",7)*PRICE S:COST<1 COST="0"_COST W "$",$J(COST,3,2),! K COST
    80         I 'PSTYPE D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") ^PSOLAB G RXN2
    81         G:$G(DOD(DFN))]"" RXN3
    82         D:+$G(PSOBAR4) BAR S PSRENW=0,PSODEA=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^",3) I PSODEA'["1",PSODEA'["2",PSODEA'["W",$P($G(^PS(53,+$P(RX0,"^",3),0)),"^",5) S PSRENW=1
    83         S PSOIFSUP=$S(PSODEA']"":0,PSODEA["S":1,1:0),RXX=$P(RX0,"^"),RXX(1)="",RXX=$O(^PSRX("B",RXX,RXX(1)))
    84         W:$P($G(^PSRX(RXX,"IB")),"^") !?11,"****COPAY****" D PSRENW^PSOSD2
    85         I PSRENW W !?1,$S(PSOIFSUP:"",'$D(PSOPRINT):"",PSOPRINT]"":PSOPRINT,1:""),?6,"RENEW/MD:" F T=1:1:30 W "_" I T=30 W "VA#:" F I=1:1:10 W "_" I I=10 D
    86         .W "DATE__________",!?6,"REFILLS"
    87         .W $S($P(RX0,"^",8)'<60&($P(RX0,"^",8)'>89):" 0 1 2"_$S('CS:" 3 4 5",1:""),$P(RX0,"^",8)<60:" 0 1 2 3 4 5"_$S('CS:" 6 7 8 9 10 11",1:""),1:" 0 1"_$S('CS:" 2 3",1:"")),!
    88         I "ASH"[$E($P(RX0,"^",15)),PSTYPE D
    89         .W !?11,"DISCONTINUE/MD:" F T=1:1:26 W "_" I T=26 W "VA#:" F I=1:1:10 W "_" I I=10 W "DATE__________",!
    90         D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") PRINT^PSOLAB
    91 RXN3    W ! K RX0,RX3,RX2,PRDT,LABEL,PHYS,PSI,PSII,PSIII,II,Y,SIG,X,FILL,FILLS,PHYS,Z9,PRICE,I,T,RXX
    92         Q
    93 ACTS    ;
    94         S ACTS=$S($P(RX0,"^",15)["PENDING":"PENDING",$P(RX0,"^",15)["Suspended":"Active/Susp",1:$P(RX0,"^",15))
    95         Q
     1PSOSD0 ;BHAM ISC/SAB - action or informational profile cont. ;3/24/93
     2 ;;7.0;OUTPATIENT PHARMACY;**2,19,40,66,107,110,258**;DEC 1997;Build 4
     3 ;External reference to ^PS(50.605 supported by DBIA 696
     4 ;External reference to ^SC supported by DBIA 10040
     5 ;External reference to ^PSDRUG supported by DBIA 221
     6CLASS S (ZCLASS,CLASS)="",RXCNT=0 F Z0=0:0 S CLASS=$O(^TMP($J,"PRF",CLASS)) Q:CLASS=""  S PCLASS=$S($D(^PS(50.605,+$O(^PS(50.605,"B",CLASS,0)),0)):CLASS_" - "_$P(^(0),"^",2),1:"UNCLASSIFIED") D DRUG Q:$D(DTOUT)!($D(DUOUT))
     7 Q
     8DRUG S DRUG="" F Z1=0:0 S DRUG=$O(^TMP($J,"PRF",CLASS,DRUG)) Q:DRUG=""  S FDT="" F Z3=0:0 S FDT=$O(^TMP($J,"PRF",CLASS,DRUG,FDT)) Q:'FDT  D RXN Q:$D(DTOUT)!($D(DUOUT))
     9 Q
     10RXN I PSORM D
     11 .D:$S($P($G(PSOPAR),"^")&($G(PSTYPE))&('$D(DOD(DFN))):RXCNT=3,'$G(PSTYPE)!($D(DOD(DFN))):RXCNT=6,1:RXCNT=4) HD1^PSOSD2
     12 I 'PSORM D
     13 .D:$S($P($G(PSOPAR),"^")&($G(PSTYPE))&('$D(DOD(DFN))):RXCNT=2,1:RXCNT=5) HD1^PSOSD2
     14 S RXN=0 F Z2=0:0 S RXN=$O(^TMP($J,"PRF",CLASS,DRUG,FDT,RXN)) Q:'RXN  D   Q:$D(DTOUT)!($D(DUOUT))
     15 .S RX0=^TMP($J,"PRF",CLASS,DRUG,FDT,RXN),J=RXN,RX2=$S($D(^PSRX(J,2)):^(2),1:""),RX3=$G(^(3)),RXNO=RXN
     16 .S RXNODE=^PSRX(RXN,0),$P(RXNODE,"^",15)=+$G(^("STA")) D ENSAVE^PSODACT,RXN1
     17 Q
     18RXN1 S RFL=1,FILL(9999999-$P(RX2,"^",2))=+$P(RX2,"^",2)_"^"_$S($P(RX2,"^",15):"(R)",1:""),FILLS=+$P(RX0,"^",9)
     19 F II=0:0 S II=$O(^PSRX(J,1,II)) Q:'II  S FILL(9999999-^PSRX(J,1,II,0))=+^PSRX(J,1,II,0)_"^"_$S($P(^(0),"^",16):"(R)",1:"") S RFL=RFL+1
     20 S PHYS=$S($D(^VA(200,+$P(RX0,"^",4),0)):$P(^(0),"^"),1:"UNKNOWN")
     21 I 'PSTYPE,ZCLASS=CLASS,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR Q:$D(DTOUT)!($D(DUOUT))  W !
     22 I $S($G(PSTYPE):$Y>48,1:$Y>60)!(ZCLASS]""&(ZCLASS'=CLASS)&($S($G(PSTYPE):$Y+16>IOSL,1:$Y+8>IOSL))) D HD1^PSOSD2 Q:$D(DTOUT)!($D(DUOUT))
     23 I ZCLASS'=CLASS D:$S($G(PSTYPE):$Y>48,1:$Y>60) HD1^PSOSD2 W !,$S('PSORM:"Class: ",1:"Classification: ")_PCLASS,! S ZCLASS=CLASS
     24 I 'PSORM D EIGHTY Q
     25 W !,$S('$D(^PSDRUG(+$P(RX0,"^",6),0)):"",+$P(^PSDRUG(+$P(RX0,"^",6),0),"^",9):"N/F",1:"")," ",$S($D(^PSDRUG(+$P(RX0,"^",6),0)):$P(^(0),"^"),1:"NOT ON FILE")
     26 N ACTS D ACTS
     27 W ?45,"Qty: "_$P(RX0,"^",7)_" for "_$P(RX0,"^",8)_" Days ",?74,$P(RX0,"^"),?84," ",ACTS,?99,$E($P(RX2,"^",6),4,5)_"-"_$E($P(RX2,"^",6),6,7)_"-"_($E($P(RX2,"^",6),1,3)+1700)
     28 W ?110,$E(PHYS,1,30) D COS^PSOSDP
     29 I $G(^PSDRUG(+$P(RX0,"^",6),"PSO"))]"" W !," Message: "_$G(^PSDRUG(+$P(RX0,"^",6),"PSO"))
     30 S RXCNT=RXCNT+1 D SIG W !?9,"Sig: ",$G(BSIG(1))
     31 I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV  W !?14,$G(BSIG(PSREV))
     32 K BSIG,PSREV
     33 S RFS=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF  S RFS=RFS+1
     34 W !?10,"Filled: " F PSIII=0:0 S PSIII=$O(FILL(PSIII)) Q:'PSIII  S Y=FILL(PSIII) W:Y " ",$E($P(Y,"^"),4,5),"-",$E($P(Y,"^"),6,7),"-",($E($P(Y,"^"),1,3)+1700)_$P(Y,"^",2)
     35 S DUPD=$O(^TMP($J,"PRF",CLASS,DRUG,FDT)) I DUPD,RFL<6 D
     36 .S OLDRX2=RX2,OLDJ=J,OLDFILL=FDT,OLDRX=RXN W "  Past Fills:" D DUP S FDT=OLDFILL,J=OLDJ,RX2=OLDRX2,RXN=OLDRX K OLDJ,OLDRX2,OLDFILL,OLDRX
     37 W !?10,"Remaining Refills: "_($P(RX0,"^",9)-RFS),?45,"Clinic: ",$S($D(^SC(+$P(RX0,"^",5),0)):$E($P(^(0),"^"),1,30),1:"UNKNOWN")
     38 W ?105,"Price: " S PRICE=$S($D(^PSDRUG($P(RX0,"^",6),660)):$P(^(660),"^",6),1:0),COST=$P(RX0,"^",7)*PRICE S:COST<1 COST="0"_COST W "$",$J(COST,3,2),! K COST
     39 I 'PSTYPE D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") ^PSOLAB G RXN2
     40 G:$G(DOD(DFN))]"" RXN2
     41 D:+$G(PSOBAR4) BAR S PSRENW=0,PSODEA=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^",3) I PSODEA'["2",PSODEA'["W",$P($G(^PS(53,+$P(RX0,"^",3),0)),"^",5) S PSRENW=1
     42 S PSOIFSUP=$S(PSODEA']"":0,PSODEA["S":1,1:0),RXX=$P(RX0,"^"),RXX(1)="",RXX=$O(^PSRX("B",RXX,RXX(1)))
     43 W:$P($G(^PSRX(RXX,"IB")),"^") !?11,"****COPAY****" D PSRENW^PSOSD2
     44 I PSRENW W !?1,$S(PSOIFSUP:"",'$D(PSOPRINT):"",PSOPRINT]"":PSOPRINT,1:""),?11,"RENEW/MD:" F T=1:1:30 W "_" I T=30 W "VA#:" F I=1:1:10 W "_" I I=10 D
     45 .W "DATE__________ REFILL"
     46 .W $S($P(RX0,"^",8)'<60&($P(RX0,"^",8)'>89):" 0 1 2"_$S('CS:" 3 4 5",1:""),$P(RX0,"^",8)<60:" 0 1 2 3 4 5"_$S('CS:" 6 7 8 9 10 11",1:""),1:" 0 1"_$S('CS:" 2 3",1:"")),!
     47 I "ASH"[$E($P(RX0,"^",15)),PSTYPE D
     48 .W !?21,"DISCONTINUE/MD:" F T=1:1:30 W "_" I T=30 W "VA#:" F I=1:1:10 W "_" I I=10 W "DATE__________",!
     49 D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") PRINT^PSOLAB
     50RXN2 W ! K RX0,RX3,RX2,PRDT,LABEL,PHYS,PSI,PSII,PSIII,II,Y,SIG,X,FILL,FILLS,PHYS,Z9,PRICE,I,T,RXX
     51 Q
     52SIG K FSIG,BSIG I $P($G(^PSRX(RXN,"SIG")),"^",2) D FSIG^PSOUTLA("R",RXN,$S('PSORM:64,$E(IOST)="C":64,1:114)) F PSREV=1:1 Q:'$D(FSIG(PSREV))  S BSIG(PSREV)=FSIG(PSREV)
     53 K FSIG,PSREV I '$P($G(^PSRX(RXN,"SIG")),"^",2) D EN3^PSOUTLA1(RXN,$S('PSORM:64,$E(IOST)="C":64,1:114))
     54 Q
     55DUP ;DUP DRUG
     56 F Z4=0:0 Q:RFL>9  S FDT=$O(^TMP($J,"PRF",CLASS,DRUG,FDT)) Q:'FDT  D
     57 .F Z5=0:0 S Z5=$O(^TMP($J,"PRF",CLASS,DRUG,FDT,Z5)) Q:'Z5  S RX2=$S($D(^PSRX(Z5,2)):^(2),1:"") D:"DE"[$E($P(^TMP($J,"PRF",CLASS,DRUG,FDT,Z5),"^",15))
     58 ..K FILL S FILL(9999999-$P(RX2,"^",2))=+$P(RX2,"^",2)_"^"_$S($P(RX2,"^",15):"(R)",1:"") F II=0:0 S II=$O(^PSRX(Z5,1,II)) Q:'II  S FILL(9999999-$P(^PSRX(Z5,1,II,0),"^"))=$P(^PSRX(Z5,1,II,0),"^")_"^"_$S($P(^(0),"^",16):"(R)",1:"")
     59 ..F PSII=0:0 S PSII=$O(FILL(PSII)) Q:'PSII  W:($X+8)>$S('PSORM:80,1:IOM) !?9 S Y=FILL(PSII) W " ",$E($P(Y,"^"),4,5)_"-"_$E($P(Y,"^"),6,7)_"-"_($E($P(Y,"^"),1,3)+1700)_$P(Y,"^",2)
     60 ..K ^TMP($J,"PRF",CLASS,DRUG,FDT,Z5)
     61 Q
     62BAR ;barcode
     63 I PSOBAR4 S X="S",X2=PSOINST_"-"_RXN W !?15 S X1=$X W @PSOBAR3,X2,@PSOBAR2,$C(13) S $X=0
     64 Q
     65EIGHTY ;prints profile in 80 column format
     66 W !,$S('$D(^PSDRUG(+$P(RX0,"^",6),0)):"",+$P(^PSDRUG(+$P(RX0,"^",6),0),"^",9):"N/F",1:"")," ",$S($D(^PSDRUG(+$P(RX0,"^",6),0)):$P(^(0),"^"),1:"NOT ON FILE"),?45,"Rx #: "_$P(RX0,"^")
     67 I $G(^PSDRUG(+$P(RX0,"^",6),"PSO"))]"" W !," Message: "_$G(^PSDRUG(+$P(RX0,"^",6),"PSO"))
     68 N ACTS D ACTS
     69 W !?1,"Qty: "_$P(RX0,"^",7)_" for "_$P(RX0,"^",8)_" Days  "_ACTS,"  Exp: "_$E($P(RX2,"^",6),4,5)_"-"_$E($P(RX2,"^",6),6,7)_"-"_($E($P(RX2,"^",6),1,3)+1700)
     70 W ?48," Prov: "_$E(PHYS,1,30) I $P($G(^PSRX(J,3)),"^",3),$D(^VA(200,+$P($G(^(3)),"^",3),0)) W !,?43,"COSIGNER: "_$P($G(^VA(200,+$P(^PSRX(J,3),"^",3),0)),"^")
     71 S RXCNT=RXCNT+1 D SIG W !?9,"Sig: ",$G(BSIG(1))
     72 I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV  W !?14,$G(BSIG(PSREV))
     73 K BSIG,PSREV
     74 S RFS=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF  S RFS=RFS+1
     75 W !?10,"Filled: " F PSIII=0:0 S PSIII=$O(FILL(PSIII)) Q:'PSIII  S Y=FILL(PSIII) W:Y " ",$E($P(Y,"^"),4,5),"-",$E($P(Y,"^"),6,7),"-",($E($P(Y,"^"),1,3)+1700)_$P(Y,"^",2)
     76 S DUPD=$O(^TMP($J,"PRF",CLASS,DRUG,FDT)) I DUPD,RFL<6 D
     77 .S OLDRX2=RX2,OLDJ=J,OLDFILL=FDT,OLDRX=RXN W "  Past Fills:" D DUP S FDT=OLDFILL,J=OLDJ,RX2=OLDRX2,RXN=OLDRX K OLDJ,OLDRX2,OLDFILL,OLDRX
     78 W !?10,"Remaining Refills: "_($P(RX0,"^",9)-RFS),?45,"Clinic: ",$S($D(^SC(+$P(RX0,"^",5),0)):$E($P(^(0),"^"),1,30),1:"UNKNOWN")
     79 W !?10,"Price: " S PRICE=$S($D(^PSDRUG($P(RX0,"^",6),660)):$P(^(660),"^",6),1:0),COST=$P(RX0,"^",7)*PRICE S:COST<1 COST="0"_COST W "$",$J(COST,3,2),! K COST
     80 I 'PSTYPE D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") ^PSOLAB G RXN2
     81 G:$G(DOD(DFN))]"" RXN3
     82 D:+$G(PSOBAR4) BAR S PSRENW=0,PSODEA=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^",3) I PSODEA'["2",PSODEA'["W",$P($G(^PS(53,+$P(RX0,"^",3),0)),"^",5) S PSRENW=1
     83 S PSOIFSUP=$S(PSODEA']"":0,PSODEA["S":1,1:0),RXX=$P(RX0,"^"),RXX(1)="",RXX=$O(^PSRX("B",RXX,RXX(1)))
     84 W:$P($G(^PSRX(RXX,"IB")),"^") !?11,"****COPAY****" D PSRENW^PSOSD2
     85 I PSRENW W !?1,$S(PSOIFSUP:"",'$D(PSOPRINT):"",PSOPRINT]"":PSOPRINT,1:""),?6,"RENEW/MD:" F T=1:1:30 W "_" I T=30 W "VA#:" F I=1:1:10 W "_" I I=10 D
     86 .W "DATE__________",!?6,"REFILLS"
     87 .W $S($P(RX0,"^",8)'<60&($P(RX0,"^",8)'>89):" 0 1 2"_$S('CS:" 3 4 5",1:""),$P(RX0,"^",8)<60:" 0 1 2 3 4 5"_$S('CS:" 6 7 8 9 10 11",1:""),1:" 0 1"_$S('CS:" 2 3",1:"")),!
     88 I "ASH"[$E($P(RX0,"^",15)),PSTYPE D
     89 .W !?11,"DISCONTINUE/MD:" F T=1:1:26 W "_" I T=26 W "VA#:" F I=1:1:10 W "_" I I=10 W "DATE__________",!
     90 D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") PRINT^PSOLAB
     91RXN3 W ! K RX0,RX3,RX2,PRDT,LABEL,PHYS,PSI,PSII,PSIII,II,Y,SIG,X,FILL,FILLS,PHYS,Z9,PRICE,I,T,RXX
     92 Q
     93ACTS ;
     94 S ACTS=$S($P(RX0,"^",15)["PENDING":"PENDING",$P(RX0,"^",15)["Suspended":"Active/Susp",1:$P(RX0,"^",15))
     95 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSD1.m

    r613 r623  
    1 PSOSD1  ;BHAM ISC/SAB/JMB - action or informational profile cont. ; 10/30/07 10:39am
    2         ;;7.0;OUTPATIENT PHARMACY;**2,17,19,22,40,49,66,107,110,132,233,258,240**;DEC 1997;Build 5
    3         ;External reference to ^PS(59.7 is supported by DBIA 694
    4         ;
    5 INIT    S PRF="" F PSOI=0:0 S DIC="^DPT(",DIC(0)="QEAM" D ^DIC Q:Y<0  D
    6         .S PRF=PRF_+Y_",",DFN=+Y D DEM^VADPT I +VADM(6) W !,"Patient Expired on "_$P(VADM(6),"^",2),! S DOD(DFN)=$P(VADM(6),"^",2) K DFN
    7         .I $L(PRF)>240 W !,$C(7),"MAX NUMBER OF PATIENTS HAS BEEN REACHED" Q
    8         Q:'$L(PRF)  D DAYS G:$D(DUOUT)!($D(DTOUT)) EXIT^PSOSD
    9 DEV     N PSOBARS,PSOBAR0,PSOBAR1 K %ZIS,IOP,ZTSK,ZTQUEUED S PSOION=ION,%ZIS="QM",%ZIS("B")="",%ZIS("A")=$S(PSTYPE:"Select a Printer: ",1:"DEVICE: ") D ^%ZIS K %ZIS I POP S IOP=PSOION D ^%ZIS K IOP,PSOION G EXIT
    10         I $E(IOST)["C",PSTYPE D ^%ZISC W $C(7),!!,"Action Profiles MUST BE SENT TO A PRINTER !!",!,"ONLY INFORMATIONAL PROFILES ARE ALLOWED TO PRINT TO SCREEN !!",! G DEV
    11         S PSOIOS=IOS D DEVBAR^PSOBMST S PSOBAR2=PSOBAR0,PSOBAR3=PSOBAR1
    12         S PSOBAR4=$G(PSOBAR3)]""&($G(PSOBAR2)]"")&(+$P($G(PSOPAR),"^"))
    13         K PSOION I $D(IO("Q")) S ZTDESC="Outpatient Pharmacy Action Profile",ZTRTN="START^PSOSD1",ZTSAVE("ZTREQ")="@" D  D EXIT Q:$G(LM)  G ^PSOSD
    14         .F G="PSORM","PSOPOL","PSONUM","PSOSYS","PSOINST","PSOBAR3","PSOBAR4","PSOBAR2","PSOPAR","PSOPAR7","PRF","PSDAYS","PSDATE","PSTYPE","PSOSITE","PSDATE","PSDAY" S:$D(@G) ZTSAVE(G)=""
    15         .S ZTSAVE("DOD*")="",ZTSAVE("PSOBAR*")="" D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued to Print !!",! K:'$G(LM) ZTSK,IO("Q")
    16         D START G:'$G(LM) ^PSOSD
    17         Q
    18 START   U IO S PSTYPE=$S($D(PSTYPE):PSTYPE,1:0),$P(LINE,"-",132)="-"
    19         F PSIX=1:1 S DFN=$P(PRF,",",PSIX) G:DFN']"" EXIT D ELIG S PAGE=1 D  G:$G(PSQFLG)!($D(DTOUT))!($D(DUOUT)) EXIT
    20         .D PAT^PSOSD Q:$D(DTOUT)!($D(DUOUT))  D  Q:PSQFLG  D RXPAD:PSTYPE W:'$G(PSTYPE)&('$D(^TMP("PSOD",$J))) @IOF D ENSTUFF^PSODACT
    21         ..Q:$D(DUOUT)!($D(DTOUT))  S PSQFLG=0 D ^PSOSD3,NVA^PSOSD3
    22 EXIT    I '$D(PSONOPG) W ! D ^%ZISC K DFN
    23         W:$D(PSONOPG)&('$D(ORVP)) @IOF
    24         K ^TMP($J,"PRF"),^("ACT"),ADDR,ADDRFL,CLASS,CNDT,CNT,DRUG,CLAPP,HDFL,I,II,J,L,LINE,P,PAGE,PSDOB,PSIIX,PSNAME,PSOI,PSQFLG,PSSN,DFN,PSIX,PAGE,PGM,LINE,PRF,PSTYPE,PSDATE,PSDAYS,VAL,VAR,RX,RX0,RX3,RX2,ST,ST0,PSDAY,RF,RFS,PSOBAR3,PSOBAR4,PSOBAR2
    25         D KVA^VADPT K DOD,FILL,DIC,PSCNT,PSDT,PCLASS,PHYS,ZCLASS,PSOPRINT,RXNODE,DIR,X1,X2,PSONUM,PSOPOLP,PSSN4
    26         Q
    27         ;
    28 DAYS    K DIR S DIR("A")="Profile Expiration/Discontinued Cutoff",DIR("B")=120,DIR(0)="N^0:9999:0",DIR("?",1)="Enter the number of days which will cut discontinued and expired Rx's from",DIR("?")="the profile."
    29         D ^DIR Q:$D(DTOUT)!($D(DUOUT))  S PSDAYS=X K DIR S X1=DT,X2=-PSDAYS D C^%DTC S (PSDATE,PSDAY)=X
    30         Q
    31         ;
    32 DFN     S:'$D(PSORM) PSORM=1
    33         S PSOIOS=IOS D DEVBAR^PSOBMST S PSOBAR2=PSOBAR0,PSOBAR3=PSOBAR1
    34         S PSOBAR4=$G(PSOBAR3)]""&($G(PSOBAR2)]"")&(+$P($G(PSOPAR),"^"))
    35         W:$D(PSONOPG)&($G(PSONOPG)'=2) @IOF I '$G(PSOSITE) S PSOSITE=$O(^PS(59,0))
    36         S PRF=DFN_"," D:'$G(PSDAYS)  G START
    37         .S PSDAYS=120,X1=DT,X2=-PSDAYS D C^%DTC S (PSDATE,PSDAY)=X
    38         Q
    39         ;
    40 ELIG    S PSOPRINT=""
    41         D ELIG^VADPT
    42         Q:'$D(VAEL(4))
    43         Q:+VAEL(4)'=1
    44         I $D(VAEL(3)),+VAEL(3)=1,($P(VAEL(3),"^",2)<50) S PSOPRINT="SC NSC"
    45         D KVAR^VADPT
    46         Q
    47         ;
    48 RXPAD   N K Q:$G(DOD(DFN))]""  D HD F CNT=1:1:4 S LF="!?45" D  Q:$Y+14>IOSL
    49         .W !?4,"Name: "_PSNAME,?33,"ID#: "_PSSN4,?58,"DOB: "_PSDOB
    50         .W !!,CNT,?4,"Medication: ",LN,$E(LN,1,11),!!?4,"Outpatient Directions: ",LN,!?4
    51         .W $E(LN,1,3),"SC",$E(LN,1,3),"NSC","  Quantity: _____    Days Supply _____   "
    52         .W:'$G(PSORM) @LF W "Refills: 0 1 2 3 4 5 6 7 8 9 10 11"
    53         .W !!?4,$E(LN,1,35)," ",$E(LN,1,14)," ",$E(LN,1,24)
    54         .W !?4,"Provider's Signature",?40,"DEA #",?55,"Date/Time",!!,$E(LINE,1,$S('PSORM:80,1:IOM))
    55         K LF Q
    56         ;
    57 HD      S FN=DFN S:'$D(PSORM) PSORM=1
    58         D ELIG^PSOSD1,DEM^VADPT,INP^VADPT,ADD^VADPT,PID^VADPT S PSSN=VA("PID"),PSSN4=VA("BID"),ADDRFL=$S(+VAPA(9):"Temporary ",1:"")
    59         I +VADM(6) S DOD(DFN)=$P(VADM(6),"^",2)
    60         S PSNAME=$E(VADM(1),1,28),PSDOB=$P(VADM(3),"^",2) I $D(IOF),$G(PAGE)'=1 W @IOF
    61         W "Action Rx Profile",?47,"Run Date: " S Y=DT D DT^DIO2 W ?71,"Page: "_PAGE S PAGE=PAGE+1,X=$$SITE^VASITE
    62         W !,"Sorted by drug classification for Rx's currently active"_$S('PSDAYS:" only.",1:"") W:PSDAYS !,"and for those Rx's that have been inactive less than "_PSDAYS_" days."
    63         W @$S(PSORM:"?70",1:"!"),"Site: VAMC "_$P(X,"^",2)_" ("_$P(X,"^",3)_")",!,$E(LINE,1,$S('PSORM:80,1:IOM)-1)
    64         I $P(VAIN(4),"^",2)]"",+$P($G(^PS(59.7,1,40.1)),"^") W !,"Outpatient prescriptions are discontinued 72 hours after admission.",!
    65         W !?1,"Name  : ",PSNAME,?30,"ID#: "_PSSN4 W ?58,"Action Date: ________" W !?1,"DOB   : "_PSDOB
    66         W:ADDRFL]"" ?30,ADDRFL,! W ?30,"Address  :"
    67         I $G(ADDRFL)="" D CHECKBAI
    68         W ?41,VAPA(1) W:VAPA(2)]"" !?41,VAPA(2) W:VAPA(3)]"" !?41,VAPA(3) W !?41,VAPA(4)_", "_$P(VAPA(5),"^",2)_"  "_$S(VAPA(11)]"":$P(VAPA(11),"^",2),1:VAPA(6)),!?30,"Phone    : "_VAPA(8)
    69         I PSOBAR4 S X="S",X2=PSSN W @$S('PSORM:"!?30",1:"?$X+5") S X1=$X W @PSOBAR3,X2,@PSOBAR2,$C(13) S $X=0
    70         S (WT,HT)="",X="GMRVUTL" X ^%ZOSF("TEST") I $T D
    71         .F GMRVSTR="WT","HT" S VM=GMRVSTR D EN6^GMRVUTL S @VM=X,$P(@VM,"^")=$E($P(@VM,"^"),4,5)_"/"_$E($P(@VM,"^"),6,7)_"/"_($E($P(@VM,"^"),1,3)+1700)
    72         .S X=$P(WT,"^",8),Y=$J(X/2.2,0,2),$P(WT,"^",9)=Y,X=$P(HT,"^",8),Y=$J(2.54*X,0,2),$P(HT,"^",9)=Y
    73         W !!,"WEIGHT(Kg): " W:+$P(WT,"^",8) $P(WT,"^",9)_" ("_$P(WT,"^")_")" W ?41,"HEIGHT(cm): " W:$P(HT,"^",8) $P(HT,"^",9)_" ("_$P(HT,"^")_")" K VM,WT,HT
    74         D GMRA^PSODEM W !,$E(LINE,1,$S('PSORM:80,1:IOM)-1),!,"Instructions to the provider:",!,"A prescription blank (VA FORM 10-2577f) must be used for All Class II NARCOTICS."
    75         S (ELN,LN,LINE)="",$P(LN,"_",53)="",$P(LINE,"-",132)=""
    76         W !,$E(LINE,1,$S('PSORM:80,1:IOM)-1),!?4,"OTHER MEDICATIONS:",!
    77         Q
    78 LM      ;prints AP from listamn action
    79         S X=$$SITE^VASITE,PSOINST=$P(X,"^",3) K X
    80         K DIR S DIR("A")="Action or Informational (A or I): ",DIR("?",1)="Enter 'A' for action profile",DIR("?",2)="      'I' for informational profile",DIR("?")="      'E' to EXIT process",DIR("B")="A",DIR(0)="SAM^1:Action;0:Informational;E:Exit"
    81         D ^DIR K DIR Q:Y="E"!($D(DIRUT))  S PSTYPE=Y,LM=1
    82         I '$P($G(PSOSYS),"^",6) S PSOPOL=0 G ASK
    83         K DIR S DIR("A")="Do you want generate a Polypharmacy report?: ",DIR("?",1)="Enter 'Y' to generate report",DIR("?",2)="      'N' if you do not want the report",DIR("?")="      'E' to EXIT process",DIR("B")="NO",DIR(0)="SA^1:YES;0:NO;E:Exit"
    84         D ^DIR S PSOPOL=$S(Y:1,1:0) G:Y="E"!($D(DIRUT)) EXIT G:'PSOPOL ASK
    85         K DIR S DIR("A")="Minimum Number of Active Prescriptions",DIR("B")=7,DIR(0)="N^1:100:0" D ^DIR S PSONUM=Y G:$D(DIRUT) EXIT
    86         K DIR,DTOUT,DIRUT,DUOUT S DIR("A")="Do you want this Profile to print in 132 columns or 80 columns: ",DIR("B")="132",DIR(0)="SAM^1:132;8:80;E:Exit"
    87         D ^DIR G:Y="E"!($D(DUOUT))!($D(DIRUT)) EXIT S PSORM=$S(Y=1:1,1:0) K DIR,X,Y
    88         ;PSO*7*240 Go to exit if DUOUT or DTOUT
    89 ASK     D DAYS G:($D(DUOUT))!($D(DTOUT)) EXIT S PRF=PSODFN_"," D DEV I $D(ZTSK) S VALMSG="Action Profile Queued to Printer."
    90         D EXIT K LM
    91         Q
    92         ;
    93 CHECKBAI        ;
    94         N PSOBADR
    95         S PSOBADR=$$BADADR^DGUTL3(DFN)
    96         I 'PSOBADR W " " Q
    97         W ?40,"** BAD ADDRESS INDICATED **",!
    98         Q
    99         ;
     1PSOSD1 ;BHAM ISC/SAB/JMB - action or informational profile cont. ;11/18/92
     2 ;;7.0;OUTPATIENT PHARMACY;**2,17,19,22,40,49,66,107,110,132,233,258**;DEC 1997;Build 4
     3 ;External reference to ^PS(59.7 is supported by DBIA 694
     4 ;
     5INIT S PRF="" F PSOI=0:0 S DIC="^DPT(",DIC(0)="QEAM" D ^DIC Q:Y<0  D
     6 .S PRF=PRF_+Y_",",DFN=+Y D DEM^VADPT I +VADM(6) W !,"Patient Expired on "_$P(VADM(6),"^",2),! S DOD(DFN)=$P(VADM(6),"^",2) K DFN
     7 .I $L(PRF)>240 W !,$C(7),"MAX NUMBER OF PATIENTS HAS BEEN REACHED" Q
     8 Q:'$L(PRF)  D DAYS G:$D(DUOUT)!($D(DTOUT)) EXIT^PSOSD
     9DEV N PSOBARS,PSOBAR0,PSOBAR1 K %ZIS,IOP,ZTSK,ZTQUEUED S PSOION=ION,%ZIS="QM",%ZIS("B")="",%ZIS("A")=$S(PSTYPE:"Select a Printer: ",1:"DEVICE: ") D ^%ZIS K %ZIS I POP S IOP=PSOION D ^%ZIS K IOP,PSOION G EXIT
     10 I $E(IOST)["C",PSTYPE D ^%ZISC W $C(7),!!,"Action Profiles MUST BE SENT TO A PRINTER !!",!,"ONLY INFORMATIONAL PROFILES ARE ALLOWED TO PRINT TO SCREEN !!",! G DEV
     11 S PSOIOS=IOS D DEVBAR^PSOBMST S PSOBAR2=PSOBAR0,PSOBAR3=PSOBAR1
     12 S PSOBAR4=$G(PSOBAR3)]""&($G(PSOBAR2)]"")&(+$P($G(PSOPAR),"^"))
     13 K PSOION I $D(IO("Q")) S ZTDESC="Outpatient Pharmacy Action Profile",ZTRTN="START^PSOSD1",ZTSAVE("ZTREQ")="@" D  D EXIT Q:$G(LM)  G ^PSOSD
     14 .F G="PSORM","PSOPOL","PSONUM","PSOSYS","PSOINST","PSOBAR3","PSOBAR4","PSOBAR2","PSOPAR","PSOPAR7","PRF","PSDAYS","PSDATE","PSTYPE","PSOSITE","PSDATE","PSDAY" S:$D(@G) ZTSAVE(G)=""
     15 .S ZTSAVE("DOD*")="",ZTSAVE("PSOBAR*")="" D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued to Print !!",! K:'$G(LM) ZTSK,IO("Q")
     16 D START G:'$G(LM) ^PSOSD
     17 Q
     18START U IO S PSTYPE=$S($D(PSTYPE):PSTYPE,1:0),$P(LINE,"-",132)="-"
     19 F PSIX=1:1 S DFN=$P(PRF,",",PSIX) G:DFN']"" EXIT D ELIG S PAGE=1 D  G:$G(PSQFLG)!($D(DTOUT))!($D(DUOUT)) EXIT
     20 .D PAT^PSOSD Q:$D(DTOUT)!($D(DUOUT))  D  Q:PSQFLG  D RXPAD:PSTYPE W:'$G(PSTYPE)&('$D(^TMP("PSOD",$J))) @IOF D ENSTUFF^PSODACT
     21 ..Q:$D(DUOUT)!($D(DTOUT))  S PSQFLG=0 D ^PSOSD3,NVA^PSOSD3
     22EXIT I '$D(PSONOPG) W ! D ^%ZISC K DFN
     23 W:$D(PSONOPG)&('$D(ORVP)) @IOF
     24 K ^TMP($J,"PRF"),^("ACT"),ADDR,ADDRFL,CLASS,CNDT,CNT,DRUG,CLAPP,HDFL,I,II,J,L,LINE,P,PAGE,PSDOB,PSIIX,PSNAME,PSOI,PSQFLG,PSSN,DFN,PSIX,PAGE,PGM,LINE,PRF,PSTYPE,PSDATE,PSDAYS,VAL,VAR,RX,RX0,RX3,RX2,ST,ST0,PSDAY,RF,RFS,PSOBAR3,PSOBAR4,PSOBAR2
     25 D KVA^VADPT K DOD,FILL,DIC,PSCNT,PSDT,PCLASS,PHYS,ZCLASS,PSOPRINT,RXNODE,DIR,X1,X2,PSONUM,PSOPOLP,PSSN4
     26 Q
     27 ;
     28DAYS K DIR S DIR("A")="Profile Expiration/Discontinued Cutoff",DIR("B")=120,DIR(0)="N^0:9999:0",DIR("?",1)="Enter the number of days which will cut discontinued and expired Rx's from",DIR("?")="the profile."
     29 D ^DIR Q:$D(DTOUT)!($D(DUOUT))  S PSDAYS=X K DIR S X1=DT,X2=-PSDAYS D C^%DTC S (PSDATE,PSDAY)=X
     30 Q
     31 ;
     32DFN S:'$D(PSORM) PSORM=1
     33 S PSOIOS=IOS D DEVBAR^PSOBMST S PSOBAR2=PSOBAR0,PSOBAR3=PSOBAR1
     34 S PSOBAR4=$G(PSOBAR3)]""&($G(PSOBAR2)]"")&(+$P($G(PSOPAR),"^"))
     35 W:$D(PSONOPG)&($G(PSONOPG)'=2) @IOF I '$G(PSOSITE) S PSOSITE=$O(^PS(59,0))
     36 S PRF=DFN_"," D:'$G(PSDAYS)  G START
     37 .S PSDAYS=120,X1=DT,X2=-PSDAYS D C^%DTC S (PSDATE,PSDAY)=X
     38 Q
     39 ;
     40ELIG S PSOPRINT=""
     41 D ELIG^VADPT
     42 Q:'$D(VAEL(4))
     43 Q:+VAEL(4)'=1
     44 I $D(VAEL(3)),+VAEL(3)=1,($P(VAEL(3),"^",2)<50) S PSOPRINT="SC NSC"
     45 D KVAR^VADPT
     46 Q
     47 ;
     48RXPAD N K Q:$G(DOD(DFN))]""  D HD F CNT=1:1:4 S LF="!?45" D  Q:$Y+14>IOSL
     49 .W !?4,"Name: "_PSNAME,?33,"ID#: "_PSSN4,?58,"DOB: "_PSDOB
     50 .W !!,CNT,?4,"Medication: ",LN,$E(LN,1,11),!!?4,"Outpatient Directions: ",LN,!?4
     51 .W $E(LN,1,3),"SC",$E(LN,1,3),"NSC","  Quantity: _____    Days Supply _____   "
     52 .W:'$G(PSORM) @LF W "Refills: 0 1 2 3 4 5 6 7 8 9 10 11"
     53 .W !!?4,$E(LN,1,35)," ",$E(LN,1,14)," ",$E(LN,1,24)
     54 .W !?4,"Provider's Signature",?40,"DEA #",?55,"Date/Time",!!,$E(LINE,1,$S('PSORM:80,1:IOM))
     55 K LF Q
     56 ;
     57HD S FN=DFN S:'$D(PSORM) PSORM=1
     58 D ELIG^PSOSD1,DEM^VADPT,INP^VADPT,ADD^VADPT,PID^VADPT S PSSN=VA("PID"),PSSN4=VA("BID"),ADDRFL=$S(+VAPA(9):"Temporary ",1:"")
     59 I +VADM(6) S DOD(DFN)=$P(VADM(6),"^",2)
     60 S PSNAME=$E(VADM(1),1,28),PSDOB=$P(VADM(3),"^",2) I $D(IOF),$G(PAGE)'=1 W @IOF
     61 W "Action Rx Profile",?47,"Run Date: " S Y=DT D DT^DIO2 W ?71,"Page: "_PAGE S PAGE=PAGE+1,X=$$SITE^VASITE
     62 W !,"Sorted by drug classification for Rx's currently active"_$S('PSDAYS:" only.",1:"") W:PSDAYS !,"and for those Rx's that have been inactive less than "_PSDAYS_" days."
     63 W @$S(PSORM:"?70",1:"!"),"Site: VAMC "_$P(X,"^",2)_" ("_$P(X,"^",3)_")",!,$E(LINE,1,$S('PSORM:80,1:IOM)-1)
     64 I $P(VAIN(4),"^",2)]"",+$P($G(^PS(59.7,1,40.1)),"^") W !,"Outpatient prescriptions are discontinued 72 hours after admission.",!
     65 W !?1,"Name  : ",PSNAME,?30,"ID#: "_PSSN4 W ?58,"Action Date: ________" W !?1,"DOB   : "_PSDOB
     66 W:ADDRFL]"" ?30,ADDRFL,! W ?30,"Address  :"
     67 I $G(ADDRFL)="" D CHECKBAI
     68 W ?41,VAPA(1) W:VAPA(2)]"" !?41,VAPA(2) W:VAPA(3)]"" !?41,VAPA(3) W !?41,VAPA(4)_", "_$P(VAPA(5),"^",2)_"  "_$S(VAPA(11)]"":$P(VAPA(11),"^",2),1:VAPA(6)),!?30,"Phone    : "_VAPA(8)
     69 I PSOBAR4 S X="S",X2=PSSN W @$S('PSORM:"!?30",1:"?$X+5") S X1=$X W @PSOBAR3,X2,@PSOBAR2,$C(13) S $X=0
     70 S (WT,HT)="",X="GMRVUTL" X ^%ZOSF("TEST") I $T D
     71 .F GMRVSTR="WT","HT" S VM=GMRVSTR D EN6^GMRVUTL S @VM=X,$P(@VM,"^")=$E($P(@VM,"^"),4,5)_"/"_$E($P(@VM,"^"),6,7)_"/"_($E($P(@VM,"^"),1,3)+1700)
     72 .S X=$P(WT,"^",8),Y=$J(X/2.2,0,2),$P(WT,"^",9)=Y,X=$P(HT,"^",8),Y=$J(2.54*X,0,2),$P(HT,"^",9)=Y
     73 W !!,"WEIGHT(Kg): " W:+$P(WT,"^",8) $P(WT,"^",9)_" ("_$P(WT,"^")_")" W ?41,"HEIGHT(cm): " W:$P(HT,"^",8) $P(HT,"^",9)_" ("_$P(HT,"^")_")" K VM,WT,HT
     74 D GMRA^PSODEM W !,$E(LINE,1,$S('PSORM:80,1:IOM)-1),!,"Instructions to the provider:",!,"A prescription blank (VA FORM 10-2577f) must be used for All Class II NARCOTICS."
     75 S (ELN,LN,LINE)="",$P(LN,"_",53)="",$P(LINE,"-",132)=""
     76 W !,$E(LINE,1,$S('PSORM:80,1:IOM)-1),!?4,"OTHER MEDICATIONS:",!
     77 Q
     78LM ;prints AP from listamn action
     79 S X=$$SITE^VASITE,PSOINST=$P(X,"^",3) K X
     80 K DIR S DIR("A")="Action or Informational (A or I): ",DIR("?",1)="Enter 'A' for action profile",DIR("?",2)="      'I' for informational profile",DIR("?")="      'E' to EXIT process",DIR("B")="A",DIR(0)="SAM^1:Action;0:Informational;E:Exit"
     81 D ^DIR K DIR Q:Y="E"!($D(DIRUT))  S PSTYPE=Y,LM=1
     82 I '$P($G(PSOSYS),"^",6) S PSOPOL=0 G ASK
     83 K DIR S DIR("A")="Do you want generate a Polypharmacy report?: ",DIR("?",1)="Enter 'Y' to generate report",DIR("?",2)="      'N' if you do not want the report",DIR("?")="      'E' to EXIT process",DIR("B")="NO",DIR(0)="SA^1:YES;0:NO;E:Exit"
     84 D ^DIR S PSOPOL=$S(Y:1,1:0) G:Y="E"!($D(DIRUT)) EXIT G:'PSOPOL ASK
     85 K DIR S DIR("A")="Minimum Number of Active Prescriptions",DIR("B")=7,DIR(0)="N^1:100:0" D ^DIR S PSONUM=Y G:$D(DIRUT) EXIT
     86 K DIR,DTOUT,DIRUT,DUOUT S DIR("A")="Do you want this Profile to print in 132 columns or 80 columns: ",DIR("B")="132",DIR(0)="SAM^1:132;8:80;E:Exit"
     87 D ^DIR G:Y="E"!($D(DUOUT))!($D(DIRUT)) EXIT S PSORM=$S(Y=1:1,1:0) K DIR,X,Y
     88ASK D DAYS S PRF=PSODFN_"," D DEV I $D(ZTSK) S VALMSG="Action Profile Queued to Printer."
     89 D EXIT K LM
     90 Q
     91 ;
     92CHECKBAI ;
     93 N PSOBADR
     94 S PSOBADR=$$BADADR^DGUTL3(DFN)
     95 I 'PSOBADR W " " Q
     96 W ?40,"** BAD ADDRESS INDICATED **",!
     97 Q
     98 ;

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSIGMX.m

    r613 r623  
    1 PSOSIGMX        ;BIR/RTR-Utility routine to calculate Max Refills for CPRS ; 7/25/07 11:17am
    2         ;;7.0;OUTPATIENT PHARMACY;**46,78,108,131,222,206**;DEC 1997;Build 39
    3         ;External reference to PS(55 supported by DBIA 2228
    4         ;External reference to PSDRUG( supported by DBIA 221
    5         ;External reference to YSCL(603.01 supported by DBIA 2697
    6         ;External reference to PS(50.7 supported by DBIA 2223
    7         ;
    8         ;PSOQX("PATIENT")=patient DFN
    9         ;PSOQX("DAYS SUPPLY")=Days Supply ->Optional ??
    10         ;PSOQX("DRUG")=File 50 ien ->Optional
    11         ;PSOQX("ITEM")=File 50.7 ien -> we may not use this
    12         ;PSOQX("DISCHARGE")=1 if the order is for a Discharge
    13         ;
    14         ;PSOQX("MAX")=Returned max refills allowed
    15         ;
    16 EN      ;
    17         S PSOQX("MAX")=11
    18         N DFN,VAROOT,PSOWRF,PSOMXAUT,PSOMXAUX,PSOCDEA,PSOCSX,PSOMXRX,PSOMX1,PSODYX,PSODYX1,PSOMXPAT,PSOMXSTA
    19         S PSOMXAUT=0
    20         S PSOMXAUX=+$P($G(^PS(55,+$G(PSOQX("PATIENT")),"PS")),"^")
    21         I PSOMXAUX,$P($G(^PS(53,+$G(PSOMXAUX),0)),"^")["AUTH ABS" S VAROOT="PSOWRF",DFN=$G(PSOQX("PATIENT")) D IN5^VADPT I '$G(PSOWRF(5)) S PSOMXAUT=1
    22         S PSOMXSTA=$S($G(PSOQX("DISCHARGE")):0,$G(PSOMXAUT):0,1:+$P($G(^PS(55,+$G(PSOQX("PATIENT")),"PS")),"^")) I PSOMXSTA S PSOMXRX=$P($G(^PS(53,PSOMXSTA,0)),"^",4)
    23         I 'PSOMXSTA S PSOMXRX=11
    24         K PSOCDEA S PSOCSX=0
    25         S PSONODD=0 I '$G(PSOQX("DRUG")),$G(PSOQX("ITEM")) D  S PSONODD=1
    26         . N A,B,PSOCDEA,DEA,PSOAPP,PSOINA,%,%H,%I,X,PSOFIRST
    27         . S DEA=99,(A,PSOFIRST)=""
    28         . F  S A=$O(^PS(50.7,"A50",PSOQX("ITEM"),A)) Q:'A  D
    29         .. S PSOCDEA=$P($G(^PSDRUG(A,0)),"^",3),PSOAPP=$P($G(^(2)),"^",3),PSOINA=$G(^("I"))
    30         .. I PSOAPP'["O" Q
    31         .. D NOW^%DTC I PSOINA]"",PSOINA'>% Q
    32         .. I PSOFIRST="" S PSOFIRST=A
    33         .. I PSOCDEA?1N.E,PSOCDEA<DEA S DEA=PSOCDEA,PSOQX("DRUG")=A
    34         . I $G(PSOQX("DRUG"))="" S PSOQX("DRUG")=PSOFIRST
    35         I $G(PSOQX("DRUG")) D
    36         .S PSOCDEA=$P($G(^PSDRUG(PSOQX("DRUG"),0)),"^",3)
    37         .I PSOCDEA["2"!(PSOCDEA["3")!(PSOCDEA["4")!(PSOCDEA["5") S PSOCSX=1
    38         I PSOCSX D
    39         .S PSOQX("MAX")=$S((PSOCDEA[1)!(PSOCDEA[2):0,1:5),PSOMX1=$S($G(PSOMXRX)>PSOQX("MAX"):PSOQX("MAX"),1:$G(PSOMXRX)),PSOQX("MAX")=$S(PSOMX1=5:PSOQX("MAX"),1:PSOMX1)
    40         .S PSOQX("MAX")=$S('PSOQX("MAX"):0,$G(PSOQX("DAYS SUPPLY"))=90:1,1:PSOQX("MAX")),PSODYX=$G(PSOQX("DAYS SUPPLY")),PSODYX1=$S(PSODYX<60:5,PSODYX'<60&(PSODYX'>89):2,PSODYX=90:1,1:0) S PSOQX("MAX")=$S(PSOQX("MAX")'>PSODYX1:PSOQX("MAX"),1:PSODYX1)
    41         I 'PSOCSX!('$G(PSOQX("DRUG"))) D
    42         .S PSOQX("MAX")=11,PSOMX1=$S($G(PSOMXRX)>PSOQX("MAX"):PSOQX("MAX"),1:$G(PSOMXRX)),PSOQX("MAX")=$S(PSOMX1=11:PSOQX("MAX"),1:PSOMX1)
    43         .S PSODYX=$G(PSOQX("DAYS SUPPLY")),PSODYX1=$S(PSODYX<60:11,PSODYX'<60&(PSODYX'>89):5,PSODYX=90:3,1:0) S PSOQX("MAX")=$S(PSOQX("MAX")'>PSODYX1:PSOQX("MAX"),1:PSODYX1)
    44         I $P($G(^PSDRUG(+$G(PSOQX("DRUG")),"CLOZ1")),"^")="PSOCLO1" D  Q
    45         .S PSOMXPAT=$O(^YSCL(603.01,"C",+$G(PSOQX("PATIENT")),0)) I 'PSOMXPAT S PSOQX("MAX")=0 Q
    46         .S PSOMXPAT=$P($G(^YSCL(603.01,PSOMXPAT,0)),"^",3)
    47         .I $D(PSOQX("DAYS SUPPLY")) S PSOQX("MAX")=$S(PSOMXPAT="M"&($G(PSOQX("DAYS SUPPLY"))<8):3,PSOMXPAT="M"&($G(PSOQX("DAYS SUPPLY"))<15):1,PSOMXPAT="B"&($G(PSOQX("DAYS SUPPLY"))<8):1,1:0) Q
    48         .S PSOQX("MAX")=$S(PSOMXPAT="M":3,PSOMXPAT="B":1,1:0)
    49         I $G(PSOQX("DRUG")) I PSOCDEA["A"&(PSOCDEA'["B")!(PSOCDEA["F")!(PSOCDEA[1)!(PSOCDEA[2) S PSOQX("MAX")=0
    50         I PSONODD S PSOQX("DRUG")=0
    51         Q
     1PSOSIGMX ;BIR/RTR-Utility routine to calculate Max Refills for CPRS ;12/28/00
     2 ;;7.0;OUTPATIENT PHARMACY;**46,78,108,131,222**;DEC 1997;Build 12
     3 ;External reference to PS(55 supported by DBIA 2228
     4 ;External reference to PSDRUG( supported by DBIA 221
     5 ;External reference to YSCL(603.01 supported by DBIA 2697
     6 ;External reference to PS(50.7 supported by DBIA 2223
     7 ;
     8 ;PSOQX("PATIENT")=patient DFN
     9 ;PSOQX("DAYS SUPPLY")=Days Supply ->Optional ??
     10 ;PSOQX("DRUG")=File 50 ien ->Optional
     11 ;PSOQX("ITEM")=File 50.7 ien -> we may not use this
     12 ;PSOQX("DISCHARGE")=1 if the order is for a Discharge
     13 ;
     14 ;PSOQX("MAX")=Returned max refills allowed
     15 ;
     16EN ;
     17 S PSOQX("MAX")=11
     18 N DFN,VAROOT,PSOWRF,PSOMXAUT,PSOMXAUX,PSOCDEA,PSOCSX,PSOMXRX,PSOMX1,PSODYX,PSODYX1,PSOMXPAT,PSOMXSTA
     19 S PSOMXAUT=0
     20 S PSOMXAUX=+$P($G(^PS(55,+$G(PSOQX("PATIENT")),"PS")),"^")
     21 I PSOMXAUX,$P($G(^PS(53,+$G(PSOMXAUX),0)),"^")["AUTH ABS" S VAROOT="PSOWRF",DFN=$G(PSOQX("PATIENT")) D IN5^VADPT I '$G(PSOWRF(5)) S PSOMXAUT=1
     22 S PSOMXSTA=$S($G(PSOQX("DISCHARGE")):0,$G(PSOMXAUT):0,1:+$P($G(^PS(55,+$G(PSOQX("PATIENT")),"PS")),"^")) I PSOMXSTA S PSOMXRX=$P($G(^PS(53,PSOMXSTA,0)),"^",4)
     23 I 'PSOMXSTA S PSOMXRX=11
     24 K PSOCDEA S PSOCSX=0
     25 S PSONODD=0 I '$G(PSOQX("DRUG")),$G(PSOQX("ITEM")) D  S PSONODD=1
     26 . N A,B,PSOCDEA,DEA,PSOAPP,PSOINA,%,%H,%I,X,PSOFIRST
     27 . S DEA=99,(A,PSOFIRST)=""
     28 . F  S A=$O(^PS(50.7,"A50",PSOQX("ITEM"),A)) Q:'A  D
     29 .. S PSOCDEA=$P($G(^PSDRUG(A,0)),"^",3),PSOAPP=$P($G(^(2)),"^",3),PSOINA=$G(^("I"))
     30 .. I PSOAPP'["O" Q
     31 .. D NOW^%DTC I PSOINA]"",PSOINA'>% Q
     32 .. I PSOFIRST="" S PSOFIRST=A
     33 .. I PSOCDEA?1N.E,PSOCDEA<DEA S DEA=PSOCDEA,PSOQX("DRUG")=A
     34 . I $G(PSOQX("DRUG"))="" S PSOQX("DRUG")=PSOFIRST
     35 I $G(PSOQX("DRUG")) D
     36 .S PSOCDEA=$P($G(^PSDRUG(PSOQX("DRUG"),0)),"^",3)
     37 .I PSOCDEA["2"!(PSOCDEA["3")!(PSOCDEA["4")!(PSOCDEA["5") S PSOCSX=1
     38 I PSOCSX D
     39 .S PSOQX("MAX")=$S(PSOCDEA["2":0,1:5),PSOMX1=$S($G(PSOMXRX)>PSOQX("MAX"):PSOQX("MAX"),1:$G(PSOMXRX)),PSOQX("MAX")=$S(PSOMX1=5:PSOQX("MAX"),1:PSOMX1)
     40 .S PSOQX("MAX")=$S('PSOQX("MAX"):0,$G(PSOQX("DAYS SUPPLY"))=90:1,1:PSOQX("MAX")),PSODYX=$G(PSOQX("DAYS SUPPLY")),PSODYX1=$S(PSODYX<60:5,PSODYX'<60&(PSODYX'>89):2,PSODYX=90:1,1:0) S PSOQX("MAX")=$S(PSOQX("MAX")'>PSODYX1:PSOQX("MAX"),1:PSODYX1)
     41 I 'PSOCSX!('$G(PSOQX("DRUG"))) D
     42 .S PSOQX("MAX")=11,PSOMX1=$S($G(PSOMXRX)>PSOQX("MAX"):PSOQX("MAX"),1:$G(PSOMXRX)),PSOQX("MAX")=$S(PSOMX1=11:PSOQX("MAX"),1:PSOMX1)
     43 .S PSODYX=$G(PSOQX("DAYS SUPPLY")),PSODYX1=$S(PSODYX<60:11,PSODYX'<60&(PSODYX'>89):5,PSODYX=90:3,1:0) S PSOQX("MAX")=$S(PSOQX("MAX")'>PSODYX1:PSOQX("MAX"),1:PSODYX1)
     44 I $P($G(^PSDRUG(+$G(PSOQX("DRUG")),"CLOZ1")),"^")="PSOCLO1" D  Q
     45 .S PSOMXPAT=$O(^YSCL(603.01,"C",+$G(PSOQX("PATIENT")),0)) I 'PSOMXPAT S PSOQX("MAX")=0 Q
     46 .S PSOMXPAT=$P($G(^YSCL(603.01,PSOMXPAT,0)),"^",3)
     47 .I $D(PSOQX("DAYS SUPPLY")) S PSOQX("MAX")=$S(PSOMXPAT="M"&($G(PSOQX("DAYS SUPPLY")))<8:3,PSOMXPAT="M"&($G(PSOQX("DAYS SUPPLY")))<15:1,PSOMXPAT="B"&($G(PSOQX("DAYS SUPPLY")))<8:1,1:0) Q
     48 .S PSOQX("MAX")=$S(PSOMXPAT="M":3,PSOMXPAT="B":1,1:0)
     49 I $G(PSOQX("DRUG")) I PSOCDEA["A"&(PSOCDEA'["B")!(PSOCDEA["F") S PSOQX("MAX")=0
     50 I PSONODD S PSOQX("DRUG")=0
     51 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSUPOE.m

    r613 r623  
    1 PSOSUPOE        ;BIR/RTR - Suspense pull via Listman ;3/1/96
    2         ;;7.0;OUTPATIENT PHARMACY;**8,21,27,34,130,148,281**;DEC 1997;Build 41
    3         ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
    4 SEL     I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
    5         N PSOGETF,PSOGET,PSOGETFN,ORD,ORN,MW,PDUZ,PSLST,PSOSQ,PSOSQRTE,PSOSQMTH,PSPOP,PSOX1,PSOX2,RXLTOP,RXREC,SFN,SORD,SORN,VALMCNT
    6         K DIR,DUOUT,DTOUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!('Y) S VALMSG="Nothing pulled from suspense!",VALMBCK="" Q
    7         S PSLST=Y
    8 SELQ    D FULL^VALM1
    9         K DIR S DIR("A")="Select routing for Rx(s)",DIR(0)="S^M:MAIL;W:WINDOW",DIR("B")="WINDOW" D ^DIR K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) G END
    10         S PSOSQRTE=Y I $G(PSOSQRTE)="W",$P(PSOPAR,"^",12) K DIR S DIR(0)="FO^2:60",DIR("A")="METHOD OF PICK-UP" D ^DIR S PSOSQMTH=$G(Y) K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) G END
    11         W ! K DIR S DIR(0)="Y",DIR("A")="Pull Rx(s) and delete from suspense",DIR("B")="YES" D  D ^DIR K DIR I Y'=1 G END
    12         .S DIR("?",1)="Enter Yes to pull selected Rx(s) from suspense. Since(Rx(s) pulled early from",DIR("?",2)="suspense are not associated with a printed batch, these Rx(s) cannot be"
    13         .S DIR("?",3)="reprinted from suspense using the 'Reprint batches from suspense' option.",DIR("?")="Therefore, any Rx(s) pulled early from suspense will be deleted from suspense."
    14         Q:$G(PULLONE)
    15         F SORD=1:1:$L(PSLST,",") Q:$P(PSLST,",",SORD)']""  S SORN=$P(PSLST,",",SORD) D:+PSOLST(SORN)=52 BEG
    16         S VALMBCK="R"
    17         I '$G(PSOSQ) S VALMSG="No Rx's pulled from suspense!"
    18         Q
    19 BEG     ;
    20         S RXREC=$P(PSOLST(SORN),"^",2)
    21 BEGQ    Q:'$D(^PSRX(+$G(RXREC),0))
    22         D PSOL^PSSLOCK(RXREC) I '$G(PSOMSG) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P($G(^PSRX(RXREC,0)),"^")),! K PSOMSG D DIR Q
    23         K PSOMSG I $P($G(^PSRX(RXREC,"STA")),"^")'=5 W !!,"Rx# ",$P(^PSRX(RXREC,0),"^")," is not on Suspense!" D DIR,ULRX Q
    24         S SFN=$O(^PS(52.5,"B",RXREC,0)) I 'SFN D DIR,ULRX Q
    25         S PDUZ=DUZ I +$G(^PS(52.5,SFN,"P")) W !,">>> Rx #",$P(^PSRX(+$P(^(0),"^"),0),"^")," ALREADY PRINTED FROM SUSPENSE.",!,?5,"USE THE REPRINT OPTION TO REPRINT LABEL." D DIR,ULRX Q
    26         I +$P($G(^PSRX(RXREC,2)),"^",6)<DT,+$P($G(^("STA")),"^")<11 D  S DIE=52,DA=RXREC,DR="100///11" D ^DIE S DA=SFN,DIK="^PS(52.5," D ^DIK K DIE,DA,DIK W !,"Rx # "_$P(^PSRX(RXREC,0),"^")_" has expired!" D DIR,ULRX Q
    27         .N PSCOU,AAA,VVV,QQQ,PSOPRT,PSOEXPI D EX^PSOSUTL
    28         I $D(RXRP(RXREC)) W !!,"A reprint has already been requested for Rx # ",$P($G(^PSRX(RXREC,0)),"^") D DIR,ULRX Q
    29         I $D(RXPR(RXREC)) W !!,"A partial has already been requested for Rx # ",$P($G(^PSRX(RXREC,0)),"^") D DIR,ULRX Q
    30         S PSPOP=0 I $G(PSODIV),$P($G(^PS(52.5,SFN,0)),"^",6)'=$G(PSOSITE) D CKDIV I $G(PSPOP) D DIR,ULRX Q
    31         S:$P(^PS(52.5,SFN,0),"^",5) RXPR(RXREC)=$P(^(0),"^",5) S:$P(^PS(52.5,SFN,0),"^",12) RXRP(RXREC)=1
    32         S RXFL(RXREC)=$P($G(^PS(52.5,SFN,0)),"^",13),RXRS(RXREC)=$G(PSODFN),RXLTOP=1
    33         S RXRS(RXREC)=$G(RXRS(RXREC))_"^"_$S($P($G(^PS(52.5,SFN,0)),"^",4)="W":"W",1:"M")_"^"_$P($G(^PSRX(RXREC,"MP")),"^") S PSOGET="M" D GETMW
    34         S RXRS(RXREC)=$G(RXRS(RXREC))_"^"_$G(PSOGETF)_"^"_$G(PSOGETFN)_"^"_$S($G(PSOGET)="W":"W",1:"M")
    35         S $P(^PS(52.5,SFN,0),"^",4)=$G(PSOSQRTE) S MW=$G(PSOSQRTE) N RR,RFCNT D MAILS^PSOSUPAT I $D(PSOSQMTH) S $P(^PSRX(RXREC,"MP"),"^")=$G(PSOSQMTH)
    36         S PSOSQ=1
    37         ;
    38         ; - Submitting Rx to ECME for 3rd Party Billing
    39         I '$D(RXPR(RXREC)) D
    40         . N ACTION,RFL S RFL=$G(RXFL(RXREC)) I RFL="" S RFL=$$LSTRFL^PSOBPSU1(RXREC)
    41         . D ECMESND^PSOBPSU1(RXREC,RFL,,"PP")
    42         . I $$FIND^PSOREJUT(RXREC,RFL) D
    43         . . S ACTION=$$HDLG^PSOREJU1(RXREC,RFL,"79,88","PP","IOQ","Q")
    44         ;
    45         D ULRX K PSOGET,PSOGETF
    46         Q
    47 WIND    ;
    48         N RRT,RRTT,XXXX,JJJJ,PSINTRX,RTETEST,PSOPSO,SSSS
    49         S PBINGRTE=0,PSINTRX=RXREC
    50         I $G(RXPR(RXREC)) S RTETEST=$P($G(^PSRX(RXREC,"P",RXPR(PSINTRX),0)),"^",2) S:RTETEST="W" PBINGRTE=1 Q
    51         S PSOPSO=0 F SSSS=0:0 S SSSS=$O(^PSRX(PSINTRX,1,SSSS)) Q:'SSSS  S PSOPSO=SSSS
    52         I 'PSOPSO S RTETEST=$P($G(^PSRX(PSINTRX,0)),"^",11) S:RTETEST="W" PBINGRTE=1 Q
    53         I PSOPSO S RTETEST=$P($G(^PSRX(PSINTRX,1,PSOPSO,0)),"^",2) S:RTETEST="W" PBINGRTE=1 Q
    54         Q
    55 DIR     ;
    56         W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR Q
    57 END     S VALMSG="Nothing pulled from suspense!",VALMBCK="R" S:$G(PULLONE)=1 PULLONE=2 Q
    58 ADD     ;Add Rx to SPSORX array
    59         I $G(SPSORX("PSOL",1))']"" S SPSORX("PSOL",1)=RXREC_"," Q
    60         F PSOX1=0:0 S PSOX1=$O(SPSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
    61         I $L(SPSORX("PSOL",PSOX2))+$L(RXREC)<220 S SPSORX("PSOL",PSOX2)=SPSORX("PSOL",PSOX2)_RXREC_"," Q
    62         S SPSORX("PSOL",PSOX2+1)=RXREC_","
    63         Q
    64 BBADD   ;
    65         N PSOX1,PSOX2
    66         I $G(BBRX(1))']"" S BBRX(1)=RXREC_"," Q
    67         F PSOX1=0:0 S PSOX1=$O(BBRX(PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
    68         I $L(BBRX(PSOX2))+$L(RXREC)<220 S BBRX(PSOX2)=BBRX(PSOX2)_RXREC_"," Q
    69         S BBRX(PSOX2+1)=RXREC_","
    70         Q
    71 PPLADD  ;
    72         N SZZ,SPSOX1,SPSOX2,LSFN
    73         I $G(PPL)'="",$E(PPL,$L(PPL))'="," S PPL=PPL_","
    74         F SZZ=0:0 S SZZ=$O(RXRS(SZZ)) Q:'SZZ  D
    75         .S LSFN=$O(^PS(52.5,"B",SZZ,0))
    76         .Q:'$G(LSFN)
    77         .Q:$G(^PS(52.5,LSFN,"P"))
    78         .I $G(PPL)="" S PPL=SZZ_"," Q
    79         .I $L(PPL)+$L(SZZ)<220 S PPL=PPL_SZZ_"," Q
    80         .I $G(PSORX("PSOL",2))']"" S PSORX("PSOL",2)=SZZ_"," Q
    81         .F SPSOX1=1:0 S SPSOX1=$O(PSORX("PSOL",SPSOX1)) Q:'SPSOX1  S SPSOX2=SPSOX1
    82         .I $L(PSORX("PSOL",SPSOX2))+$L(SZZ)<220 S PSORX("PSOL",SPSOX2)=PSORX("PSOL",SPSOX2)_SZZ_"," Q
    83         .S PSORX("PSOL",SPSOX2+1)=SZZ_","
    84         Q
    85 CKDIV   ;
    86         I '$P($G(PSOSYS),"^",2) W !!?10,"Rx # ",$P(^PSRX(RXREC,0),"^")," is not a valid choice (Different Division)" S PSPOP=1 Q
    87         I $P($G(PSOSYS),"^",3) W !!?10 K DIR S DIR("A")="Rx # "_$P(^PSRX(RXREC,0),"^")_" is from another division. OK to Pull",DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR I $G(DIRUT)!('Y) S PSPOP=1
    88         Q
    89 SELONE  ;Pull one Rx through Listman
    90         I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q
    91         N ORD,MW,PDUZ,PSLST,PSOSQ,PSOSQRTE,PSOSQMTH,PSPOP,PSOX1,PSOX2,PULLONE,RXLTOP,RXREC,SFN,SORD,SORN,VALMCNT
    92         S PULLONE=1
    93         I +PSOLST(ORN)'=52 S VALMBCK="" Q
    94         I +PSOLST(ORN)=52,$P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")'=5 S VALMSG="Rx is not on Suspense!",VALMBCK="" Q
    95         I +PSOLST(ORN)=52,$D(RXRS($P(PSOLST(ORN),"^",2))) S VALMSG="Pull early has already been requested!",VALMBCK="" Q
    96         D SELQ I $G(PULLONE)=2 S VALMSG="Rx# "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^")_" not pulled from suspense!" Q
    97         I +PSOLST(ORN)=52 S RXREC=$P(PSOLST(ORN),"^",2) D BEGQ S VALMSG="Rx# "_$P($G(^PSRX(+$G(RXREC),0)),"^")_$S($G(PSOSQ):" pulled",1:" not pulled")_" from Suspense!"
    98         S VALMBCK="R"
    99         Q
    100 RESET   ;
    101         N RSDA,RXMW,RXMP,RXSP,RXR,DA,RXPSRX,RXFILL,RXFILLN
    102         F RSDA=0:0 S RSDA=$O(RXRS(RSDA)) Q:'RSDA  D
    103         .S RXSP=$O(^PS(52.5,"B",RSDA,0)) Q:'RXSP
    104         .Q:'$D(^PS(52.5,RXSP,0))
    105         .S RXMW=$S($P($G(RXRS(RSDA)),"^",2)="":"M",1:$P($G(RXRS(RSDA)),"^",2)),RXMP=$P($G(RXRS(RSDA)),"^",3),RXFILL=$P($G(RXRS(RSDA)),"^",4),RXFILLN=$P($G(RXRS(RSDA)),"^",5),RXPSRX=$S($P($G(RXRS(RSDA)),"^",6)="":"M",1:$P($G(RXRS(RSDA)),"^",6))
    106         .I RXMW'="" S $P(^PS(52.5,RXSP,0),"^",4)=RXMW D
    107         ..I RXFILL="P" D  Q
    108         ...I $D(^PSRX(RSDA,"P",+$G(RXFILLN),0)) S $P(^PSRX(RSDA,"P",+$G(RXFILLN),0),"^",2)=$G(RXPSRX),$P(^PSRX(RSDA,"MP"),"^")=RXMP
    109         ..I RXFILL="R",$G(RXFILLN) S DA(1)=RSDA,DA=RXFILLN,DIE="^PSRX("_DA(1)_",1,",DR="2////"_RXPSRX D ^DIE K DIE
    110         ..I RXFILL="O" S DA=RSDA,DIE="^PSRX(",DR="11////"_RXPSRX D ^DIE K DIE
    111         ..S $P(^PSRX(RSDA,"MP"),"^")=RXMP
    112         Q
    113 GETMW   ;
    114         N GETPAR,GETRX,GETCNT
    115         S PSOGETF="O",PSOGETFN=""
    116         S GETPAR=$P($G(^PS(52.5,SFN,0)),"^",5)
    117         I GETPAR S PSOGET=$P($G(^PSRX(RXREC,"P",GETPAR,0)),"^",2),PSOGETF="P",PSOGETFN=GETPAR Q
    118         I '$O(^PSRX(RXREC,1,0)) S PSOGET=$P($G(^PSRX(RXREC,0)),"^",11) Q
    119         S GETRX=0 F GETCNT=0:0 S GETCNT=$O(^PSRX(RXREC,1,GETCNT)) Q:'GETCNT  S GETRX=GETCNT
    120         S PSOGET=$P($G(^PSRX(RXREC,1,+$G(GETRX),0)),"^",2),PSOGETF="R",PSOGETFN=+$G(GETRX)
    121         Q
    122 ULRX    ;
    123         I '$G(RXREC) Q
    124         D PSOUL^PSSLOCK(RXREC)
    125         Q
     1PSOSUPOE ;BIR/RTR - Suspense pull via Listman ;3/1/96
     2 ;;7.0;OUTPATIENT PHARMACY;**8,21,27,34,130,148**;DEC 1997
     3 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
     4SEL I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
     5 N PSOGETF,PSOGET,PSOGETFN,ORD,ORN,MW,PDUZ,PSLST,PSOSQ,PSOSQRTE,PSOSQMTH,PSPOP,PSOX1,PSOX2,RXLTOP,RXREC,SFN,SORD,SORN,VALMCNT
     6 K DIR,DUOUT,DTOUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!('Y) S VALMSG="Nothing pulled from suspense!",VALMBCK="" Q
     7 S PSLST=Y
     8SELQ D FULL^VALM1
     9 K DIR S DIR("A")="Select routing for Rx(s)",DIR(0)="S^M:MAIL;W:WINDOW",DIR("B")="WINDOW" D ^DIR K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) G END
     10 S PSOSQRTE=Y I $G(PSOSQRTE)="W",$P(PSOPAR,"^",12) K DIR S DIR(0)="FO^2:60",DIR("A")="METHOD OF PICK-UP" D ^DIR S PSOSQMTH=$G(Y) K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) G END
     11 W ! K DIR S DIR(0)="Y",DIR("A")="Pull Rx(s) and delete from suspense",DIR("B")="YES" D  D ^DIR K DIR I Y'=1 G END
     12 .S DIR("?",1)="Enter Yes to pull selected Rx(s) from suspense. Since(Rx(s) pulled early from",DIR("?",2)="suspense are not associated with a printed batch, these Rx(s) cannot be"
     13 .S DIR("?",3)="reprinted from suspense using the 'Reprint batches from suspense' option.",DIR("?")="Therefore, any Rx(s) pulled early from suspense will be deleted from suspense."
     14 Q:$G(PULLONE)
     15 F SORD=1:1:$L(PSLST,",") Q:$P(PSLST,",",SORD)']""  S SORN=$P(PSLST,",",SORD) D:+PSOLST(SORN)=52 BEG
     16 S VALMBCK="R"
     17 I '$G(PSOSQ) S VALMSG="No Rx's pulled from suspense!"
     18 Q
     19BEG ;
     20 S RXREC=$P(PSOLST(SORN),"^",2)
     21BEGQ Q:'$D(^PSRX(+$G(RXREC),0))
     22 D PSOL^PSSLOCK(RXREC) I '$G(PSOMSG) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P($G(^PSRX(RXREC,0)),"^")),! K PSOMSG D DIR Q
     23 K PSOMSG I $P($G(^PSRX(RXREC,"STA")),"^")'=5 W !!,"Rx# ",$P(^PSRX(RXREC,0),"^")," is not on Suspense!" D DIR,ULRX Q
     24 S SFN=$O(^PS(52.5,"B",RXREC,0)) I 'SFN D DIR,ULRX Q
     25 S PDUZ=DUZ I +$G(^PS(52.5,SFN,"P")) W !,">>> Rx #",$P(^PSRX(+$P(^(0),"^"),0),"^")," ALREADY PRINTED FROM SUSPENSE.",!,?5,"USE THE REPRINT OPTION TO REPRINT LABEL." D DIR,ULRX Q
     26 I +$P($G(^PSRX(RXREC,2)),"^",6)<DT,+$P($G(^("STA")),"^")<11 D  S DIE=52,DA=RXREC,DR="100///11" D ^DIE S DA=SFN,DIK="^PS(52.5," D ^DIK K DIE,DA,DIK W !,"Rx # "_$P(^PSRX(RXREC,0),"^")_" has expired!" D DIR,ULRX Q
     27 .N PSCOU,AAA,VVV,QQQ,PSOPRT,PSOEXPI D EX^PSOSUTL
     28 I $D(RXRP(RXREC)) W !!,"A reprint has already been requested for Rx # ",$P($G(^PSRX(RXREC,0)),"^") D DIR,ULRX Q
     29 I $D(RXPR(RXREC)) W !!,"A partial has already been requested for Rx # ",$P($G(^PSRX(RXREC,0)),"^") D DIR,ULRX Q
     30 S PSPOP=0 I $G(PSODIV),$P($G(^PS(52.5,SFN,0)),"^",6)'=$G(PSOSITE) D CKDIV I $G(PSPOP) D DIR,ULRX Q
     31 S:$P(^PS(52.5,SFN,0),"^",5) RXPR(RXREC)=$P(^(0),"^",5) S:$P(^PS(52.5,SFN,0),"^",12) RXRP(RXREC)=1
     32 S RXFL(RXREC)=$P($G(^PS(52.5,SFN,0)),"^",13),RXRS(RXREC)=$G(PSODFN),RXLTOP=1
     33 S RXRS(RXREC)=$G(RXRS(RXREC))_"^"_$S($P($G(^PS(52.5,SFN,0)),"^",4)="W":"W",1:"M")_"^"_$P($G(^PSRX(RXREC,"MP")),"^") S PSOGET="M" D GETMW
     34 S RXRS(RXREC)=$G(RXRS(RXREC))_"^"_$G(PSOGETF)_"^"_$G(PSOGETFN)_"^"_$S($G(PSOGET)="W":"W",1:"M")
     35 S $P(^PS(52.5,SFN,0),"^",4)=$G(PSOSQRTE) S MW=$G(PSOSQRTE) N RR,RFCNT D MAILS^PSOSUPAT I $D(PSOSQMTH) S $P(^PSRX(RXREC,"MP"),"^")=$G(PSOSQMTH)
     36 S PSOSQ=1
     37 ;
     38 ; - Submitting Rx to ECME for 3rd Party Billing
     39 I '$D(RXPR(RXREC)) D
     40 . N ACTION,RFL S RFL=$G(RXFL(RXREC)) I RFL="" S RFL=$$LSTRFL^PSOBPSU1(RXREC)
     41 . D ECMESND^PSOBPSU1(RXREC,RFL,,"PP")
     42 . I $$FIND^PSOREJUT(RXREC,RFL) D
     43 . . S ACTION=$$HDLG^PSOREJU1(RXREC,RFL,"79,88","PP","IOQ","I")
     44 ;
     45 D ULRX K PSOGET,PSOGETF
     46 Q
     47WIND ;
     48 N RRT,RRTT,XXXX,JJJJ,PSINTRX,RTETEST,PSOPSO,SSSS
     49 S PBINGRTE=0,PSINTRX=RXREC
     50 I $G(RXPR(RXREC)) S RTETEST=$P($G(^PSRX(RXREC,"P",RXPR(PSINTRX),0)),"^",2) S:RTETEST="W" PBINGRTE=1 Q
     51 S PSOPSO=0 F SSSS=0:0 S SSSS=$O(^PSRX(PSINTRX,1,SSSS)) Q:'SSSS  S PSOPSO=SSSS
     52 I 'PSOPSO S RTETEST=$P($G(^PSRX(PSINTRX,0)),"^",11) S:RTETEST="W" PBINGRTE=1 Q
     53 I PSOPSO S RTETEST=$P($G(^PSRX(PSINTRX,1,PSOPSO,0)),"^",2) S:RTETEST="W" PBINGRTE=1 Q
     54 Q
     55DIR ;
     56 W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR Q
     57END S VALMSG="Nothing pulled from suspense!",VALMBCK="R" S:$G(PULLONE)=1 PULLONE=2 Q
     58ADD ;Add Rx to SPSORX array
     59 I $G(SPSORX("PSOL",1))']"" S SPSORX("PSOL",1)=RXREC_"," Q
     60 F PSOX1=0:0 S PSOX1=$O(SPSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
     61 I $L(SPSORX("PSOL",PSOX2))+$L(RXREC)<220 S SPSORX("PSOL",PSOX2)=SPSORX("PSOL",PSOX2)_RXREC_"," Q
     62 S SPSORX("PSOL",PSOX2+1)=RXREC_","
     63 Q
     64BBADD ;
     65 N PSOX1,PSOX2
     66 I $G(BBRX(1))']"" S BBRX(1)=RXREC_"," Q
     67 F PSOX1=0:0 S PSOX1=$O(BBRX(PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
     68 I $L(BBRX(PSOX2))+$L(RXREC)<220 S BBRX(PSOX2)=BBRX(PSOX2)_RXREC_"," Q
     69 S BBRX(PSOX2+1)=RXREC_","
     70 Q
     71PPLADD ;
     72 N SZZ,SPSOX1,SPSOX2,LSFN
     73 I $G(PPL)'="",$E(PPL,$L(PPL))'="," S PPL=PPL_","
     74 F SZZ=0:0 S SZZ=$O(RXRS(SZZ)) Q:'SZZ  D
     75 .S LSFN=$O(^PS(52.5,"B",SZZ,0))
     76 .Q:'$G(LSFN)
     77 .Q:$G(^PS(52.5,LSFN,"P"))
     78 .I $G(PPL)="" S PPL=SZZ_"," Q
     79 .I $L(PPL)+$L(SZZ)<220 S PPL=PPL_SZZ_"," Q
     80 .I $G(PSORX("PSOL",2))']"" S PSORX("PSOL",2)=SZZ_"," Q
     81 .F SPSOX1=1:0 S SPSOX1=$O(PSORX("PSOL",SPSOX1)) Q:'SPSOX1  S SPSOX2=SPSOX1
     82 .I $L(PSORX("PSOL",SPSOX2))+$L(SZZ)<220 S PSORX("PSOL",SPSOX2)=PSORX("PSOL",SPSOX2)_SZZ_"," Q
     83 .S PSORX("PSOL",SPSOX2+1)=SZZ_","
     84 Q
     85CKDIV ;
     86 I '$P($G(PSOSYS),"^",2) W !!?10,"Rx # ",$P(^PSRX(RXREC,0),"^")," is not a valid choice (Different Division)" S PSPOP=1 Q
     87 I $P($G(PSOSYS),"^",3) W !!?10 K DIR S DIR("A")="Rx # "_$P(^PSRX(RXREC,0),"^")_" is from another division. OK to Pull",DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR I $G(DIRUT)!('Y) S PSPOP=1
     88 Q
     89SELONE ;Pull one Rx through Listman
     90 I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q
     91 N ORD,MW,PDUZ,PSLST,PSOSQ,PSOSQRTE,PSOSQMTH,PSPOP,PSOX1,PSOX2,PULLONE,RXLTOP,RXREC,SFN,SORD,SORN,VALMCNT
     92 S PULLONE=1
     93 I +PSOLST(ORN)'=52 S VALMBCK="" Q
     94 I +PSOLST(ORN)=52,$P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")'=5 S VALMSG="Rx is not on Suspense!",VALMBCK="" Q
     95 I +PSOLST(ORN)=52,$D(RXRS($P(PSOLST(ORN),"^",2))) S VALMSG="Pull early has already been requested!",VALMBCK="" Q
     96 D SELQ I $G(PULLONE)=2 S VALMSG="Rx# "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^")_" not pulled from suspense!" Q
     97 I +PSOLST(ORN)=52 S RXREC=$P(PSOLST(ORN),"^",2) D BEGQ S VALMSG="Rx# "_$P($G(^PSRX(+$G(RXREC),0)),"^")_$S($G(PSOSQ):" pulled",1:" not pulled")_" from Suspense!"
     98 S VALMBCK="R"
     99 Q
     100RESET ;
     101 N RSDA,RXMW,RXMP,RXSP,RXR,DA,RXPSRX,RXFILL,RXFILLN
     102 F RSDA=0:0 S RSDA=$O(RXRS(RSDA)) Q:'RSDA  D
     103 .S RXSP=$O(^PS(52.5,"B",RSDA,0)) Q:'RXSP
     104 .Q:'$D(^PS(52.5,RXSP,0))
     105 .S RXMW=$S($P($G(RXRS(RSDA)),"^",2)="":"M",1:$P($G(RXRS(RSDA)),"^",2)),RXMP=$P($G(RXRS(RSDA)),"^",3),RXFILL=$P($G(RXRS(RSDA)),"^",4),RXFILLN=$P($G(RXRS(RSDA)),"^",5),RXPSRX=$S($P($G(RXRS(RSDA)),"^",6)="":"M",1:$P($G(RXRS(RSDA)),"^",6))
     106 .I RXMW'="" S $P(^PS(52.5,RXSP,0),"^",4)=RXMW D
     107 ..I RXFILL="P" D  Q
     108 ...I $D(^PSRX(RSDA,"P",+$G(RXFILLN),0)) S $P(^PSRX(RSDA,"P",+$G(RXFILLN),0),"^",2)=$G(RXPSRX),$P(^PSRX(RSDA,"MP"),"^")=RXMP
     109 ..I RXFILL="R",$G(RXFILLN) S DA(1)=RSDA,DA=RXFILLN,DIE="^PSRX("_DA(1)_",1,",DR="2////"_RXPSRX D ^DIE K DIE
     110 ..I RXFILL="O" S DA=RSDA,DIE="^PSRX(",DR="11////"_RXPSRX D ^DIE K DIE
     111 ..S $P(^PSRX(RSDA,"MP"),"^")=RXMP
     112 Q
     113GETMW ;
     114 N GETPAR,GETRX,GETCNT
     115 S PSOGETF="O",PSOGETFN=""
     116 S GETPAR=$P($G(^PS(52.5,SFN,0)),"^",5)
     117 I GETPAR S PSOGET=$P($G(^PSRX(RXREC,"P",GETPAR,0)),"^",2),PSOGETF="P",PSOGETFN=GETPAR Q
     118 I '$O(^PSRX(RXREC,1,0)) S PSOGET=$P($G(^PSRX(RXREC,0)),"^",11) Q
     119 S GETRX=0 F GETCNT=0:0 S GETCNT=$O(^PSRX(RXREC,1,GETCNT)) Q:'GETCNT  S GETRX=GETCNT
     120 S PSOGET=$P($G(^PSRX(RXREC,1,+$G(GETRX),0)),"^",2),PSOGETF="R",PSOGETFN=+$G(GETRX)
     121 Q
     122ULRX ;
     123 I '$G(RXREC) Q
     124 D PSOUL^PSSLOCK(RXREC)
     125 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOTPCAN.m

    r613 r623  
    1 PSOTPCAN        ;BIR/RTR - TPB Utility routine ;3/13/07  21:21
    2         ;;7.0;OUTPATIENT PHARMACY;**146,153,163,227,208**;DEC 1997;Build 41
    3         ; Modified from FOIA VistA
    4         ; Copyright (C) 2007 WorldVistA
    5         ;
    6         ; This program is free software; you can redistribute it and/or modify
    7         ; it under the terms of the GNU General Public License as published by
    8         ; the Free Software Foundation; either version 2 of the License, or
    9         ; (at your option) any later version.
    10         ;
    11         ; This program is distributed in the hope that it will be useful,
    12         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ; GNU General Public License for more details.
    15         ;
    16         ; You should have received a copy of the GNU General Public License
    17         ; along with this program; if not, write to the Free Software
    18         ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
    19         ;External reference to PS(55 supported by DBIA 2228
    20         ;External reference to VA(200 supported by DBIA 224
    21         ;
    22         ;Check Rx being DC'd, if it's a TPB Rx, check to inactivate patient
    23         ;Called from all DC actions
    24 CAN(PSOTPRCX)   ;
    25         Q  ; placed out of order by PSO*7*227
    26         I '$G(PSOTPRCX) Q
    27         N PSOTPRC
    28         S PSOTPRC=$P($G(^PSRX(PSOTPRCX,0)),"^",2)
    29         I '$G(PSOTPRC) Q
    30         I '$P($G(^PSRX(PSOTPRCX,"TPB")),"^") Q
    31         I '$D(^PS(52.91,PSOTPRC,0)) Q
    32         I $P($G(^PS(52.91,PSOTPRC,0)),"^",3),$P($G(^(0)),"^",3)'>DT Q
    33         ;Patient is active in the TPB File, and TPB Rx is being canceled
    34         I PSOTPRC'=$P($G(^PSRX(PSOTPRCX,0)),"^",2) Q
    35         N PSOTPCSS,PSOTCXFL,PSOTC1,PSOTC2,PSOTC3,X1,X2,DA,DR,DIE,X,Y
    36         S PSOTCXFL=0
    37         S X1=DT,X2=-1 D C^%DTC S PSOTC3=X
    38         F PSOTC1=PSOTC3:0 S PSOTC1=$O(^PS(55,PSOTPRC,"P","A",PSOTC1)) Q:'PSOTC1!(PSOTCXFL)  S PSOTC2="" F  S PSOTC2=$O(^PS(55,PSOTPRC,"P","A",PSOTC1,PSOTC2)) Q:PSOTC2=""!(PSOTCXFL)  D
    39         .I $P($G(^PSRX(PSOTC2,0)),"^",2)'=PSOTPRC Q
    40         .S PSOTPCSS=$P($G(^PSRX(PSOTC2,"STA")),"^")
    41         .I PSOTPCSS'=0,PSOTPCSS'=1,PSOTPCSS'=2,PSOTPCSS'=3,PSOTPCSS'=4,PSOTPCSS'=5,PSOTPCSS'=16 Q
    42         .I $P($G(^PSRX(PSOTC2,"TPB")),"^"),$P($G(^(2)),"^",6)'<DT S PSOTCXFL=1
    43         I 'PSOTCXFL K DA,DIE,DR S DA=PSOTPRC,DIE="^PS(52.91,",DR="2////"_DT_";3////"_6 D ^DIE K DIE,DA,DR
    44         Q
    45         ;
    46 MARK    ;Mark Rx as TPB Rx if applicable
    47         N PSOTPODE,PSOZTRX
    48         I '$G(PSOX("IRXN")) Q
    49         I '$D(^PSRX(PSOX("IRXN"),0)) Q
    50         I '$G(PSOTPBFG) Q
    51         ;I $G(PSOFDR) Q
    52         S PSOTPODE=$G(^PSRX(PSOX("IRXN"),0))
    53         I '$P(PSOTPODE,"^",2)!('$P(PSOTPODE,"^",3))!('$P(PSOTPODE,"^",4)) Q
    54         S PSOZTRX=$P($G(^PS(53,+$P(PSOTPODE,"^",3),0)),"^") I $$UP^XLFSTR(PSOZTRX)'="NON-VA" Q
    55         I '$P($G(^VA(200,+$P(PSOTPODE,"^",4),"TPB")),"^") Q
    56         I $P($G(^VA(200,+$P(PSOTPODE,"^",4),"TPB")),"^",5)'=0 Q
    57         I '$D(^PS(52.91,+$P(PSOTPODE,"^",2),0)) Q
    58         I $P($G(^PS(52.91,+$P(PSOTPODE,"^",2),0)),"^",3),$P($G(^(0)),"^",3)'>DT Q
    59         ;Hard setting, to avoid DIE kiling any needed variables, no cross references on field, if added, need to use FileMan here
    60         S $P(^PSRX(PSOX("IRXN"),"TPB"),"^")=1
    61         Q
    62 MARKV   ;Mark from Verify action
    63         N PSOTPV1,PSOTPV2
    64         I '$G(PSONVLP) Q
    65         I '$D(^PSRX(PSONVLP,0)) Q
    66         I '$G(PSOTPBFG) Q
    67         ;I $G(PSOFDR) Q
    68         S PSOTPV1=$G(^PSRX(PSONVLP,0))
    69         I '$P(PSOTPV1,"^",2)!('$P(PSOTPV1,"^",3))!('$P(PSOTPV1,"^",4)) Q
    70         S PSOTPV2=$P($G(^PS(53,+$P(PSOTPV1,"^",3),0)),"^") I $$UP^XLFSTR(PSOTPV2)'="NON-VA" Q
    71         I '$P($G(^VA(200,+$P(PSOTPV1,"^",4),"TPB")),"^") Q
    72         I $P($G(^VA(200,+$P(PSOTPV1,"^",4),"TPB")),"^",5)'=0 Q
    73         I '$D(^PS(52.91,+$P(PSOTPV1,"^",2),0)) Q
    74         I $P($G(^PS(52.91,+$P(PSOTPV1,"^",2),0)),"^",3),$P($G(^(0)),"^",3)'>DT Q
    75         S $P(^PSRX(PSONVLP,"TPB"),"^")=1
    76         Q
    77 RXPAT   ;Sets Rx patient status to null
    78         N PSOZZTRX
    79         I $G(X),$G(X)'>DT D
    80         .S PSOZZTRX=$P($G(^PS(53,+$P($G(^PS(55,DA,"PS")),"^"),0)),"^") S PSOZZTRX=$$UP^XLFSTR(PSOZZTRX) I PSOZZTRX="NON-VA" S $P(^PS(55,DA,"PS"),"^")=""
    81         Q
    82 SET(PSOTPPST)   ;Pass in DFN on a hard set of INACTIVATION OF BENEFIT DATE
    83         N PSOZXTRX
    84         I $P($G(^PS(52.91,PSOTPPST,0)),"^",3),$P($G(^(0)),"^",3)'>DT S PSOZXTRX=$P($G(^PS(53,+$P($G(^PS(55,PSOTPPST,"PS")),"^"),0)),"^") I $$UP^XLFSTR(PSOZXTRX)="NON-VA" S $P(^PS(55,PSOTPPST,"PS"),"^")=""
    85         Q
    86 PCAP(PSOPAPPT)  ;Find nearest Primary Care appointment
    87         Q "TODAY AT NOON"
    88         ;
    89 PDIR(PSOTPEX)   ;
    90         Q:'$G(PSOTPEX)
    91         N PSOTPEXS
    92         S PSOTPEXT=0
    93         S PSOTPEXS=$P($G(^DPT(PSOTPEX,0)),"^",9)
    94         W !!?10,$C(7),$P($G(^DPT(PSOTPEX,0)),"^")_" ("_$E(PSOTPEXS,1,3)_"-"_$E(PSOTPEXS,4,5)_"-"_$E(PSOTPEXS,6,9)_")"
    95         W !?10,"Patient is eligible for the Transitional Pharmacy Benefit!!"
    96         W ! K DIR S DIR(0)="E",DIR("A")="Press <ret> to continue, '^' to exit"  D ^DIR K DIR I Y'=1 S PSOTPEXT=1
    97         Q
    98 VOPN    ;
    99         I '$G(PSOTPPEN) Q
    100         I '$D(^PSRX(PSOTPPEN,0)) Q
    101         N PSOTPPE3,PSOTPPE4,PSOTPPE5,PSOTPPE6,PSOTPPE7,PSOTPPE8
    102         S PSOTPPE6=1
    103         S PSOTPPE3=$P($G(^PSRX(PSOTPPEN,0)),"^",3),PSOTPPE4=$P($G(^PSRX(PSOTPPEN,0)),"^",4)
    104 VOPNX   ;
    105         I 'PSOTPPE4 S PSOTPPEX=1,PSOTPPE5(PSOTPPE6)="Unknown Provider!",PSOTPPE6=PSOTPPE6+1
    106         I 'PSOTPPE3 S PSOTPPEX=1 S PSOTPPE5(PSOTPPE6)="Unknown Patient Status!",PSOTPPE6=PSOTPPE6+1
    107         I PSOTPPE4,'$P($G(^VA(200,PSOTPPE4,"TPB")),"^") S PSOTPPE5(PSOTPPE6)="Provider is not flagged as a NON-VA PRESCRIBER!",PSOTPPE6=PSOTPPE6+1,PSOTPPEX=1
    108         I PSOTPPE4,$P($G(^VA(200,PSOTPPE4,"TPB")),"^",5)'=0 S PSOTPPE5(PSOTPPE6)="Provider is not flagged as not being on exclusionary list!",PSOTPPE6=PSOTPPE6+1,PSOTPPEX=1
    109         I PSOTPPE3 S PSOTPPE7=$P($G(^PS(53,PSOTPPE3,0)),"^") S PSOTPPE7=$$UP^XLFSTR(PSOTPPE7) I PSOTPPE7'="NON-VA" S PSOTPPE5(PSOTPPE6)="Rx Patient Status is not equal to 'NON-VA'!",PSOTPPE6=PSOTPPE6+1,PSOTPPEX=1
    110         I $G(PSOTPPEX) D  I $G(PSOTPPE9) S VALMSG="Cannot Verify through this option"
    111         .W ! F PSOTPPE8=0:0 S PSOTPPE8=$O(PSOTPPE5(PSOTPPE8)) Q:'PSOTPPE8  W !,$G(PSOTPPE5(PSOTPPE8))
    112         .K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
    113         Q
    114 VOPNR   ;
    115         I '$G(PSOTPPEN) Q
    116         I '$D(^PS(52.41,PSOTPPEN,0)) Q
    117         N PSOTPPE3,PSOTPPE4,PSOTPPE5,PSOTPPE6,PSOTPPE7,PSOTPPE8
    118         S PSOTPPE6=1
    119         I $P(^PS(52.41,PSOTPPEN,0),"^",3)="RNW",$D(^PSRX(+$P(^PS(52.41,PSOTPPEN,0),"^",21),0)) S PSOTPPE3=$P($G(^PSRX(+$P(^PS(52.41,PSOTPPEN,0),"^",21),0)),"^",3) G NOREN
    120         S PSOTPPE3=$P($G(^PS(55,+$P($G(^PS(52.41,PSOTPPEN,0)),"^",2),"PS")),"^")
    121 NOREN   ;
    122         S PSOTPPE4=$P($G(^PS(52.41,PSOTPPEN,0)),"^",5)
    123         G VOPNX
    124         ;
    125 DSPL(PSOTPWRN)  ;
    126         N DIR,PSOTPWR1,PSOTPWR2,PSOTPWR3
    127         I '$G(PSOTPWRN) Q
    128         I '$D(^PS(52.41,PSOTPWRN,0)) Q
    129         I $P(^PS(52.41,PSOTPWRN,0),"^",3)="RNW",$D(^PSRX(+$P(^PS(52.41,PSOTPWRN,0),"^",21),0)) D  Q
    130         . S PSOTPWR1=$P($G(^PSRX(+$P(^PS(52.41,PSOTPWRN,0),"^",21),0)),"^",3)
    131         . S PSOTPWR2=$P($G(^PS(53,+PSOTPWR1,0)),"^"),PSOTPWR3=$$UP^XLFSTR(PSOTPWR2)
    132         . I PSOTPWR3="NON-VA",DUZ("AG")="V" D  ; Skip for VOE sites
    133         . . K DIR W !!,"This order has an Rx Patient Status of 'NON-VA'!",! K DIR S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR K DIR
    134         . . Q
    135         . Q
    136         S PSOTPWR1=$P($G(^PS(55,+$P($G(^PS(52.41,PSOTPWRN,0)),"^",2),"PS")),"^")
    137         S PSOTPWR2=$P($G(^PS(53,+PSOTPWR1,0)),"^") S PSOTPWR3=$$UP^XLFSTR(PSOTPWR2)
    138         I PSOTPWR3="NON-VA",DUZ("AG")="V" D  ; Skip for VOE sites
    139         .W !!,"This order has an Rx Patient Status of 'NON-VA'!",! K DIR S DIR(0)="E",DIR("A")="Press return to continue"  D ^DIR K DIR
    140         Q
    141 EXFLAG(PSOTPPX) ;Exit TPB RX option, reset TPG flag if necessary,
    142         ;and possibly delete inactive date and reason code for patient in 52.91
    143         I '$G(DT) S DT=$$DT^XLFDT
    144         I '$G(PSOTPPX) Q
    145         I '$D(^PS(52.91,PSOTPPX,0)) Q
    146         I $E($P(^PS(52.91,PSOTPPX,0),"^",3),1,7)'=DT Q
    147         I $P(^PS(52.91,PSOTPPX,0),"^",4)'=6 Q
    148         N DR,DIE,X1,X2,X,Y,DA,PSOTPPX1,PSOTPPX2,PSOTPPX3,PSOTPPX4,PSOTPPX5,PSOTPPX6,PSOTPPX7,PSOTPPX9
    149         S X1=DT,X2=-1 D C^%DTC S PSOTPPX1=X
    150         S PSOTPPX9=0
    151         F PSOTPPX2=PSOTPPX1:0 S PSOTPPX2=$O(^PS(55,PSOTPPX,"P","A",PSOTPPX2)) Q:'PSOTPPX2  S PSOTPPX3="" F  S PSOTPPX3=$O(^PS(55,PSOTPPX,"P","A",PSOTPPX2,PSOTPPX3)) Q:PSOTPPX3=""  D
    152         .I PSOTPPX'=$P($G(^PSRX(PSOTPPX3,0)),"^",2) Q
    153         .I $P($G(^PSRX(PSOTPPX3,"TPB")),"^") Q
    154         .I $E($P($G(^PSRX(PSOTPPX3,2)),"^"),1,7)'=DT Q
    155         .S PSOTPPX4=$P($G(^PSRX(PSOTPPX3,"STA")),"^") I PSOTPPX4="" Q
    156         .I PSOTPPX4'=0,PSOTPPX4'=1,PSOTPPX4'=2,PSOTPPX4'=3,PSOTPPX4'=4,PSOTPPX4'=5,PSOTPPX4'=16 Q
    157         .S PSOTPPX5=$P(^PSRX(PSOTPPX3,0),"^",3),PSOTPPX6=$P(^(0),"^",4)
    158         .I 'PSOTPPX5!('PSOTPPX6) Q
    159         .S PSOTPPX7=$P($G(^PS(53,+PSOTPPX5,0)),"^") S PSOTPPX7=$$UP^XLFSTR(PSOTPPX7) I PSOTPPX7'="NON-VA" Q
    160         .I '$P($G(^VA(200,PSOTPPX6,"TPB")),"^")!($P($G(^("TPB")),"^",5)'=0) Q
    161         .S $P(^PSRX(PSOTPPX3,"TPB"),"^")=1,PSOTPPX9=1
    162         I PSOTPPX9 K DA,DIE,DR S DIE="^PS(52.91,",DA=PSOTPPX,DR="2////"_"@"_";3////"_"@" D ^DIE K DIE,DA,DR
    163         Q
    164         ;
    165 SCH     ;DBIA to return TPB patients to Scheduling
    166         N PSOSCT,PSOSCTD
    167         K ^TMP($J,"PSODFN")
    168         F PSOSCT=0:0 S PSOSCT=$O(^PS(52.91,PSOSCT)) Q:'PSOSCT  I PSOSCT=$P($G(^(PSOSCT,0)),"^") D
    169         .S PSOSCTD=$P($G(^PS(52.91,PSOSCT,0)),"^",3)
    170         .I 'PSOSCTD!(PSOSCTD>DT) D
    171         ..I $P($G(^DPT(PSOSCT,0)),"^")="" Q
    172         ..S ^TMP($J,"PSODFN",$P($G(^DPT(PSOSCT,0)),"^"),PSOSCT)=""
    173         Q
     1PSOTPCAN ;BIR/RTR - TPB Utility routine ;3/13/07  21:21
     2 ;;7.0;OUTPATIENT PHARMACY;**146,153,163,227,208**;DEC 1997;Build 39
     3 ; Modified from FOIA VistA
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ; This program is distributed in the hope that it will be useful,
     12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ; GNU General Public License for more details.
     15 ;
     16 ; You should have received a copy of the GNU General Public License
     17 ; along with this program; if not, write to the Free Software
     18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
     19 ;External reference to PS(55 supported by DBIA 2228
     20 ;External reference to VA(200 supported by DBIA 224
     21 ;
     22 ;Check Rx being DC'd, if it's a TPB Rx, check to inactivate patient
     23 ;Called from all DC actions
     24CAN(PSOTPRCX) ;
     25 Q  ; placed out of order by PSO*7*227
     26 I '$G(PSOTPRCX) Q
     27 N PSOTPRC
     28 S PSOTPRC=$P($G(^PSRX(PSOTPRCX,0)),"^",2)
     29 I '$G(PSOTPRC) Q
     30 I '$P($G(^PSRX(PSOTPRCX,"TPB")),"^") Q
     31 I '$D(^PS(52.91,PSOTPRC,0)) Q
     32 I $P($G(^PS(52.91,PSOTPRC,0)),"^",3),$P($G(^(0)),"^",3)'>DT Q
     33 ;Patient is active in the TPB File, and TPB Rx is being canceled
     34 I PSOTPRC'=$P($G(^PSRX(PSOTPRCX,0)),"^",2) Q
     35 N PSOTPCSS,PSOTCXFL,PSOTC1,PSOTC2,PSOTC3,X1,X2,DA,DR,DIE,X,Y
     36 S PSOTCXFL=0
     37 S X1=DT,X2=-1 D C^%DTC S PSOTC3=X
     38 F PSOTC1=PSOTC3:0 S PSOTC1=$O(^PS(55,PSOTPRC,"P","A",PSOTC1)) Q:'PSOTC1!(PSOTCXFL)  S PSOTC2="" F  S PSOTC2=$O(^PS(55,PSOTPRC,"P","A",PSOTC1,PSOTC2)) Q:PSOTC2=""!(PSOTCXFL)  D
     39 .I $P($G(^PSRX(PSOTC2,0)),"^",2)'=PSOTPRC Q
     40 .S PSOTPCSS=$P($G(^PSRX(PSOTC2,"STA")),"^")
     41 .I PSOTPCSS'=0,PSOTPCSS'=1,PSOTPCSS'=2,PSOTPCSS'=3,PSOTPCSS'=4,PSOTPCSS'=5,PSOTPCSS'=16 Q
     42 .I $P($G(^PSRX(PSOTC2,"TPB")),"^"),$P($G(^(2)),"^",6)'<DT S PSOTCXFL=1
     43 I 'PSOTCXFL K DA,DIE,DR S DA=PSOTPRC,DIE="^PS(52.91,",DR="2////"_DT_";3////"_6 D ^DIE K DIE,DA,DR
     44 Q
     45 ;
     46MARK ;Mark Rx as TPB Rx if applicable
     47 N PSOTPODE,PSOZTRX
     48 I '$G(PSOX("IRXN")) Q
     49 I '$D(^PSRX(PSOX("IRXN"),0)) Q
     50 I '$G(PSOTPBFG) Q
     51 ;I $G(PSOFDR) Q
     52 S PSOTPODE=$G(^PSRX(PSOX("IRXN"),0))
     53 I '$P(PSOTPODE,"^",2)!('$P(PSOTPODE,"^",3))!('$P(PSOTPODE,"^",4)) Q
     54 S PSOZTRX=$P($G(^PS(53,+$P(PSOTPODE,"^",3),0)),"^") I $$UP^XLFSTR(PSOZTRX)'="NON-VA" Q
     55 I '$P($G(^VA(200,+$P(PSOTPODE,"^",4),"TPB")),"^") Q
     56 I $P($G(^VA(200,+$P(PSOTPODE,"^",4),"TPB")),"^",5)'=0 Q
     57 I '$D(^PS(52.91,+$P(PSOTPODE,"^",2),0)) Q
     58 I $P($G(^PS(52.91,+$P(PSOTPODE,"^",2),0)),"^",3),$P($G(^(0)),"^",3)'>DT Q
     59 ;Hard setting, to avoid DIE kiling any needed variables, no cross references on field, if added, need to use FileMan here
     60 S $P(^PSRX(PSOX("IRXN"),"TPB"),"^")=1
     61 Q
     62MARKV ;Mark from Verify action
     63 N PSOTPV1,PSOTPV2
     64 I '$G(PSONVLP) Q
     65 I '$D(^PSRX(PSONVLP,0)) Q
     66 I '$G(PSOTPBFG) Q
     67 ;I $G(PSOFDR) Q
     68 S PSOTPV1=$G(^PSRX(PSONVLP,0))
     69 I '$P(PSOTPV1,"^",2)!('$P(PSOTPV1,"^",3))!('$P(PSOTPV1,"^",4)) Q
     70 S PSOTPV2=$P($G(^PS(53,+$P(PSOTPV1,"^",3),0)),"^") I $$UP^XLFSTR(PSOTPV2)'="NON-VA" Q
     71 I '$P($G(^VA(200,+$P(PSOTPV1,"^",4),"TPB")),"^") Q
     72 I $P($G(^VA(200,+$P(PSOTPV1,"^",4),"TPB")),"^",5)'=0 Q
     73 I '$D(^PS(52.91,+$P(PSOTPV1,"^",2),0)) Q
     74 I $P($G(^PS(52.91,+$P(PSOTPV1,"^",2),0)),"^",3),$P($G(^(0)),"^",3)'>DT Q
     75 S $P(^PSRX(PSONVLP,"TPB"),"^")=1
     76 Q
     77RXPAT ;Sets Rx patient status to null
     78 N PSOZZTRX
     79 I $G(X),$G(X)'>DT D
     80 .S PSOZZTRX=$P($G(^PS(53,+$P($G(^PS(55,DA,"PS")),"^"),0)),"^") S PSOZZTRX=$$UP^XLFSTR(PSOZZTRX) I PSOZZTRX="NON-VA" S $P(^PS(55,DA,"PS"),"^")=""
     81 Q
     82SET(PSOTPPST) ;Pass in DFN on a hard set of INACTIVATION OF BENEFIT DATE
     83 N PSOZXTRX
     84 I $P($G(^PS(52.91,PSOTPPST,0)),"^",3),$P($G(^(0)),"^",3)'>DT S PSOZXTRX=$P($G(^PS(53,+$P($G(^PS(55,PSOTPPST,"PS")),"^"),0)),"^") I $$UP^XLFSTR(PSOZXTRX)="NON-VA" S $P(^PS(55,PSOTPPST,"PS"),"^")=""
     85 Q
     86PCAP(PSOPAPPT) ;Find nearest Primary Care appointment
     87 Q "TODAY AT NOON"
     88 ;
     89PDIR(PSOTPEX) ;
     90 Q:'$G(PSOTPEX)
     91 N PSOTPEXS
     92 S PSOTPEXT=0
     93 S PSOTPEXS=$P($G(^DPT(PSOTPEX,0)),"^",9)
     94 W !!?10,$C(7),$P($G(^DPT(PSOTPEX,0)),"^")_" ("_$E(PSOTPEXS,1,3)_"-"_$E(PSOTPEXS,4,5)_"-"_$E(PSOTPEXS,6,9)_")"
     95 W !?10,"Patient is eligible for the Transitional Pharmacy Benefit!!"
     96 W ! K DIR S DIR(0)="E",DIR("A")="Press <ret> to continue, '^' to exit"  D ^DIR K DIR I Y'=1 S PSOTPEXT=1
     97 Q
     98VOPN ;
     99 I '$G(PSOTPPEN) Q
     100 I '$D(^PSRX(PSOTPPEN,0)) Q
     101 N PSOTPPE3,PSOTPPE4,PSOTPPE5,PSOTPPE6,PSOTPPE7,PSOTPPE8
     102 S PSOTPPE6=1
     103 S PSOTPPE3=$P($G(^PSRX(PSOTPPEN,0)),"^",3),PSOTPPE4=$P($G(^PSRX(PSOTPPEN,0)),"^",4)
     104VOPNX ;
     105 I 'PSOTPPE4 S PSOTPPEX=1,PSOTPPE5(PSOTPPE6)="Unknown Provider!",PSOTPPE6=PSOTPPE6+1
     106 I 'PSOTPPE3 S PSOTPPEX=1 S PSOTPPE5(PSOTPPE6)="Unknown Patient Status!",PSOTPPE6=PSOTPPE6+1
     107 I PSOTPPE4,'$P($G(^VA(200,PSOTPPE4,"TPB")),"^") S PSOTPPE5(PSOTPPE6)="Provider is not flagged as a NON-VA PRESCRIBER!",PSOTPPE6=PSOTPPE6+1,PSOTPPEX=1
     108 I PSOTPPE4,$P($G(^VA(200,PSOTPPE4,"TPB")),"^",5)'=0 S PSOTPPE5(PSOTPPE6)="Provider is not flagged as not being on exclusionary list!",PSOTPPE6=PSOTPPE6+1,PSOTPPEX=1
     109 I PSOTPPE3 S PSOTPPE7=$P($G(^PS(53,PSOTPPE3,0)),"^") S PSOTPPE7=$$UP^XLFSTR(PSOTPPE7) I PSOTPPE7'="NON-VA" S PSOTPPE5(PSOTPPE6)="Rx Patient Status is not equal to 'NON-VA'!",PSOTPPE6=PSOTPPE6+1,PSOTPPEX=1
     110 I $G(PSOTPPEX) D  I $G(PSOTPPE9) S VALMSG="Cannot Verify through this option"
     111 .W ! F PSOTPPE8=0:0 S PSOTPPE8=$O(PSOTPPE5(PSOTPPE8)) Q:'PSOTPPE8  W !,$G(PSOTPPE5(PSOTPPE8))
     112 .K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
     113 Q
     114VOPNR ;
     115 I '$G(PSOTPPEN) Q
     116 I '$D(^PS(52.41,PSOTPPEN,0)) Q
     117 N PSOTPPE3,PSOTPPE4,PSOTPPE5,PSOTPPE6,PSOTPPE7,PSOTPPE8
     118 S PSOTPPE6=1
     119 I $P(^PS(52.41,PSOTPPEN,0),"^",3)="RNW",$D(^PSRX(+$P(^PS(52.41,PSOTPPEN,0),"^",21),0)) S PSOTPPE3=$P($G(^PSRX(+$P(^PS(52.41,PSOTPPEN,0),"^",21),0)),"^",3) G NOREN
     120 S PSOTPPE3=$P($G(^PS(55,+$P($G(^PS(52.41,PSOTPPEN,0)),"^",2),"PS")),"^")
     121NOREN ;
     122 S PSOTPPE4=$P($G(^PS(52.41,PSOTPPEN,0)),"^",5)
     123 G VOPNX
     124 ;
     125DSPL(PSOTPWRN) ;
     126 N DIR,PSOTPWR1,PSOTPWR2,PSOTPWR3
     127 I '$G(PSOTPWRN) Q
     128 I '$D(^PS(52.41,PSOTPWRN,0)) Q
     129 I $P(^PS(52.41,PSOTPWRN,0),"^",3)="RNW",$D(^PSRX(+$P(^PS(52.41,PSOTPWRN,0),"^",21),0)) D  Q
     130 . S PSOTPWR1=$P($G(^PSRX(+$P(^PS(52.41,PSOTPWRN,0),"^",21),0)),"^",3)
     131 . S PSOTPWR2=$P($G(^PS(53,+PSOTPWR1,0)),"^"),PSOTPWR3=$$UP^XLFSTR(PSOTPWR2)
     132 . I PSOTPWR3="NON-VA",DUZ("AG")="V" D  ; Skip for VOE sites
     133 . . K DIR W !!,"This order has an Rx Patient Status of 'NON-VA'!",! K DIR S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR K DIR
     134 . . Q
     135 . Q
     136 S PSOTPWR1=$P($G(^PS(55,+$P($G(^PS(52.41,PSOTPWRN,0)),"^",2),"PS")),"^")
     137 S PSOTPWR2=$P($G(^PS(53,+PSOTPWR1,0)),"^") S PSOTPWR3=$$UP^XLFSTR(PSOTPWR2)
     138 I PSOTPWR3="NON-VA",DUZ("AG")="V" D  ; Skip for VOE sites
     139 .W !!,"This order has an Rx Patient Status of 'NON-VA'!",! K DIR S DIR(0)="E",DIR("A")="Press return to continue"  D ^DIR K DIR
     140 Q
     141EXFLAG(PSOTPPX) ;Exit TPB RX option, reset TPG flag if necessary,
     142 ;and possibly delete inactive date and reason code for patient in 52.91
     143 I '$G(DT) S DT=$$DT^XLFDT
     144 I '$G(PSOTPPX) Q
     145 I '$D(^PS(52.91,PSOTPPX,0)) Q
     146 I $E($P(^PS(52.91,PSOTPPX,0),"^",3),1,7)'=DT Q
     147 I $P(^PS(52.91,PSOTPPX,0),"^",4)'=6 Q
     148 N DR,DIE,X1,X2,X,Y,DA,PSOTPPX1,PSOTPPX2,PSOTPPX3,PSOTPPX4,PSOTPPX5,PSOTPPX6,PSOTPPX7,PSOTPPX9
     149 S X1=DT,X2=-1 D C^%DTC S PSOTPPX1=X
     150 S PSOTPPX9=0
     151 F PSOTPPX2=PSOTPPX1:0 S PSOTPPX2=$O(^PS(55,PSOTPPX,"P","A",PSOTPPX2)) Q:'PSOTPPX2  S PSOTPPX3="" F  S PSOTPPX3=$O(^PS(55,PSOTPPX,"P","A",PSOTPPX2,PSOTPPX3)) Q:PSOTPPX3=""  D
     152 .I PSOTPPX'=$P($G(^PSRX(PSOTPPX3,0)),"^",2) Q
     153 .I $P($G(^PSRX(PSOTPPX3,"TPB")),"^") Q
     154 .I $E($P($G(^PSRX(PSOTPPX3,2)),"^"),1,7)'=DT Q
     155 .S PSOTPPX4=$P($G(^PSRX(PSOTPPX3,"STA")),"^") I PSOTPPX4="" Q
     156 .I PSOTPPX4'=0,PSOTPPX4'=1,PSOTPPX4'=2,PSOTPPX4'=3,PSOTPPX4'=4,PSOTPPX4'=5,PSOTPPX4'=16 Q
     157 .S PSOTPPX5=$P(^PSRX(PSOTPPX3,0),"^",3),PSOTPPX6=$P(^(0),"^",4)
     158 .I 'PSOTPPX5!('PSOTPPX6) Q
     159 .S PSOTPPX7=$P($G(^PS(53,+PSOTPPX5,0)),"^") S PSOTPPX7=$$UP^XLFSTR(PSOTPPX7) I PSOTPPX7'="NON-VA" Q
     160 .I '$P($G(^VA(200,PSOTPPX6,"TPB")),"^")!($P($G(^("TPB")),"^",5)'=0) Q
     161 .S $P(^PSRX(PSOTPPX3,"TPB"),"^")=1,PSOTPPX9=1
     162 I PSOTPPX9 K DA,DIE,DR S DIE="^PS(52.91,",DA=PSOTPPX,DR="2////"_"@"_";3////"_"@" D ^DIE K DIE,DA,DR
     163 Q
     164 ;
     165SCH ;DBIA to return TPB patients to Scheduling
     166 N PSOSCT,PSOSCTD
     167 K ^TMP($J,"PSODFN")
     168 F PSOSCT=0:0 S PSOSCT=$O(^PS(52.91,PSOSCT)) Q:'PSOSCT  I PSOSCT=$P($G(^(PSOSCT,0)),"^") D
     169 .S PSOSCTD=$P($G(^PS(52.91,PSOSCT,0)),"^",3)
     170 .I 'PSOSCTD!(PSOSCTD>DT) D
     171 ..I $P($G(^DPT(PSOSCT,0)),"^")="" Q
     172 ..S ^TMP($J,"PSODFN",$P($G(^DPT(PSOSCT,0)),"^"),PSOSCT)=""
     173 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOUTLA1.m

    r613 r623  
    1 PSOUTLA1        ;BHAM ISC/RTR-Pharmacy utility program cont. ;5/22/07 10:01am
    2         ;;7.0;OUTPATIENT PHARMACY;**35,186,218,259,206**;DEC 1997;Build 39
    3         ;External reference to File ^PS(55 supported by DBIA 2228
    4         ;External reference to File ^PSDRUG supported by DBIA 221
    5         ;External reference to File ^PS(59.7 supported by DBIA 694
    6         ;External reference to File ^PS(51 supported by DBIA 2224
    7         ;
    8         ;*186 - add DEACHK function
    9         ;*218 - add REFIP function
    10         ;*259 - reverse *218 delete restriction only warn of deleting
    11         ;       also add del of last refill only
    12         ;
    13 EN1     ;Formats condensed, back door sig in BSIG array
    14         ;pass in  1) Internal Rx from 52
    15         ;         2) max length of BSIG array
    16         ;Returned, still condensed, in BSIG array, when looping through, check for array=null, if so, juist don't print it
    17 EN2(PSOBINTR,PSOBLGTH)  ;
    18         K BSIG
    19         N BBSIG,BVAR,BVAR1,III,CNT,NNN,BLIM
    20         S BBSIG=$P($G(^PSRX(PSOBINTR,"SIG")),"^") Q:BBSIG=""!($P($G(^("SIG")),"^",2))
    21         S (BVAR,BVAR1)="",III=1
    22         S CNT=0 F NNN=1:1:$L(BBSIG) I $E(BBSIG,NNN)=" "!($L(BBSIG)=NNN) S CNT=CNT+1 D  I $L(BVAR)>PSOBLGTH S BSIG(III)=BLIM_" ",III=III+1,BVAR=BVAR1
    23         .S BVAR1=$P(BBSIG," ",(CNT))
    24         .S BLIM=BVAR
    25         .S BVAR=$S(BVAR="":BVAR1,1:BVAR_" "_BVAR1)
    26         I $G(BVAR)'="" S BSIG(III)=BVAR
    27         I $G(BSIG(1))=""!($G(BSIG(1))=" ") S BSIG(1)=$G(BSIG(2)) K BSIG(2)
    28         Q
    29         ;
    30 EN3(PSOBINTR,PSOBLGTH)  ;
    31         ;Pass in to EN3 the internal Rx number from 52, and the length of
    32         ;the array you want. Returns expanded Sig, or warning from PSOHELP
    33         ;concantenated with the condensed Sig in the BSIG array
    34         ;BACK DOOR ONLY
    35         K BSIG,X N BBSIG,BVAR,BVAR1,III,CNT,NNN,BLIM,Y,SIG,Z0,Z1,BBWARN
    36         S BBSIG=$P($G(^PSRX(PSOBINTR,"SIG")),"^") Q:BBSIG=""!($P($G(^("SIG")),"^",2))
    37         S (SIG,X)=BBSIG
    38         I $E(BBSIG)=" " S BBWARN="Leading spaces are not allowed in the SIG!" G START
    39         S SIG="" Q:$L(X)<1  F Z0=1:1:$L(X," ") G:Z0="" START S Z1=$P(X," ",Z0) D  G:'$D(X) START
    40         .I $L(Z1)>32 S BBWARN="MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES!" K X Q
    41         .D:$D(X)&($G(Z1)]"")  S SIG=SIG_" "_Z1
    42         ..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y!($P($G(^PS(51,+Y,0)),"^",4)>1)  S Z1=$P(^PS(51,Y,0),"^",2) Q:'$D(^(9))  S Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9)
    43 START   ;
    44         S BBSIG=$S($G(BBWARN)="":SIG,1:BBWARN_"  "_BBSIG)
    45         S (BVAR,BVAR1)="",III=1
    46         S CNT=0 F NNN=1:1:$L(BBSIG) I $E(BBSIG,NNN)=" "!($L(BBSIG)=NNN) S CNT=CNT+1 D  I $L(BVAR)>PSOBLGTH S BSIG(III)=BLIM_" ",III=III+1,BVAR=BVAR1
    47         .S BVAR1=$P(BBSIG," ",(CNT))
    48         .S BLIM=BVAR
    49         .S BVAR=$S(BVAR="":BVAR1,1:BVAR_" "_BVAR1)
    50         I $G(BVAR)'="" S BSIG(III)=BVAR
    51         I $G(BSIG(1))=""!($G(BSIG(1))=" ") S BSIG(1)=$G(BSIG(2)) K BSIG(2)
    52         Q
    53 PATCH   ;Allow sites to backfill more than what was done at install
    54         N PSOBACKL,PSOBACKI,PSOBACKS,PSOBACKB,PSOBACKD,PSOBACKA
    55         S PSOBACKL=$O(^PS(59.7,0)),PSOBACKI=$E($P($G(^PS(59.7,+$G(PSOBACKL),49.99)),"^",7),1,7)
    56         I '$G(PSOBACKI) S PSOBACKI=$P($G(^PS(59.7,+$G(PSOBACKL),49.99)),"^",4)
    57         I $G(PSOBACKI) S Y=PSOBACKI D DD^%DT S PSOBACKS=Y S X1=PSOBACKI,X2=-120 D C^%DTC S (Y,PSOBACKB)=X D DD^%DT S PSOBACKD=Y
    58         I $G(PSOBACKD)'="" W !!,"Your CPRS/Outpatient installation date is "_$G(PSOBACKS)_","_" which",!,"means we have already backfilled all active prescriptions and all",!,"prescriptions canceled or expired after "_$G(PSOBACKD)_"."
    59         I  W !!,"If you want to backfill orders that were canceled or expired prior to this",!,"date of "_$G(PSOBACKD)_", enter an earlier date and those orders",!,"will be backfilled to CPRS.",!
    60         I $G(PSOBACKD)="" W !!,"We cannot determine the date of the CPRS/Outpatient installation.",!
    61         W !,"If you choose to backfill more orders to CPRS by utilizing this option,",!,"we remind you that disk storage can be significantly affected, depending on",!,"how many orders are backfilled.",!
    62         K DIR S DIR(0)="Y",DIR("B")="N",DIR("A")="Do you want to backfill more prescriptions",DIR("?")="Enter Yes to backfill prescriptions canceled or expired before "_$G(PSOBACKD) D ^DIR K DIR I Y'=1 W ! G PATCHQ
    63         W ! S %DT="AEPX",%DT("A")="Enter Date to begin backfill: " S:$G(PSOBACKB) %DT(0)=-PSOBACKB D ^%DT G:Y<0!($D(DTOUT)) PATCHQ S PSOBACKA=$E(Y,1,7)
    64         W ! K ZTDTH S ZTSAVE("PSOBACKB")="",ZTSAVE("PSOBACKA")="",ZTRTN="PATCHR^PSOUTLA1",ZTDESC="BACKFILL PRSCRIPTIONS TO CPRS",ZTIO="" D ^%ZTLOAD W ! G PATCHQ
    65 PATCHR  ;Begin task
    66         N PSOPAL,PSOLPD,PSOLPRX
    67         S PSOBACKA=PSOBACKA-.01
    68         I '$G(PSOBACKB) S PSOBACKB=DT
    69         F PSOPAL=0:0 S PSOPAL=$O(^PS(55,PSOPAL)) Q:'PSOPAL  F PSOLPD=PSOBACKA:0 S PSOLPD=$O(^PS(55,PSOPAL,"P","A",PSOLPD)) Q:'PSOLPD!(PSOLPD>PSOBACKB)  F PSOLPRX=0:0 S PSOLPRX=$O(^PS(55,PSOPAL,"P","A",PSOLPD,PSOLPRX)) Q:'PSOLPRX  D
    70         .I $P($G(^PSRX(PSOLPRX,0)),"^")=""!('$P($G(^(0)),"^",2))!('$P($G(^(0)),"^",6)) Q
    71         .I $P($G(^PSRX(PSOLPRX,"OR1")),"^",2) Q
    72         .I '$P($G(^PSRX(PSOLPRX,0)),"^",19) D
    73         ..I $P($G(^PSRX(PSOLPRX,"OR1")),"^")="",+$G(^PSDRUG(+$P($G(^PSRX(PSOLPRX,0)),"^",6),2)) S $P(^PSRX(PSOLPRX,"OR1"),"^")=+$G(^PSDRUG(+$P($G(^PSRX(PSOLPRX,0)),"^",6),2))
    74         ..I $P($G(^PSRX(PSOLPRX,0)),"^",10)'="",$G(^PSRX(PSOLPRX,"SIG"))']"",'$O(^PSRX(PSOLPRX,"SIG1",0)) S ^PSRX(PSOLPRX,"SIG")=$P($G(^PSRX(PSOLPRX,0)),"^",10)_"^"_0 S $P(^PSRX(PSOLPRX,0),"^",10)=""
    75         ..I $P($G(^PSRX(PSOLPRX,"STA")),"^")="",$P($G(^PSRX(PSOLPRX,0)),"^",15)'="" S $P(^PSRX(PSOLPRX,"STA"),"^")=$P($G(^PSRX(PSOLPRX,0)),"^",15) S $P(^PSRX(PSOLPRX,0),"^",15)=""
    76         ..S $P(^PSRX(PSOLPRX,0),"^",19)=1
    77         .S PSOLPSTA=$P($G(^PSRX(PSOLPRX,"STA")),"^") Q:PSOLPSTA=""!(PSOLPSTA=13)!(PSOLPSTA=10)
    78         .D EN^PSOHLSN1(PSOLPRX,"ZC","")
    79         .I PSOLPSTA'="",PSOLPSTA<10 D
    80         ..I +$P($G(^PSRX(PSOLPRX,2)),"^",6),+$P($G(^(2)),"^",6)<DT S $P(^PSRX(PSOLPRX,"STA"),"^")=11,PSOLPSTA=11
    81         .S PSOLPSTX=$S(PSOLPSTA=3:"OH",PSOLPSTA=16:"OH",PSOLPSTA=12:"OD",PSOLPSTA=15:"OD",PSOLPSTA=14:"OD",1:"SC"),PSOLPSTZ=$S(PSOLPSTA=0:"CM",PSOLPSTA=1:"IP",PSOLPSTA=4:"IP",PSOLPSTA=5:"ZS",PSOLPSTA=11:"ZE",1:"")
    82         .D EN^PSOHLSN1(PSOLPRX,PSOLPSTX,PSOLPSTZ,"")
    83         S:$D(ZTQUEUED) ZTREQ="@"
    84 PATCHQ  Q
    85         ;
    86         ;PSO*186
    87 DEACHK(PSIRXN,PSDEA,PSDAYS,PCLOZ,PSOCS,PSMAXRF) ;Apply DEA restrictions
    88         ;
    89         ; If no refills allowed indicate that and set Max refills to number
    90         ; of fills thus far, or if new order, then num of refills will not be
    91         ; found and Max refills will be 0.
    92         ;
    93         ;  Function returns: 1 = no refills allowed
    94         ;                    0 = ok to refill
    95         ;  Input Variables: PSIRXN = internal RX number or "*"=(new order)
    96         ;                   PSDEA  = DEA special handling for drug ordered
    97         ;                   PSDAYS = Days supply ordered
    98         ;                   PCLOZ  = Clozapine patient? (Optional)
    99         ; Output Variables: PSOCS  = Controlled sub flag  (Optional)
    100         ;                   PSMAXRF= Max Refill allowed by DEA restriction
    101         ;                                                 (Optional)
    102         ;
    103         S PSIRXN=+$G(PSIRXN),PSDEA=$G(PSDEA),PSDAYS=+$G(PSDAYS)
    104         S PSOCS=+$G(PSOCS),PSMAXRF=+$G(PSMAXRF),PCLOZ=$G(PCLOZ)
    105         ;
    106         ;if clozapine patient (passed in 0 or 1),  set max refills and quit
    107         I PCLOZ=0 S PSMAXRF=0 Q 1
    108         I PCLOZ=1 S PSMAXRF=1 Q 0
    109         ;
    110         ;no refills if PSDEA = 'A' & not 'B' or 'F',
    111         I (PSDEA["A")&(PSDEA'["B")!(PSDEA["F")!(PSDEA[1)!(PSDEA[2) D  Q 1
    112         . S PSMAXRF=$$NUMFILLS(PSIRXN)
    113         ;
    114         N QQ
    115         F QQ=1:1 Q:$E(PSDEA,QQ)=""  I $E(+PSDEA,QQ)>1,$E(+PSDEA,QQ)<6 D
    116         . S PSOCS=1
    117         . S:$E(+PSDEA,QQ)=2 $P(PSOCS,"^",2)=1
    118         ;
    119         ;no refills allowed on sched 2
    120         I $P(PSOCS,"^",2)=1 S PSMAXRF=$$NUMFILLS(PSIRXN) Q 1
    121         ;
    122         ;set max refill for controlled substance & other based on days supply
    123         S PSDAYS=+$G(PSDAYS)
    124         I PSOCS D
    125         . S PSMAXRF=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0)
    126         E  D
    127         . S PSMAXRF=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0)
    128         ;
    129         ;get number of fills if applies & compare to Max refills
    130         N PNFILLS S PNFILLS=$$NUMFILLS(PSIRXN)
    131         I PNFILLS'<PSMAXRF S PSMAXRF=PNFILLS Q 1
    132         ;
    133         Q 0
    134         ;
    135 NUMFILLS(PSIRXN)        ;Return number of fills thus far, or 0 if doesn't apply
    136         ; function returns: if   Active drug, then number of refills thus far
    137         ;                   else return 0 for does not apply
    138         ;  Input Variables: PSIRXN = internal RX number (Optional)
    139         Q:'$G(PSIRXN) 0
    140         N RFN,RFNC
    141         S (RFN,RFNC)=0
    142         F  S RFN=$O(^PSRX(PSIRXN,1,RFN)) Q:'RFN  S RFNC=RFNC+1
    143         Q RFNC
    144         ;
    145 REFIP(RXI,RFIL,TYP)     ;Check if refill is Not Released and In Process and
    146         ;           pending Auto Release by an external dispense machine.
    147         ; Input: RXI = internal Prescription no.
    148         ;        RFIL= refill number
    149         ;        TYP ="R"-refill or "P"-partial
    150         ; Returns 1 = In Process      (Not OK to delete)
    151         ;         0 = Not In Process  (OK to delete)
    152         ;
    153         ;assumes a refill is Not In Process by the external dispense machine
    154         ;unless it finds a record in this file and is marked to the contrary
    155         ;
    156         N PSIEN,IP,FOUND,EXDATA,EXDIV
    157         S (IP,FOUND)=0,PSIEN=""
    158         ;find first specified refill processing backwards, in case dupes
    159         F  S PSIEN=$O(^PS(52.51,"B",RXI,PSIEN),-1) Q:PSIEN=""  D  Q:FOUND
    160         . S EXDATA=^PS(52.51,PSIEN,0)
    161         . I $P(EXDATA,"^",9)=RFIL D
    162         . . S EXDIV=$P(EXDATA,"^",11)
    163         . . Q:'$P($G(^PS(59,EXDIV,"DISP")),"^",2)     ;quit, not auto release
    164         . . S FOUND=1
    165         . I FOUND,$P(^PS(52.51,PSIEN,0),"^",10)'=2 S IP=1
    166         Q IP
    167         ;
    168 WARN1   ;partial del checks    *259
    169         N PSR,PSOL
    170         S PSR=0 F  S PSR=$O(^PSRX(DA(1),"P",PSR)) Q:'PSR  S PSOL=PSR
    171         I DA=PSOL,$P(^PSRX(DA(1),"P",DA,0),"^",19) D  Q
    172         .D EN^DDIOL("Partial Released! Use the 'Return to Stock' option!","","$C(7),!!"),EN^DDIOL(" ","","!")
    173         ;
    174         ;Warn of In Process, Only delete if answered Yes         ;*259
    175         I $$REFIP^PSOUTLA1(DA(1),DA,"P") D  I 'Y Q               ;reset $T
    176         . D EN^DDIOL("** Partial refill has previously been sent to the External Dispense Machine","","!!,?2")
    177         . D EN^DDIOL("** for filling and is still Pending Processing","","$C(7),!,?2")
    178         . D EN^DDIOL("","","!")
    179         . K DIR
    180         . S DIR("A")="Do you want to continue? "
    181         . S DIR("B")="Y"
    182         . S DIR(0)="YA^^"
    183         . S DIR("?")="Enter Y for Yes or N for No."
    184         . D ^DIR
    185         . K DIR
    186         Q
     1PSOUTLA1 ;BHAM ISC/RTR-Pharmacy utility program cont. ;10/20/06 3:44pm
     2 ;;7.0;OUTPATIENT PHARMACY;**35,186,218,259**;DEC 1997;Build 5
     3 ;External reference to File ^PS(55 supported by DBIA 2228
     4 ;External reference to File ^PSDRUG supported by DBIA 221
     5 ;External reference to File ^PS(59.7 supported by DBIA 694
     6 ;External reference to File ^PS(51 supported by DBIA 2224
     7 ;
     8 ;*186 - add DEACHK function
     9 ;*218 - add REFIP function
     10 ;*259 - reverse *218 delete restriction only warn of deleting
     11 ;       also add del of last refill only
     12 ;
     13EN1 ;Formats condensed, back door sig in BSIG array
     14 ;pass in  1) Internal Rx from 52
     15 ;         2) max length of BSIG array
     16 ;Returned, still condensed, in BSIG array, when looping through, check for array=null, if so, juist don't print it
     17EN2(PSOBINTR,PSOBLGTH) ;
     18 K BSIG
     19 N BBSIG,BVAR,BVAR1,III,CNT,NNN,BLIM
     20 S BBSIG=$P($G(^PSRX(PSOBINTR,"SIG")),"^") Q:BBSIG=""!($P($G(^("SIG")),"^",2))
     21 S (BVAR,BVAR1)="",III=1
     22 S CNT=0 F NNN=1:1:$L(BBSIG) I $E(BBSIG,NNN)=" "!($L(BBSIG)=NNN) S CNT=CNT+1 D  I $L(BVAR)>PSOBLGTH S BSIG(III)=BLIM_" ",III=III+1,BVAR=BVAR1
     23 .S BVAR1=$P(BBSIG," ",(CNT))
     24 .S BLIM=BVAR
     25 .S BVAR=$S(BVAR="":BVAR1,1:BVAR_" "_BVAR1)
     26 I $G(BVAR)'="" S BSIG(III)=BVAR
     27 I $G(BSIG(1))=""!($G(BSIG(1))=" ") S BSIG(1)=$G(BSIG(2)) K BSIG(2)
     28 Q
     29 ;
     30EN3(PSOBINTR,PSOBLGTH) ;
     31 ;Pass in to EN3 the internal Rx number from 52, and the length of
     32 ;the array you want. Returns expanded Sig, or warning from PSOHELP
     33 ;concantenated with the condensed Sig in the BSIG array
     34 ;BACK DOOR ONLY
     35 K BSIG,X N BBSIG,BVAR,BVAR1,III,CNT,NNN,BLIM,Y,SIG,Z0,Z1,BBWARN
     36 S BBSIG=$P($G(^PSRX(PSOBINTR,"SIG")),"^") Q:BBSIG=""!($P($G(^("SIG")),"^",2))
     37 S (SIG,X)=BBSIG
     38 I $E(BBSIG)=" " S BBWARN="Leading spaces are not allowed in the SIG!" G START
     39 S SIG="" Q:$L(X)<1  F Z0=1:1:$L(X," ") G:Z0="" START S Z1=$P(X," ",Z0) D  G:'$D(X) START
     40 .I $L(Z1)>32 S BBWARN="MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES!" K X Q
     41 .D:$D(X)&($G(Z1)]"")  S SIG=SIG_" "_Z1
     42 ..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y!($P($G(^PS(51,+Y,0)),"^",4)>1)  S Z1=$P(^PS(51,Y,0),"^",2) Q:'$D(^(9))  S Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9)
     43START ;
     44 S BBSIG=$S($G(BBWARN)="":SIG,1:BBWARN_"  "_BBSIG)
     45 S (BVAR,BVAR1)="",III=1
     46 S CNT=0 F NNN=1:1:$L(BBSIG) I $E(BBSIG,NNN)=" "!($L(BBSIG)=NNN) S CNT=CNT+1 D  I $L(BVAR)>PSOBLGTH S BSIG(III)=BLIM_" ",III=III+1,BVAR=BVAR1
     47 .S BVAR1=$P(BBSIG," ",(CNT))
     48 .S BLIM=BVAR
     49 .S BVAR=$S(BVAR="":BVAR1,1:BVAR_" "_BVAR1)
     50 I $G(BVAR)'="" S BSIG(III)=BVAR
     51 I $G(BSIG(1))=""!($G(BSIG(1))=" ") S BSIG(1)=$G(BSIG(2)) K BSIG(2)
     52 Q
     53PATCH ;Allow sites to backfill more than what was done at install
     54 N PSOBACKL,PSOBACKI,PSOBACKS,PSOBACKB,PSOBACKD,PSOBACKA
     55 S PSOBACKL=$O(^PS(59.7,0)),PSOBACKI=$E($P($G(^PS(59.7,+$G(PSOBACKL),49.99)),"^",7),1,7)
     56 I '$G(PSOBACKI) S PSOBACKI=$P($G(^PS(59.7,+$G(PSOBACKL),49.99)),"^",4)
     57 I $G(PSOBACKI) S Y=PSOBACKI D DD^%DT S PSOBACKS=Y S X1=PSOBACKI,X2=-120 D C^%DTC S (Y,PSOBACKB)=X D DD^%DT S PSOBACKD=Y
     58 I $G(PSOBACKD)'="" W !!,"Your CPRS/Outpatient installation date is "_$G(PSOBACKS)_","_" which",!,"means we have already backfilled all active prescriptions and all",!,"prescriptions canceled or expired after "_$G(PSOBACKD)_"."
     59 I  W !!,"If you want to backfill orders that were canceled or expired prior to this",!,"date of "_$G(PSOBACKD)_", enter an earlier date and those orders",!,"will be backfilled to CPRS.",!
     60 I $G(PSOBACKD)="" W !!,"We cannot determine the date of the CPRS/Outpatient installation.",!
     61 W !,"If you choose to backfill more orders to CPRS by utilizing this option,",!,"we remind you that disk storage can be significantly affected, depending on",!,"how many orders are backfilled.",!
     62 K DIR S DIR(0)="Y",DIR("B")="N",DIR("A")="Do you want to backfill more prescriptions",DIR("?")="Enter Yes to backfill prescriptions canceled or expired before "_$G(PSOBACKD) D ^DIR K DIR I Y'=1 W ! G PATCHQ
     63 W ! S %DT="AEPX",%DT("A")="Enter Date to begin backfill: " S:$G(PSOBACKB) %DT(0)=-PSOBACKB D ^%DT G:Y<0!($D(DTOUT)) PATCHQ S PSOBACKA=$E(Y,1,7)
     64 W ! K ZTDTH S ZTSAVE("PSOBACKB")="",ZTSAVE("PSOBACKA")="",ZTRTN="PATCHR^PSOUTLA1",ZTDESC="BACKFILL PRSCRIPTIONS TO CPRS",ZTIO="" D ^%ZTLOAD W ! G PATCHQ
     65PATCHR ;Begin task
     66 N PSOPAL,PSOLPD,PSOLPRX
     67 S PSOBACKA=PSOBACKA-.01
     68 I '$G(PSOBACKB) S PSOBACKB=DT
     69 F PSOPAL=0:0 S PSOPAL=$O(^PS(55,PSOPAL)) Q:'PSOPAL  F PSOLPD=PSOBACKA:0 S PSOLPD=$O(^PS(55,PSOPAL,"P","A",PSOLPD)) Q:'PSOLPD!(PSOLPD>PSOBACKB)  F PSOLPRX=0:0 S PSOLPRX=$O(^PS(55,PSOPAL,"P","A",PSOLPD,PSOLPRX)) Q:'PSOLPRX  D
     70 .I $P($G(^PSRX(PSOLPRX,0)),"^")=""!('$P($G(^(0)),"^",2))!('$P($G(^(0)),"^",6)) Q
     71 .I $P($G(^PSRX(PSOLPRX,"OR1")),"^",2) Q
     72 .I '$P($G(^PSRX(PSOLPRX,0)),"^",19) D
     73 ..I $P($G(^PSRX(PSOLPRX,"OR1")),"^")="",+$G(^PSDRUG(+$P($G(^PSRX(PSOLPRX,0)),"^",6),2)) S $P(^PSRX(PSOLPRX,"OR1"),"^")=+$G(^PSDRUG(+$P($G(^PSRX(PSOLPRX,0)),"^",6),2))
     74 ..I $P($G(^PSRX(PSOLPRX,0)),"^",10)'="",$G(^PSRX(PSOLPRX,"SIG"))']"",'$O(^PSRX(PSOLPRX,"SIG1",0)) S ^PSRX(PSOLPRX,"SIG")=$P($G(^PSRX(PSOLPRX,0)),"^",10)_"^"_0 S $P(^PSRX(PSOLPRX,0),"^",10)=""
     75 ..I $P($G(^PSRX(PSOLPRX,"STA")),"^")="",$P($G(^PSRX(PSOLPRX,0)),"^",15)'="" S $P(^PSRX(PSOLPRX,"STA"),"^")=$P($G(^PSRX(PSOLPRX,0)),"^",15) S $P(^PSRX(PSOLPRX,0),"^",15)=""
     76 ..S $P(^PSRX(PSOLPRX,0),"^",19)=1
     77 .S PSOLPSTA=$P($G(^PSRX(PSOLPRX,"STA")),"^") Q:PSOLPSTA=""!(PSOLPSTA=13)!(PSOLPSTA=10)
     78 .D EN^PSOHLSN1(PSOLPRX,"ZC","")
     79 .I PSOLPSTA'="",PSOLPSTA<10 D
     80 ..I +$P($G(^PSRX(PSOLPRX,2)),"^",6),+$P($G(^(2)),"^",6)<DT S $P(^PSRX(PSOLPRX,"STA"),"^")=11,PSOLPSTA=11
     81 .S PSOLPSTX=$S(PSOLPSTA=3:"OH",PSOLPSTA=16:"OH",PSOLPSTA=12:"OD",PSOLPSTA=15:"OD",PSOLPSTA=14:"OD",1:"SC"),PSOLPSTZ=$S(PSOLPSTA=0:"CM",PSOLPSTA=1:"IP",PSOLPSTA=4:"IP",PSOLPSTA=5:"ZS",PSOLPSTA=11:"ZE",1:"")
     82 .D EN^PSOHLSN1(PSOLPRX,PSOLPSTX,PSOLPSTZ,"")
     83 S:$D(ZTQUEUED) ZTREQ="@"
     84PATCHQ Q
     85 ;
     86 ;PSO*186
     87DEACHK(PSIRXN,PSDEA,PSDAYS,PCLOZ,PSOCS,PSMAXRF) ;Apply DEA restrictions
     88 ;
     89 ; If no refills allowed indicate that and set Max refills to number
     90 ; of fills thus far, or if new order, then num of refills will not be
     91 ; found and Max refills will be 0.
     92 ;
     93 ;  Function returns: 1 = no refills allowed
     94 ;                    0 = ok to refill
     95 ;  Input Variables: PSIRXN = internal RX number or "*"=(new order)
     96 ;                   PSDEA  = DEA special handling for drug ordered
     97 ;                   PSDAYS = Days supply ordered
     98 ;                   PCLOZ  = Clozapine patient? (Optional)
     99 ; Output Variables: PSOCS  = Controlled sub flag  (Optional)
     100 ;                   PSMAXRF= Max Refill allowed by DEA restriction
     101 ;                                                 (Optional)
     102 ;
     103 S PSIRXN=+$G(PSIRXN),PSDEA=$G(PSDEA),PSDAYS=+$G(PSDAYS)
     104 S PSOCS=+$G(PSOCS),PSMAXRF=+$G(PSMAXRF),PCLOZ=$G(PCLOZ)
     105 ;
     106 ;if clozapine patient (passed in 0 or 1),  set max refills and quit
     107 I PCLOZ=0 S PSMAXRF=0 Q 1
     108 I PCLOZ=1 S PSMAXRF=1 Q 0
     109 ;
     110 ;no refills if PSDEA = 'A' & not 'B' or 'F',
     111 I (PSDEA["A")&(PSDEA'["B")!(PSDEA["F") D  Q 1
     112 . S PSMAXRF=$$NUMFILLS(PSIRXN)
     113 ;
     114 N QQ
     115 F QQ=1:1 Q:$E(PSDEA,QQ)=""  I $E(+PSDEA,QQ)>1,$E(+PSDEA,QQ)<6 D
     116 . S PSOCS=1
     117 . S:$E(+PSDEA,QQ)=2 $P(PSOCS,"^",2)=1
     118 ;
     119 ;no refills allowed on sched 2
     120 I $P(PSOCS,"^",2)=1 S PSMAXRF=$$NUMFILLS(PSIRXN) Q 1
     121 ;
     122 ;set max refill for controlled substance & other based on days supply
     123 S PSDAYS=+$G(PSDAYS)
     124 I PSOCS D
     125 . S PSMAXRF=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0)
     126 E  D
     127 . S PSMAXRF=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0)
     128 ;
     129 ;get number of fills if applies & compare to Max refills
     130 N PNFILLS S PNFILLS=$$NUMFILLS(PSIRXN)
     131 I PNFILLS'<PSMAXRF S PSMAXRF=PNFILLS Q 1
     132 ;
     133 Q 0
     134 ;
     135NUMFILLS(PSIRXN) ;Return number of fills thus far, or 0 if doesn't apply
     136 ; function returns: if   Active drug, then number of refills thus far
     137 ;                   else return 0 for does not apply
     138 ;  Input Variables: PSIRXN = internal RX number (Optional)
     139 Q:'$G(PSIRXN) 0
     140 N RFN,RFNC
     141 S (RFN,RFNC)=0
     142 F  S RFN=$O(^PSRX(PSIRXN,1,RFN)) Q:'RFN  S RFNC=RFNC+1
     143 Q RFNC
     144 ;
     145REFIP(RXI,RFIL,TYP) ;Check if refill is Not Released and In Process and
     146 ;           pending Auto Release by an external dispense machine.
     147 ; Input: RXI = internal Prescription no.
     148 ;        RFIL= refill number
     149 ;        TYP ="R"-refill or "P"-partial
     150 ; Returns 1 = In Process      (Not OK to delete)
     151 ;         0 = Not In Process  (OK to delete)
     152 ;
     153 ;assumes a refill is Not In Process by the external dispense machine
     154 ;unless it finds a record in this file and is marked to the contrary
     155 ;
     156 N PSIEN,IP,FOUND,EXDATA,EXDIV
     157 S (IP,FOUND)=0,PSIEN=""
     158 ;find first specified refill processing backwards, in case dupes
     159 F  S PSIEN=$O(^PS(52.51,"B",RXI,PSIEN),-1) Q:PSIEN=""  D  Q:FOUND
     160 . S EXDATA=^PS(52.51,PSIEN,0)
     161 . I $P(EXDATA,"^",9)=RFIL D
     162 . . S EXDIV=$P(EXDATA,"^",11)
     163 . . Q:'$P($G(^PS(59,EXDIV,"DISP")),"^",2)     ;quit, not auto release
     164 . . S FOUND=1
     165 . I FOUND,$P(^PS(52.51,PSIEN,0),"^",10)'=2 S IP=1
     166 Q IP
     167 ;
     168WARN1 ;partial del checks    *259
     169 N PSR,PSOL
     170 S PSR=0 F  S PSR=$O(^PSRX(DA(1),"P",PSR)) Q:'PSR  S PSOL=PSR
     171 I DA=PSOL,$P(^PSRX(DA(1),"P",DA,0),"^",19) D  Q
     172 .D EN^DDIOL("Partial Released! Use the 'Return to Stock' option!","","$C(7),!!"),EN^DDIOL(" ","","!")
     173 ;
     174 ;Warn of In Process, Only delete if answered Yes         ;*259
     175 I $$REFIP^PSOUTLA1(DA(1),DA,"P") D  I 'Y Q               ;reset $T
     176 . D EN^DDIOL("** Partial refill has previously been sent to the External Dispense Machine","","!!,?2")
     177 . D EN^DDIOL("** for filling and is still Pending Processing","","$C(7),!,?2")
     178 . D EN^DDIOL("","","!")
     179 . K DIR
     180 . S DIR("A")="Do you want to continue? "
     181 . S DIR("B")="Y"
     182 . S DIR(0)="YA^^"
     183 . S DIR("?")="Enter Y for Yes or N for No."
     184 . D ^DIR
     185 . K DIR
     186 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOVER1.m

    r613 r623  
    1 PSOVER1 ;BHAM ISC/SAB - verify one rx ;3/9/05 12:53pm
    2         ;;7.0;OUTPATIENT PHARMACY;**32,46,90,131,202,207,148,243,268,281**;DEC 1997;Build 41
    3         ;External reference ^PSDRUG( supported by DBIA 221
    4         ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
    5         ;External reference ^PS(55 supported by DBIA 2228
    6         ;External reference to PSSORPH is supported by DBIA 3234
    7         ;External references to ^ORRDI1 supported by DBIA 4659
    8         ;External reference ^XTMP("ORRDI" supported by DBIA 4660
    9 REDO    ;
    10         S (DRG,PSODRUG("NAME"))=$P(^PSDRUG(+$P(^PSRX(PSONV,0),"^",6),0),"^"),PSODRUG("VA CLASS")=$P(^(0),"^",2)
    11         I '$D(PSODFN) S PSODFN=$P(^PSRX(PSONV,0),"^",2)
    12         S (STA,DNM)="",PSDPSTOP=0,$P(PSONULN,"-",79)="-" F  S STA=$O(PSOSD(STA)) Q:STA=""  F  S DNM=$O(PSOSD(STA,DNM)) Q:DNM=""  K PSZZZDUP I $P(PSOSD(STA,DNM),"^",2)<10 D
    13         .I STA="ZNONVA" D NVA Q
    14         .I PSODRUG("NAME")=$P(DNM,"^")&(PSONV'=$P(PSOSD(STA,DNM),"^")) S PSZZZDUP=1 K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" W ! D ^DIR K DIR S PSDTSTOP=1
    15         .I PSODRUG("VA CLASS")]"",$E(PSODRUG("VA CLASS"),1,4)=$E($P(PSOSD(STA,DNM),"^",5),1,4),PSODRUG("NAME")'=$P(DNM,"^") K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" W ! D ^DIR K DIR D CLS^PSODRDUP S PSDTSTOP=1
    16         .I $G(PSZZZDUP),$G(PSVFLAG),$P($G(^PSRX($P(PSOSD(STA,DNM),"^"),"STA")),"^")=12,$D(^PS(52.4,$P(PSOSD(STA,DNM),"^"),0)) S DA=$P(PSOSD(STA,DNM),"^"),DIK="^PS(52.4," D ^DIK K DIK
    17         .I $G(PSZZZDUP),$G(PSVFLAG),$P($G(^PSRX($P(PSOSD(STA,DNM),"^"),"STA")),"^")'=12 S PSZZQUIT=1
    18         K MSG I $G(PSZZQUIT),$G(PSVFLAG) K PSZZQUIT,PSODRUG,PSODFN,PSZZZDUP,DNM,PSDTSTOP D CLEAN Q
    19         D REMOTE
    20         K PSODRUG,PSODFN,PSZZZDUP,DNM,PSZZQUIT
    21 ALLR    ;Allergy check
    22         S PSONOAL="" D ALLERGY^PSOORUT2 D:PSONOAL'="" NOALRGY K PSONOAL I $G(PSZZQUIT) K MSG,PSZZQUIT,PSODRUG,PSODFN,PSZZZDUP,DNM,PSDTSTOP D CLEAN Q
    23         G:'$P($G(^PSRX(PSONV,3)),"^",6) EDIT
    24         I '$G(PSDTSTOP) K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) K PSDTSTOP G OUT
    25         W !!,"A Drug-Allergy Reaction exists for this medication!",!!,"***SIGNIFICANT*** Allergy Reaction"
    26         W !,"Drug: ",$P($G(^PSDRUG(+$P($G(^PSRX(PSONV,0)),"^",6),0)),"^")
    27         I $O(^PSRX(PSONV,"DAI",0)) W !?6,"Ingredients: " D
    28         .F PSPPP=0:0 S PSPPP=$O(^PSRX(PSONV,"DAI",PSPPP)) Q:'PSPPP  I $G(^(PSPPP,0))'="" W:$X+$L($G(^PSRX(PSONV,"DAI",PSPPP,0)))+2>IOM !?19 W $G(^PSRX(PSONV,"DAI",PSPPP,0))_", "
    29         W ! K DIR,PSPPP S DIR(0)="Y",DIR("B")="Y",DIR("A")="Do you want to intervene?" D ^DIR K DIR I X["^"!($D(DTOUT))!($D(DUOUT)) K PSDTSTOP G OUT
    30         I Y S PSORX("INTERVENE")=0 D EN1^PSORXI(PSONV)
    31 EDIT    I $G(PKI1)=2 D DCV1^PSOPKIV1 G OUT
    32         K PSDTSTOP S DIR("A")="EDIT",DIR("B")="N",DIR(0)="SB^Y:YES;N:NO;P:PROFILE",DIR("?")="Enter Y to change this RX, P to see a profile, or N to procede with verification"
    33         D ^DIR K DIR I Y="Y",$G(PSOACT)]"" S VALMBCK="R" G OUT
    34         I $D(DIRUT),$G(PSOCLK) S PSOCQ=1 G OUT
    35         I $D(DIRUT),$G(PSOACT)]"" S VALMBCK="R" G OUT
    36         G VERIFY:Y="N",PROF:Y="P",OUT:"YNP"'[$E(Y)
    37 CHANGE  S DA=PSONV,(PSRX1,PSRX2)=$P(^PSRX(PSONV,0),"^",6)
    38         S DEA1=1,DEA2=0,PSDOLD=+DA,DIE="^PSRX(",DR="3;7;8;9;4;5;12;1;22;11;"_$S($P(PSOPAR,"^",12):"35;",1:"")_$S($P(PSOPAR,"^",15):"10.6",1:"")_";@2" D ^DIE
    39         ;I PSRX1'=PSRX2,DEA1'=DEA2 S DR="6////"_PSRX1 D ^DIE
    40         D EXPIRE K DIE,DR,DEA1,DEA2,P(5),PSRX1,PSRX2
    41         K PSD(PSDOLD) S PSDNEW=$P(^PSDRUG($P(^PSRX(PSONV,0),"^",6),0),"^")_"^"_PSONV,PSD(PSDNEW)=PSONV_"^*^1^"_$P(^PSDRUG($P(^PSRX(PSONV,0),"^",6),0),"^",2)
    42         S DA=PSONV D ^PSORXPR
    43         G EDIT:PSDNEW=PSDOLD,REDO
    44 PROF    I '$D(PSOSD) W !,$C(7),"This patient has no other prescriptions on file",!! G EDIT Q
    45         D ^PSODSPL G EDIT Q
    46         ;
    47 EXPIRE  S RX0=^PSRX(DA,0),X1=$P($P(RX0,"^",13),"."),X2=$P(RX0,"^",9)+1*$P(RX0,"^",8),X2=$S($P(RX0,"^",8)=X2:X2,X2<181:184,X2=360:366,1:X2),X=X1 D:X1&X2 C^%DTC
    48         K ^PS(55,PSDFN,"P","A",+$P(^PSRX(DA,2),"^",6),DA) S ^PS(55,PSDFN,"P","A",X,DA)="",$P(^PSRX(DA,2),"^",6)=X,$P(^PS(52.4,DA,0),"^",7)=X Q
    49 VERIFY  G:'$P(PSOPAR,"^",2) VERY
    50         S DIR("A")="VERIFY FOR "_PSONAM_" ? (Y/N/Delete/Quit): ",DIR("B")="Y",DIR(0)="SA^Y:YES;N:NO;D:DELETE;Q:QUIT"
    51         S DIR("?",1)="Enter Y (or return) to verify this prescription",DIR("?",2)="N to leave this prescription non-verified and to end this session of verification",DIR("?")="D to delete this prescription"
    52         D ^DIR K DIR G OUT:Y="N",QUIT:"Q^"[$E(Y),DELETE:Y="D"
    53 VERY    I $G(PKI1)=1 D REA^PSOPKIV1 G:'$D(PKIR) VERIFY
    54         K ^PSRX(PSONV,"DAI") S $P(^PSRX(PSONV,3),"^",6)=""
    55         K ^PSRX(PSONV,"DRI"),SPFL
    56         I '$O(^PSRX(PSONV,6,0)) D  I $D(DUOUT)!($D(DTOUT)) W !!,"Rx: "_$P(^PSRX(DA,0),"^")_" not Verified!!",! H 2 G OUT
    57         .W !!,"Dosing Instructions Missing. Please add!",!
    58         .I $P($G(^PSRX(PSONV,"SIG")),"^")]"",'$P($G(^("SIG")),"^",2) W "SIG: "_$P(^PSRX(PSONV,"SIG"),"^"),!
    59         .I $P($G(^PSRX(PSONV,"SIG")),"^",2),$O(^PSRX(PSONV,"SIG1",0)) D  K I
    60         ..W "SIG: " F I=0:0 S I=$O(^PSRX(PSONV,"SIG1",I)) Q:'I  W ^PSRX(PSONV,"SIG1",I,0),!
    61         .S DA=PSONV,PSOVER=1 K DIR,DIRUT,DUOUT,DTOUT
    62         .S PSODRUG("IEN")=$P(^PSRX(DA,0),"^",6),PSODFN=$P(^(0),"^",2),PSORXED("IRXN")=DA,PSODRUG("OI")=$P(^PSRX(DA,"OR1"),"^")
    63         .D DOSE^PSSORPH(.DOSE,PSODRUG("IEN"),"O",PSODFN),^PSOORED3
    64         .K PSODFN,PSODRUG("IEN"),DOSE,PSOVER
    65         .I '$G(ENT) S DUOUT=1
    66         .Q:$D(DUOUT)!($D(DTOUT))
    67         .K DIR,DIRUT,DUOUT,DTOUT S DIE=52,DR=114 D ^DIE K DIE,DR,DTOUT
    68         .I X'="" D SIG^PSOHELP D:$G(INS1)]"" EN^DDIOL($E(INS1,2,9999999)) S PSORXED("SIG",1)=$E(INS1,2,9999999)
    69         .D EN^PSOFSIG(.PSORXED,1),UDSIG^PSOORED3 H 2
    70         S DA=PSONV,$P(^PSRX(DA,2),"^",10)=DUZ I $P(^PSRX(DA,2),"^",2)>DT,$P(PSOPAR,"^",6) S (SPFL1,PSOVER)="",PSORX("FILL DATE")=$P(^(2),"^",2),RXF=0 D UPSUS S PSTRIVER=1 D SUS^PSORXL K PSORX("FILL DATE"),PSTRIVER G KILL
    71         S PSOVER(PSONV)="" S $P(^PSRX(PSONV,"STA"),"^")=0,$P(PSOSD("NON-VERIFIED",DRG),"^",2)=0,PSOSD("ACTIVE",DRG)=PSOSD("NON-VERIFIED",DRG)
    72         I $G(PKI1)=1,$G(PKIR)]"" D ACT^PSOPKIV1(DA)
    73         K PSOSD("NON-VERIFIED",DRG) D EN^PSOHLSN1(PSONV,"SC","CM","")
    74         ;
    75         ; - Calling ECME for claims generation and transmission / REJECT handling
    76         N ACTION
    77         I $$SUBMIT^PSOBPSUT(PSONV) D  I ACTION="Q"!(ACTION="^") Q
    78         . S ACTION="" D ECMESND^PSOBPSU1(PSONV,,,$S($O(^PSRX(PSONV,1,0)):"RF",1:"OF"))
    79         . I $$FIND^PSOREJUT(PSONV) D
    80         . . S ACTION=$$HDLG^PSOREJU1(PSONV,0,"79,88","OF","IOQ","Q")
    81         ;
    82 KILL    S DA=PSONV,DIK="^PS(52.4," D ^DIK K DA,DIK D DCORD^PSONEW2
    83 OUT     K DIRUT,DTOUT,DUOUT,UPFLAGX D CLEAN Q
    84 DELETE  K UPFLAGX D DELETE^PSOVER2 G:$G(UPFLAGX) OUT K PSOSD("NON-VERIFIED",$G(DRG)) Q
    85 QUIT    S PSOQUIT="" D CLEAN Q
    86 UPSUS   S $P(PSOSD("NON-VERIFIED",DRG),"^",2)=5,PSOSD("ACTIVE",DRG)=PSOSD("NON-VERIFIED",DRG) K PSOSD("NON-VERIFIED",DRG) D EN^PSOHLSN1(PSONV,"SC","CM","")
    87         Q
    88 CLEAN   ;cleans up tmp("psorxdc") global
    89         I $O(^TMP("PSORXDC",$J,0)) F RORD=0:0 S RORD=$O(^TMP("PSORXDC",$J,RORD)) Q:'RORD  D
    90         .D PSOUL^PSSLOCK(RORD_$S($P(^TMP("PSORXDC",$J,RORD,0),"^")="P":"S",1:""))
    91         .W !,$S($P(^TMP("PSORXDC",$J,RORD,0),"^")=52:"Prescription",1:"Pending Order")_" #"_$S($P(^TMP("PSORXDC",$J,RORD,0),"^")=52:$P(^PSRX(RORD,0),"^"),1:RORD)_" NOT Discontinued."
    92         K ^TMP("PSORXDC",$J),RORD
    93         Q
    94 KV1     ;
    95         K PSOANSQD,DRET,LST,PSOQUIT,PSODRUG,PSONEW,SIG,PSODIR,PHI,PRC,ORCHK,ORDRG,PSOSIGFL,PSORX("ISSUE DATE"),PSORX("FILL DATE"),CLOZPAT
    96 KV      K DIR,DIRUT,DTOUT,DUOUT
    97         Q
    98 NVA     ;
    99         I $P(PSOSD(STA,DNM),"^",11) D NVA^PSODRDU1 Q
    100         N PSOOI,CLASS,FLG,X,Y,RXREC,IFN
    101         S (Y,FLG)=""
    102         S RXREC=$P(PSOSD(STA,DNM),"^",10),PSOOI=+$G(^PS(55,DFN,"NVA",RXREC,0)),IFN=RXREC N DNM
    103         F  S Y=$O(^PSDRUG("ASP",PSOOI,Y)) Q:Y=""!(FLG)  S DNM=$P(^PSDRUG(Y,0),"^"),CLASS=$P(^PSDRUG(Y,0),"^",2) I PSODRUG("NAME")=DNM!(CLASS=PSODRUG("VA CLASS")) D DSP^PSODRDU1 S FLG=1 Q
    104         Q
    105 REMOTE  ;
    106         K ^TMP($J,"DD"),^TMP($J,"DC"),^TMP($J,"DI"),^TMP($J,"DI"_PSODFN) D
    107         .I $T(HAVEHDR^ORRDI1)']"" Q
    108         .I '$$HAVEHDR^ORRDI1 Q
    109         .I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) D  Q
    110         ..I $T(REMOTE^PSORX1)]"" Q
    111         ..W !,"Remote data not available - Only local order checks processed." D PAUSE^PSOORRD2
    112         .W !,"Now doing remote order checks. Please wait..."
    113         .D REMOTE^PSOORRDI(PSODFN,+$P($G(^PSRX(PSONV,0)),"^",6))
    114         .I $P($G(^XTMP("ORRDI","PSOO",PSODFN,0)),"^",3)<0 W !,"Remote data not available - Only local order checks processed." D PAUSE^PSOORRD2 Q
    115         .I $D(^TMP($J,"DD")) D DUP^PSOORRD2
    116         .I $D(^TMP($J,"DC")) D CLS^PSOORRD2
    117         .I $D(^TMP($J,"DI"_PSODFN)) K ^TMP($J,"DI") M ^TMP($J,"DI")=^TMP($J,"DI"_PSODFN) D DRGINT^PSOORRD2
    118         K ^TMP($J,"DD"),^TMP($J,"DC"),^TMP($J,"DI"),^TMP($J,"DI"_PSODFN)
    119         Q
    120 NOALRGY ;
    121         W $C(7),!,"There is no allergy assessment on file for this patient."
    122         W !,"You will be prompted to intervene if you continue with this prescription"
    123         K DIR
    124         S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to Continue?: ",DIR("B")="N" D ^DIR
    125         I 'Y S PSZZQUIT=1 Q
    126         S PSORX("INTERVENE")=0
    127         D EN1^PSORXI(PSONV)
    128         Q
     1PSOVER1 ;BHAM ISC/SAB - verify one rx ;3/9/05 12:53pm
     2 ;;7.0;OUTPATIENT PHARMACY;**32,46,90,131,202,207,148,243,268**;DEC 1997;Build 9
     3 ;External reference ^PSDRUG( supported by DBIA 221
     4 ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
     5 ;External reference ^PS(55 supported by DBIA 2228
     6 ;External reference to PSSORPH is supported by DBIA 3234
     7 ;External references to ^ORRDI1 supported by DBIA 4659
     8 ;External reference ^XTMP("ORRDI" supported by DBIA 4660
     9REDO ;
     10 S (DRG,PSODRUG("NAME"))=$P(^PSDRUG(+$P(^PSRX(PSONV,0),"^",6),0),"^"),PSODRUG("VA CLASS")=$P(^(0),"^",2)
     11 I '$D(PSODFN) S PSODFN=$P(^PSRX(PSONV,0),"^",2)
     12 S (STA,DNM)="",PSDPSTOP=0,$P(PSONULN,"-",79)="-" F  S STA=$O(PSOSD(STA)) Q:STA=""  F  S DNM=$O(PSOSD(STA,DNM)) Q:DNM=""  K PSZZZDUP I $P(PSOSD(STA,DNM),"^",2)<10 D
     13 .I STA="ZNONVA" D NVA Q
     14 .I PSODRUG("NAME")=$P(DNM,"^")&(PSONV'=$P(PSOSD(STA,DNM),"^")) S PSZZZDUP=1 K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" W ! D ^DIR K DIR S PSDTSTOP=1
     15 .I PSODRUG("VA CLASS")]"",$E(PSODRUG("VA CLASS"),1,4)=$E($P(PSOSD(STA,DNM),"^",5),1,4),PSODRUG("NAME")'=$P(DNM,"^") K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" W ! D ^DIR K DIR D CLS^PSODRDUP S PSDTSTOP=1
     16 .I $G(PSZZZDUP),$G(PSVFLAG),$P($G(^PSRX($P(PSOSD(STA,DNM),"^"),"STA")),"^")=12,$D(^PS(52.4,$P(PSOSD(STA,DNM),"^"),0)) S DA=$P(PSOSD(STA,DNM),"^"),DIK="^PS(52.4," D ^DIK K DIK
     17 .I $G(PSZZZDUP),$G(PSVFLAG),$P($G(^PSRX($P(PSOSD(STA,DNM),"^"),"STA")),"^")'=12 S PSZZQUIT=1
     18 K MSG I $G(PSZZQUIT),$G(PSVFLAG) K PSZZQUIT,PSODRUG,PSODFN,PSZZZDUP,DNM,PSDTSTOP D CLEAN Q
     19 D REMOTE
     20 K PSODRUG,PSODFN,PSZZZDUP,DNM,PSZZQUIT
     21ALLR ;Allergy check
     22 S PSONOAL="" D ALLERGY^PSOORUT2 D:PSONOAL'="" NOALRGY K PSONOAL I $G(PSZZQUIT) K MSG,PSZZQUIT,PSODRUG,PSODFN,PSZZZDUP,DNM,PSDTSTOP D CLEAN Q
     23 G:'$P($G(^PSRX(PSONV,3)),"^",6) EDIT
     24 I '$G(PSDTSTOP) K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) K PSDTSTOP G OUT
     25 W !!,"A Drug-Allergy Reaction exists for this medication!",!!,"***SIGNIFICANT*** Allergy Reaction"
     26 W !,"Drug: ",$P($G(^PSDRUG(+$P($G(^PSRX(PSONV,0)),"^",6),0)),"^")
     27 I $O(^PSRX(PSONV,"DAI",0)) W !?6,"Ingredients: " D
     28 .F PSPPP=0:0 S PSPPP=$O(^PSRX(PSONV,"DAI",PSPPP)) Q:'PSPPP  I $G(^(PSPPP,0))'="" W:$X+$L($G(^PSRX(PSONV,"DAI",PSPPP,0)))+2>IOM !?19 W $G(^PSRX(PSONV,"DAI",PSPPP,0))_", "
     29 W ! K DIR,PSPPP S DIR(0)="Y",DIR("B")="Y",DIR("A")="Do you want to intervene?" D ^DIR K DIR I X["^"!($D(DTOUT))!($D(DUOUT)) K PSDTSTOP G OUT
     30 I Y S PSORX("INTERVENE")=0 D EN1^PSORXI(PSONV)
     31EDIT I $G(PKI1)=2 D DCV1^PSOPKIV1 G OUT
     32 K PSDTSTOP S DIR("A")="EDIT",DIR("B")="N",DIR(0)="SB^Y:YES;N:NO;P:PROFILE",DIR("?")="Enter Y to change this RX, P to see a profile, or N to procede with verification"
     33 D ^DIR K DIR I Y="Y",$G(PSOACT)]"" S VALMBCK="R" G OUT
     34 I $D(DIRUT),$G(PSOCLK) S PSOCQ=1 G OUT
     35 I $D(DIRUT),$G(PSOACT)]"" S VALMBCK="R" G OUT
     36 G VERIFY:Y="N",PROF:Y="P",OUT:"YNP"'[$E(Y)
     37CHANGE S DA=PSONV,(PSRX1,PSRX2)=$P(^PSRX(PSONV,0),"^",6)
     38 S DEA1=1,DEA2=0,PSDOLD=+DA,DIE="^PSRX(",DR="3;7;8;9;4;5;12;1;22;11;"_$S($P(PSOPAR,"^",12):"35;",1:"")_$S($P(PSOPAR,"^",15):"10.6",1:"")_";@2" D ^DIE
     39 ;I PSRX1'=PSRX2,DEA1'=DEA2 S DR="6////"_PSRX1 D ^DIE
     40 D EXPIRE K DIE,DR,DEA1,DEA2,P(5),PSRX1,PSRX2
     41 K PSD(PSDOLD) S PSDNEW=$P(^PSDRUG($P(^PSRX(PSONV,0),"^",6),0),"^")_"^"_PSONV,PSD(PSDNEW)=PSONV_"^*^1^"_$P(^PSDRUG($P(^PSRX(PSONV,0),"^",6),0),"^",2)
     42 S DA=PSONV D ^PSORXPR
     43 G EDIT:PSDNEW=PSDOLD,REDO
     44PROF I '$D(PSOSD) W !,$C(7),"This patient has no other prescriptions on file",!! G EDIT Q
     45 D ^PSODSPL G EDIT Q
     46 ;
     47EXPIRE S RX0=^PSRX(DA,0),X1=$P($P(RX0,"^",13),"."),X2=$P(RX0,"^",9)+1*$P(RX0,"^",8),X2=$S($P(RX0,"^",8)=X2:X2,X2<181:184,X2=360:366,1:X2),X=X1 D:X1&X2 C^%DTC
     48 K ^PS(55,PSDFN,"P","A",+$P(^PSRX(DA,2),"^",6),DA) S ^PS(55,PSDFN,"P","A",X,DA)="",$P(^PSRX(DA,2),"^",6)=X,$P(^PS(52.4,DA,0),"^",7)=X Q
     49VERIFY G:'$P(PSOPAR,"^",2) VERY
     50 S DIR("A")="VERIFY FOR "_PSONAM_" ? (Y/N/Delete/Quit): ",DIR("B")="Y",DIR(0)="SA^Y:YES;N:NO;D:DELETE;Q:QUIT"
     51 S DIR("?",1)="Enter Y (or return) to verify this prescription",DIR("?",2)="N to leave this prescription non-verified and to end this session of verification",DIR("?")="D to delete this prescription"
     52 D ^DIR K DIR G OUT:Y="N",QUIT:"Q^"[$E(Y),DELETE:Y="D"
     53VERY I $G(PKI1)=1 D REA^PSOPKIV1 G:'$D(PKIR) VERIFY
     54 K ^PSRX(PSONV,"DAI") S $P(^PSRX(PSONV,3),"^",6)=""
     55 K ^PSRX(PSONV,"DRI"),SPFL
     56 I '$O(^PSRX(PSONV,6,0)) D  I $D(DUOUT)!($D(DTOUT)) W !!,"Rx: "_$P(^PSRX(DA,0),"^")_" not Verified!!",! H 2 G OUT
     57 .W !!,"Dosing Instructions Missing. Please add!",!
     58 .I $P($G(^PSRX(PSONV,"SIG")),"^")]"",'$P($G(^("SIG")),"^",2) W "SIG: "_$P(^PSRX(PSONV,"SIG"),"^"),!
     59 .I $P($G(^PSRX(PSONV,"SIG")),"^",2),$O(^PSRX(PSONV,"SIG1",0)) D  K I
     60 ..W "SIG: " F I=0:0 S I=$O(^PSRX(PSONV,"SIG1",I)) Q:'I  W ^PSRX(PSONV,"SIG1",I,0),!
     61 .S DA=PSONV,PSOVER=1 K DIR,DIRUT,DUOUT,DTOUT
     62 .S PSODRUG("IEN")=$P(^PSRX(DA,0),"^",6),PSODFN=$P(^(0),"^",2),PSORXED("IRXN")=DA,PSODRUG("OI")=$P(^PSRX(DA,"OR1"),"^")
     63 .D DOSE^PSSORPH(.DOSE,PSODRUG("IEN"),"O",PSODFN),^PSOORED3
     64 .K PSODFN,PSODRUG("IEN"),DOSE,PSOVER
     65 .I '$G(ENT) S DUOUT=1
     66 .Q:$D(DUOUT)!($D(DTOUT))
     67 .K DIR,DIRUT,DUOUT,DTOUT S DIE=52,DR=114 D ^DIE K DIE,DR,DTOUT
     68 .I X'="" D SIG^PSOHELP D:$G(INS1)]"" EN^DDIOL($E(INS1,2,9999999)) S PSORXED("SIG",1)=$E(INS1,2,9999999)
     69 .D EN^PSOFSIG(.PSORXED,1),UDSIG^PSOORED3 H 2
     70 S DA=PSONV,$P(^PSRX(DA,2),"^",10)=DUZ I $P(^PSRX(DA,2),"^",2)>DT,$P(PSOPAR,"^",6) S (SPFL1,PSOVER)="",PSORX("FILL DATE")=$P(^(2),"^",2),RXF=0 D UPSUS S PSTRIVER=1 D SUS^PSORXL K PSORX("FILL DATE"),PSTRIVER G KILL
     71 S PSOVER(PSONV)="" S $P(^PSRX(PSONV,"STA"),"^")=0,$P(PSOSD("NON-VERIFIED",DRG),"^",2)=0,PSOSD("ACTIVE",DRG)=PSOSD("NON-VERIFIED",DRG)
     72 I $G(PKI1)=1,$G(PKIR)]"" D ACT^PSOPKIV1(DA)
     73 K PSOSD("NON-VERIFIED",DRG) D EN^PSOHLSN1(PSONV,"SC","CM","")
     74 ;
     75 ; - Calling ECME for claims generation and transmission / REJECT handling
     76 N ACTION
     77 I $$SUBMIT^PSOBPSUT(PSONV) D  I ACTION="Q"!(ACTION="^") Q
     78 . S ACTION="" D ECMESND^PSOBPSU1(PSONV,,,$S($O(^PSRX(PSONV,1,0)):"RF",1:"OF"))
     79 . I $$FIND^PSOREJUT(PSONV) D
     80 . . S ACTION=$$HDLG^PSOREJU1(PSONV,0,"79,88","OF","IOQ","I")
     81 ;
     82KILL S DA=PSONV,DIK="^PS(52.4," D ^DIK K DA,DIK D DCORD^PSONEW2
     83OUT K DIRUT,DTOUT,DUOUT,UPFLAGX D CLEAN Q
     84DELETE K UPFLAGX D DELETE^PSOVER2 G:$G(UPFLAGX) OUT K PSOSD("NON-VERIFIED",$G(DRG)) Q
     85QUIT S PSOQUIT="" D CLEAN Q
     86UPSUS S $P(PSOSD("NON-VERIFIED",DRG),"^",2)=5,PSOSD("ACTIVE",DRG)=PSOSD("NON-VERIFIED",DRG) K PSOSD("NON-VERIFIED",DRG) D EN^PSOHLSN1(PSONV,"SC","CM","")
     87 Q
     88CLEAN ;cleans up tmp("psorxdc") global
     89 I $O(^TMP("PSORXDC",$J,0)) F RORD=0:0 S RORD=$O(^TMP("PSORXDC",$J,RORD)) Q:'RORD  D
     90 .D PSOUL^PSSLOCK(RORD_$S($P(^TMP("PSORXDC",$J,RORD,0),"^")="P":"S",1:""))
     91 .W !,$S($P(^TMP("PSORXDC",$J,RORD,0),"^")=52:"Prescription",1:"Pending Order")_" #"_$S($P(^TMP("PSORXDC",$J,RORD,0),"^")=52:$P(^PSRX(RORD,0),"^"),1:RORD)_" NOT Discontinued."
     92 K ^TMP("PSORXDC",$J),RORD
     93 Q
     94KV1 ;
     95 K PSOANSQD,DRET,LST,PSOQUIT,PSODRUG,PSONEW,SIG,PSODIR,PHI,PRC,ORCHK,ORDRG,PSOSIGFL,PSORX("ISSUE DATE"),PSORX("FILL DATE"),CLOZPAT
     96KV K DIR,DIRUT,DTOUT,DUOUT
     97 Q
     98NVA ;
     99 I $P(PSOSD(STA,DNM),"^",11) D NVA^PSODRDU1 Q
     100 N PSOOI,CLASS,FLG,X,Y,RXREC,IFN
     101 S (Y,FLG)=""
     102 S RXREC=$P(PSOSD(STA,DNM),"^",10),PSOOI=+$G(^PS(55,DFN,"NVA",RXREC,0)),IFN=RXREC N DNM
     103 F  S Y=$O(^PSDRUG("ASP",PSOOI,Y)) Q:Y=""!(FLG)  S DNM=$P(^PSDRUG(Y,0),"^"),CLASS=$P(^PSDRUG(Y,0),"^",2) I PSODRUG("NAME")=DNM!(CLASS=PSODRUG("VA CLASS")) D DSP^PSODRDU1 S FLG=1 Q
     104 Q
     105REMOTE ;
     106 K ^TMP($J,"DD"),^TMP($J,"DC"),^TMP($J,"DI"),^TMP($J,"DI"_PSODFN) D
     107 .I $T(HAVEHDR^ORRDI1)']"" Q
     108 .I '$$HAVEHDR^ORRDI1 Q
     109 .I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) D  Q
     110 ..I $T(REMOTE^PSORX1)]"" Q
     111 ..W !,"Remote data not available - Only local order checks processed." D PAUSE^PSOORRD2
     112 .W !,"Now doing remote order checks. Please wait..."
     113 .D REMOTE^PSOORRDI(PSODFN,+$P($G(^PSRX(PSONV,0)),"^",6))
     114 .I $P($G(^XTMP("ORRDI","PSOO",PSODFN,0)),"^",3)<0 W !,"Remote data not available - Only local order checks processed." D PAUSE^PSOORRD2 Q
     115 .I $D(^TMP($J,"DD")) D DUP^PSOORRD2
     116 .I $D(^TMP($J,"DC")) D CLS^PSOORRD2
     117 .I $D(^TMP($J,"DI"_PSODFN)) K ^TMP($J,"DI") M ^TMP($J,"DI")=^TMP($J,"DI"_PSODFN) D DRGINT^PSOORRD2
     118 K ^TMP($J,"DD"),^TMP($J,"DC"),^TMP($J,"DI"),^TMP($J,"DI"_PSODFN)
     119 Q
     120NOALRGY ;
     121 W $C(7),!,"There is no allergy assessment on file for this patient."
     122 W !,"You will be prompted to intervene if you continue with this prescription"
     123 K DIR
     124 S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to Continue?: ",DIR("B")="N" D ^DIR
     125 I 'Y S PSZZQUIT=1 Q
     126 S PSORX("INTERVENE")=0
     127 D EN1^PSORXI(PSONV)
     128 Q

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA.m

    r613 r623  
    1 PSOXZA ; DRIVER FOR COMPILED XREFS FOR FILE #52 ; 11/08/09
     1PSOXZA ; DRIVER FOR COMPILED XREFS FOR FILE #52 ; 01/17/08
    22 ;
    33 N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA1.m

    r613 r623  
    1 PSOXZA1 ; COMPILED XREF FOR FILE #52 ; 11/08/09
     1PSOXZA1 ; COMPILED XREF FOR FILE #52 ; 01/17/08
    22 ;
    33 S DIKZK=2

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA10.m

    r613 r623  
    1 PSOXZA10 ; COMPILED XREF FOR FILE #52.052311 ; 11/08/09
     1PSOXZA10 ; COMPILED XREF FOR FILE #52.052311 ; 01/17/08
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA11.m

    r613 r623  
    1 PSOXZA11 ; COMPILED XREF FOR FILE #52.1 ; 11/08/09
     1PSOXZA11 ; COMPILED XREF FOR FILE #52.1 ; 01/17/08
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA12.m

    r613 r623  
    1 PSOXZA12 ; COMPILED XREF FOR FILE #52.2 ; 11/08/09
     1PSOXZA12 ; COMPILED XREF FOR FILE #52.2 ; 01/17/08
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA13.m

    r613 r623  
    1 PSOXZA13 ; COMPILED XREF FOR FILE #52.25 ; 11/08/09
     1PSOXZA13 ; COMPILED XREF FOR FILE #52.25 ; 01/17/08
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA14.m

    r613 r623  
    1 PSOXZA14 ; COMPILED XREF FOR FILE #52.2551 ; 11/08/09
     1PSOXZA14 ; COMPILED XREF FOR FILE #52.2551 ; 01/17/08
    22 ;
    33 S DA(2)=DA(1) S DA(1)=0 S DA=0

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA2.m

    r613 r623  
    1 PSOXZA2 ; COMPILED XREF FOR FILE #52.01 ; 11/08/09
     1PSOXZA2 ; COMPILED XREF FOR FILE #52.01 ; 01/17/08
    22 ;
    33 S DA(1)=DA S DA=0

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA3.m

    r613 r623  
    1 PSOXZA3 ; COMPILED XREF FOR FILE #52.052311 ; 11/08/09
     1PSOXZA3 ; COMPILED XREF FOR FILE #52.052311 ; 01/17/08
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA4.m

    r613 r623  
    1 PSOXZA4 ; COMPILED XREF FOR FILE #52.1 ; 11/08/09
     1PSOXZA4 ; COMPILED XREF FOR FILE #52.1 ; 01/17/08
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA5.m

    r613 r623  
    1 PSOXZA5 ; COMPILED XREF FOR FILE #52.2 ; 11/08/09
     1PSOXZA5 ; COMPILED XREF FOR FILE #52.2 ; 01/17/08
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA6.m

    r613 r623  
    1 PSOXZA6 ; COMPILED XREF FOR FILE #52.25 ; 11/08/09
     1PSOXZA6 ; COMPILED XREF FOR FILE #52.25 ; 01/17/08
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA7.m

    r613 r623  
    1 PSOXZA7 ; COMPILED XREF FOR FILE #52.2551 ; 11/08/09
     1PSOXZA7 ; COMPILED XREF FOR FILE #52.2551 ; 01/17/08
    22 ;
    33 S DA(2)=DA(1) S DA(1)=0 S DA=0

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA8.m

    r613 r623  
    1 PSOXZA8 ; COMPILED XREF FOR FILE #52 ; 11/08/09
     1PSOXZA8 ; COMPILED XREF FOR FILE #52 ; 01/17/08
    22 ;
    33 S DIKZK=1

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA9.m

    r613 r623  
    1 PSOXZA9 ; COMPILED XREF FOR FILE #52.01 ; 11/08/09
     1PSOXZA9 ; COMPILED XREF FOR FILE #52.01 ; 01/17/08
    22 ;
    33 S DA(1)=DA S DA=0
Note: See TracChangeset for help on using the changeset viewer.