Changeset 636 for FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBINGO.m

-              r628
+              r636
 PSOBINGO ;BHAM ISC/LC - BINGO BOARD OPTION DRIVER ;8/1/07 1:45pm
  ;;7.0;OUTPATIENT PHARMACY;**12,28,56,125,152,232,268,275**;DEC 1997;Build 8
+PSOBINGO ;BHAM ISC/LC - BINGO BOARD OPTION DRIVER ;1/18/06 9:09am
+ ;;7.0;OUTPATIENT PHARMACY;**12,28,56,125,152,232,268**;DEC 1997;Build 9
  ;External Ref. to ^PS(55 is supp. by DBIA# 2228
  ;External Ref. to ^PSDRUG(, is supp. by DBIA# 221
+ ;
+ ;*232 add ATIC xref set/kill code here
+ ;*275 BA xref sometimes gets corrupted, kill bad BA xref and quit
+ ;PSO*7*232 add ATIC xref set/kill code here
+ ;
  S (FLAG,FLAG1)=0,(TRIPS,JOES,ADV,DGP)="" G:'$G(PSOAP) END D:'$D(PSOPAR) ^PSOLSET G:'$D(PSOPAR) END
 …
 FIRST ;Set 1st dup
  S DR="11////A" D ^DIE K DR,CNT
+BROW 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  Q:NOPE
+ . ;add check for bad xref and kill        *275
+ . I '$D(^PS(52.11,NIEN,0)) K ^PS(52.11,"BA",NAM,NIEN) Q
+ . D:$D(^PS(52.11,"BI")) BICK Q:CNT>0
+ . D SETNEW
+BROW 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
+ Q
 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

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBPSU1.m

-              r628
+              r636
 PSOBPSU1 ;BIRM/MFR - BPS (ECME) Utilities 1 ;10/15/04
  ;;7.0;OUTPATIENT PHARMACY;**148,260,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**148,260**;DEC 1997;Build 84
  ;Reference to $$EN^BPSNCPDP supported by IA 4415
  ;References to $$NDCFMT^PSSNDCUT,$$GETNDC^PSSNDCUT supported by IA 4707
 …
  I $$NDCFMT^PSSNDCUT($G(NDC))="" D
  . S NDC=$$GETNDC^PSSNDCUT($$GET1^DIQ(52,RX,6,"I"),$$RXSITE^PSOBPSUT(RX,RFL),+$G(CMOP))
  . I $G(NDC)'="" D SAVNDC^PSONDCUT(RX,RFL,NDC,+$G(CMOP),1)
+ . I $G(NDC)'="" D SAVNDC^PSONDCUT(RX,RFL,NDC,+$G(CMOP))
+ ;
  ; - Creating ECME Activity Log on the PRESCRIPTION file
 …
  I $G(RVTX)="",FROM="ED" S RVTX="RX EDITED"
  S RESP=$$EN^BPSNCPDP(RX,RFL,$$DOS(RX,RFL,.DATE),FROM,NDC,$G(RVTX),$G(OVRC),,$G(CLA),$G(PA))
- I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" D SAVNDC^PSONDCUT(RX,RFL,NDC,+$G(CMOP),1)
+ ;
  ; - Reseting the Re-transmission flag
 …
  ; - Logging ECME Activity Log to the PRESCRIPTION file
  I $G(ALTX)="" D
+ . N X,ROUTE S (ROUTE,X)=""
+ . S ROUTE=$S(FROM="RF":$$GET1^DIQ(52.1,RFL_","_RX_",",2),FROM="OF":$$GET1^DIQ(52,RX_",",11),1:"")
+ . S:FROM="OF" X=ROUTE_" FILL(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
+ . S:FROM="RF" X=ROUTE_" REFILL(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
+ . N X S X=""
+ . S:FROM="OF" X="WINDOW FILL(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
+ . S:FROM="RF" X="WINDOW REFILL(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
  . S:FROM="RN" X="RX RENEWED(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
  . S:FROM="PL" X="PRINTED FROM SUSPENSE(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
+ . S:FROM="PL" X="SUSP LABEL PRINTED(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
  . S:FROM="PE"!(FROM="PP") X="PULLED FROM SUSPENSE(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
  . S:FROM="PC" X="CMOP TRANSMISSION(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBPSUT.m

-              r628
+              r636
 PSOBPSUT ;BIRM/MFR - BPS (ECME) Utilities ; 07 Jun 2005  8:39 PM
  ;;7.0;OUTPATIENT PHARMACY;**148,247,260,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**148,247,260**;DEC 1997;Build 84
  ;Reference to $$ECMEON^BPSUTIL supported by IA 4410
  ;Reference to IBSEND^BPSECMP2 supported by IA 4411
 …
+ ;
  ; - Get the REFILL # (multiple IEN)
- N STATUS
  I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
  ; - Not the latest fill for the prescription
  I RFL'=$$LSTRFL^PSOBPSU1(RX) Q 0
+ ; - Status not ACTIVE, DISCONTINUED, or EXPIRED
+ S STATUS=$$GET1^DIQ(52,RX,100,"I")
+ I STATUS'=0&(STATUS'=11)&(STATUS'=12) Q 0
+ ; - Status not ACTIVE
+ I $$GET1^DIQ(52,RX,100,"I")'=0 Q 0
  ; Will suspend for CMOP
  I '$G(IGCMP),$$CMOP(RX,RFL) Q 0

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBUILD.m

-              r628
+              r636
 PSOBUILD ;IHS/DSD/JCM - BUILD ARRAY OF PATIENTS CURRENT MEDS  [ 07/15/96  5:25 PM ] ;6/21/07 8:20am
  ;;7.0;OUTPATIENT PHARMACY;**23,82,119,132,235,206**;DEC 1997;Build 39
+PSOBUILD ;IHS/DSD/JCM - BUILD ARRAY OF PATIENTS CURRENT MEDS  [ 07/15/96  5:25 PM ]
+ ;;7.0;OUTPATIENT PHARMACY;**23,82,119,132,235**;DEC 1997
  ;External reference ^PS(50.606 supported by DBIA 2174
  ;External reference ^PS(50.7 supported by DBIA 2223
 …
  S PSODRG=+$P(PSORX0,"^",6) G:'$D(^PSDRUG(PSODRG,0)) GETX S PSODRUG0=^PSDRUG(PSODRG,0),PSOVACL=$P(PSODRUG0,"^",2),PSODYS=$P(PSORX0,"^",8)
+ ;
  I PSOST0<12!(PSOST0=16),PSOEXPDT<DT D:$P(PSORX0,"^",15)'=11
+ I PSOST0<12,PSOEXPDT<DT D:$P(PSORX0,"^",15)'=11
  .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
  .D ECAN^PSOUTL(DA) K DA
 …
  I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" S PSOSTN=PSOSTN_"M"
  S CLOZPT=$S($P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1":1,1:0)
  I 'CLOZPT,($P(PSODRUG0,"^",3)["A")&($P(PSODRUG0,"^",3)'["B") S PSOSTN=PSOSTN_"B",PSOSTF=PSOSTF_"B"
  K CLOZPT I ($P(PSODRUG0,"^",3)["W")!($P(PSODRUG0,"^",3)[1)!($P(PSODRUG0,"^",3)[2) S PSOSTN=PSOSTN_"C"
+ I 'CLOZPT,$P(PSODRUG0,"^",3)["A",$P(PSODRUG0,"^",3)'["B" S PSOSTN=PSOSTN_"B",PSOSTF=PSOSTF_"B"
+ K CLOZPT I $P(PSODRUG0,"^",3)["W" S PSOSTN=PSOSTN_"C"
  I $D(^PS(53,+$P(PSORX0,"^",3),0)),'$P(^(0),"^",5) S PSOSTN=PSOSTN_"D"
  I PSOST0=1 S PSOSTN=PSOSTN_"E"

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN2.m

-              r628
+              r636
 PSOCAN2 ;BHAM ISC/JMB - modular rx cancel with speed ability drug check ; 10/23/06 11:30am
  ;;7.0;OUTPATIENT PHARMACY;**8,18,62,46,88,164,235,148,259,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**8,18,62,46,88,164,235,148,259**;DEC 1997;Build 5
  ;External reference to ^PSDRUG supported by dbia 221
 REINS N DODR
 …
  . N ACTION
  . D ECMESND^PSOBPSU1(RXIEN,,,$S($O(^PSRX(RXIEN,1,0)):"RF",1:"OF"))
  . I $$FIND^PSOREJUT(RXIEN) S ACTION=$$HDLG^PSOREJU1(RXIEN,,"79,88","OF","IOQ","Q")
+ . I $$FIND^PSOREJUT(RXIEN) S ACTION=$$HDLG^PSOREJU1(RXIEN,,"79,88","OF","IOQ","I")
+ ;
  W !?3,"Prescription #",RX," "

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN4.m

-              r628
+              r636
+PSOCAN4 ;BIR/SAB-rx speed dc listman ; 10/23/06 11:50am
+ ;;7.0;OUTPATIENT PHARMACY;**20,24,27,63,88,117,131,259,268**;DEC 1997;Build 9
+PSOCAN4 ;BIR/SAB-rx speed dc listman ; 11/3/06 9:50pm
+ ;;7.0;OUTPATIENT PHARMACY;**20,24,27,63,88,117,131,259,268,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External reference to File #200 supported by DBIA 224
  ;External reference NA^ORX1 supported by DBIA 2186
 …
 OK S ORD=SAVORD,ORN=SAVORN Q
 NOOR ;ask nature of order
+ D FULL^VALM1
+ K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]"" D  Q:$D(DIRUT)  G NOORXP
+ .S PSONOOR=$$NA^ORX1("S",0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:""))
+ .I +PSONOOR S PSONOOR=$P(PSONOOR,"^",3) Q
+ .S DIRUT=1 K PSONOOR
+ S DIR("A")="Nature of Order: ",DIR("B")=$S($G(DODR):"SERVICE CORRECTED",1:"WRITTEN")
+ 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:"")
+ D ^DIR K DIR,DTOUT,DTOUT Q:$D(DIRUT)  S PSONOOR=Y
+ ;vfah set nature of order automatically for autofinish,rx
+ I $G(PSOAFYN)'="Y" D FULL^VALM1 ;vfah
+ I $G(PSOAFYN)'="Y" K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]"" D  Q:$D(DIRUT)  G NOORXP ;vfah
+ .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
+ .I $G(PSOAFYN)'="Y" I +PSONOOR S PSONOOR=$P(PSONOOR,"^",3) Q  ;vfah
+ .I $G(PSOAFYN)'="Y" S DIRUT=1 K PSONOOR ;vfah
+ I $G(PSOAFYN)'="Y" S DIR("A")="Nature of Order: ",DIR("B")=$S($G(DODR):"SERVICE CORRECTED",1:"WRITTEN") ;vfah
+ 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:"")
+ I $G(PSOAFYN)'="Y" D ^DIR K DIR,DTOUT,DTOUT Q:$D(DIRUT)  S PSONOOR=Y ;vfah
+ I $G(PSOAFYN)="Y" S PSONOOR="S" ;vfah sets nature of order to service correction for autofinish,rx
+ ;vfah end of set nature of order
 NOORXP I $G(PSOCANRA),'$G(PSOCANRZ) D REQ
 NOORX S:$D(DIRUT)&($G(SPEED)) VALMBCK="Q"

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCMOP.m

-              r628
+              r636
 PSOCMOP ;BIR/HTW-Rx Order Entry Screen for CMOP ; 6/28/07 7:35am
  ;;7.0;OUTPATIENT PHARMACY;**2,16,21,27,43,61,126,148,274**;DEC 1997;Build 8
+PSOCMOP ;BIR/HTW-Rx Order Entry Screen for CMOP ;02/19/98  9:21 AM
+ ;;7.0;OUTPATIENT PHARMACY;**2,16,21,27,43,61,126,148**;DEC 1997
  ;External reference to ^PS(55 supported by DBIA 2228
  ;External reference to ^PSDRUG supported by DBIA 221
 …
  D REVERSE^PSOBPSU1(RXN,,"DC",3)
+ Q
 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
+ACT 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
  S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA  S IR=FDA
  S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPC.m

-              r628
+              r636
 PSOCPC ;BHAM ISC/BAB - PHARMACY CO-PAY APPLICATION ; 7/13/07 10:21am
  ;;7.0;OUTPATIENT PHARMACY;**10,9,71,85,114,157,143,239,201,275**;DEC 1997;Build 8
+PSOCPC ;BHAM ISC/BAB - PHARMACY CO-PAY APPLICATION ;06/09/92
+ ;;7.0;OUTPATIENT PHARMACY;**10,9,71,85,114,157,143,239,201**;DEC 1997
+ ;
  ;REF/IA
 …
  . D ASKEXEM
  I $D(PSOCHG) D
- . ;PSO*7*275 IBQ node should not be present in some cases.
- . K ^PSRX(PSODA,"IBQ")
  . S:PSOSCP<50&($TR(PSOIBQ,"^")'="")&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)'=1) ^PSRX(PSODA,"IBQ")=PSOIBQ
  . D RESET^PSORN52D  ;set SC/EI on ICD node

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCSTM.m

-              r628
+              r636
 PSOCSTM ;BHAM ISC/SAB - monthly rx cost compilation ;7/10/06 4:36pm
  ;;7.0;OUTPATIENT PHARMACY;**4,17,19,28,89,212,246**;DEC 1997;Build 12
+PSOCSTM ;BHAM ISC/SAB - monthly rx cost compilation ;9/14/05 1:13pm
+ ;;7.0;OUTPATIENT PHARMACY;**4,17,19,28,89,212**;DEC 1997
  ;External Ref. to ^PS(55 DBIA# 2228
  ;External Ref. to ^DPT DBIA# 10035
  ;External Ref. to ^PSDRUG DBIA# 221
+ ;
+ ;*212 don't allow this request, if monthly compile is running
+ ;*246 alter SRCH1 For loop to not init to numeric values
+ ;PSO*212 don't allow this request, if monthly compile is running
+ ;
  Q:$$MTHLCK(1)            ;get lock, quit if already locked    PSO*212
 …
+ Q
+ ;
+SRCH1 D INI
+ ;refill
+ S PSDT1=PSDT                                ;*246
+ F  S PSDT1=$O(^PSRX("AL",PSDT1)) Q:($E(PSDT1,1,7)<PSDT)!($E(PSDT1,1,7)>PSDTX)  D
+SRCH1 D INI F PSDT1=PSDT:0:PSDTX S PSDT1=$O(^PSRX("AL",PSDT1)) Q:'PSDT1!($E(PSDT1,1,7)>PSDTX)  D
  .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
  .S NDT=$O(^PSRX("AL",PSDT1)) D:$P(NDT,".")'=CDT VST
+ ;partial fill
+ S PSDT1=PSDT                                ;*246
+ F  S PSDT1=$O(^PSRX("AM",PSDT1)) Q:($E(PSDT1,1,7)<PSDT)!($E(PSDT1,1,7)>PSDTX)  D
+ F PSDT1=PSDT:0:PSDTX S PSDT1=$O(^PSRX("AM",PSDT1)) Q:'PSDT1!($E(PSDT1,1,7)>PSDTX)  D
  .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
  .S NDT=$O(^PSRX("AM",PSDT1)) D:$P(NDT,".")'=CDT VST K PAR

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODEA.m

-              r628
+              r636
 PSODEA ;BHAM ISC/  - HELP TEXT FOR DEA FIELD IN DRUG FILE ; 10/17/07 7:41am
  ;;7.0;OUTPATIENT PHARMACY;**206**;DEC 1997;Build 39
+PSODEA ;BHAM ISC/  - HELP TEXT FOR DEA FIELD IN DRUG FILE ; 06/03/92 17:28
+ ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
  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,"
  W !,"A SCHEDULE 3 NARCOTIC WILL BE CODED '3A' AND A SCHEDULE 2 DEPRESSANT",!,"WILL BE CODED '2L'.  THE CODES ARE:",!
 …
  ;;R          RESTRICTED ITEMS
  ;;S          SUPPLY ITEMS
  ;;B          ALLOW REFILL (SCH. 3, 4, 5 ONLY)
+ ;;B          ALLOW REFILL (SCH. 3, 4, 5 NARCOTICS ONLY)
  ;;W          NOT RENEWABLE
  ;;
 EDIT ;INPUT XFORM FOR DEA FIELD IN DRUG FILE
  I X["B",(+X<3) W !,"The B designation is only valid for schedule 3, 4, 5 !",$C(7) K X Q
+ 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
+ Q

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODGDGI.m

-              r628
+              r636
 PSODGDGI ;BIR/SAB - drug drug interaction checker ; 6/28/07 7:36am
  ;;7.0;OUTPATIENT PHARMACY;**10,27,48,130,144,132,188,207,243,274**;DEC 1997;Build 8
+PSODGDGI ;BIR/SAB - drug drug interaction checker ;4/14/93
+ ;;7.0;OUTPATIENT PHARMACY;**10,27,48,130,144,132,188,207,243**;DEC 1997;Build 22
  ;External reference to ^PS(56 supported by DBIA 2229
  ;External reference to ^PSDRUG supported by DBIA 221
 …
  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
  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
 BLD I $D(^XUSEC("PSORPH",DUZ)) D PHARM Q
+BLD I $D(^XUSEC("PSORPH",DUZ)) S PSORX("PHARM")=DUZ D PHARM Q
  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
  I $P(^PS(56,IT,0),"^",4)=2 S SERS=IT_","_SERS,DGS=$P(PSOSD(STA,DRG),"^")_","_DGS

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR.m

-              r628
+              r636
 PSODIR ;BHAM ISC/SAB - asks data for rx order entry ; 9/17/07 5:03pm
  ;;7.0;OUTPATIENT PHARMACY;**37,46,111,117,146,164,211,264,275**;DEC 1997;Build 8
+PSODIR ;BHAM ISC/SAB - asks data for rx order entry ;02/12/93 8:49
+ ;;7.0;OUTPATIENT PHARMACY;**37,46,111,117,146,164,211,264**;DEC 1997;Build 19
  ;External reference PSDRUG( supported by DBIA 221
  ;External reference PS(50.7 supported by DBIA 2223
 …
  N DA K INS1,DD,DIR,DIRUT S D=0 F  S D=$O(PSODIR("SIG",D)) Q:'D  S DD=$G(DD)+1
  I $G(DD)=1 S PSODIR("INS")=$G(PSODIR("SIG",1)) G INSD
+ ;PSO*7*275 remove check for PSOINSFL just check for multi line sig
+ I $G(DD)>1 D  G EX
+ 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
  .K ^TMP($J) S D=0 F  S D=$O(PSODIR("SIG",D)) Q:'D  S ^TMP($J,"SIG",D,0)=PSODIR("SIG",D)
  .S DWPK=2,DWLW=80,DIC="^TMP($J,""SIG""," D EN^DIWE K PSODIR("SIG")

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR1.m

-              r628
+              r636
 PSODIR1 ;IHS/DSD - ASKS DATA FOR RX ORDER ENTRY CONT. ;6/21/07 8:22am
  ;;7.0;OUTPATIENT PHARMACY;**23,46,78,102,121,131,146,166,184,222,268,206**;DEC 1997;Build 39
+PSODIR1 ;IHS/DSD - ASKS DATA FOR RX ORDER ENTRY CONT. ;02/17/93 17:03
+ ;;7.0;OUTPATIENT PHARMACY;**23,46,78,102,121,131,146,166,184,222,268**;DEC 1997;Build 9
  ;Ext ref ^PS(55-DBIA 2228, ^PSDRUG(-DBIA 221
 PTSTAT(PSODIR) ;
 …
  .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)
  .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)
  I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) D  G REFILLX
  .I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2)!'$O(^PSRX(+$G(PSODIR("IRXN")),1,0))!('$G(PSOLOKED)) D  Q
+ I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") D  G REFILLX
+ .I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!'$O(^PSRX(+$G(PSODIR("IRXN")),1,0))!('$G(PSOLOKED)) D  Q
  ..S VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics.") W !,VALMSG,!
  ..S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR3.m

-              r628
+              r636
 PSODIR3 ;ISC-BIRM/SAB - rx order entry contd ;4/25/07 8:28am
  ;;7.0;OUTPATIENT PHARMACY;**3,46,184,222,206**;DEC 1997;Build 39
+PSODIR3 ;ISC-BIRM/SAB - rx order entry contd ;09/27/96
+ ;;7.0;OUTPATIENT PHARMACY;**3,46,184,222**;DEC 1997;Build 12
+ ;
 EXP(PSODIR) ;
 …
  .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)
  .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)
  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
  .S VALMSG="No refills allowed on "_$S($G(PSODRUG("DEA"))["A":"this narcotic drug.",1:"this drug.")
+ K PSOELSE I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F") D  Q
+ .S VALMSG="No refills allowed on "_$S($G(PSODRUG("DEA"))["F":"this drug.",1:"Narcotics ..")
  .W !,VALMSG,!
  .S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODISP.m

-              r628
+              r636
 PSODISP ;BIR/SAB,PWC-MANUAL BARCODE RELEASE FUNCTION ;03/02/93
+ ;;7.0;OUTPATIENT PHARMACY;**15,71,131,156,185,148,247,200**;DEC 1997;Build 7
+ ;;7.0;OUTPATIENT PHARMACY;**15,71,131,156,185,148,247,200,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;Reference to $$SERV^IBARX1 supported by DBIA 2245
  ;Reference to ^PSD(58.8 supported by DBIA 1036
 …
  S Y=$G(^PS(59,PSOSITE,"IB")),PSOIBSS=$$SERV^IBARX1(+Y) I 'PSOIBSS D IBSSR^PSOUTL I 'PSOIBFL D   G EXIT
  .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!",!
+AC1 W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2)
+ 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
+AC1 I $G(PSOAFYN)'="Y" W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2) ;vfah - VOE
+ I $G(PSOAFYN)="Y" S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2) ;vfah - VOE
+ 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
+ I $G(PSOAFYN)="Y" S PSRH=DUZ,PSZAR="0" ;vfah - VOE
  ;check for Drug Acct background job K8 & K7.1
  S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19.2 D ^DIC I Y=-1 K DIC,X,Y G BC
 …
  K PSA,DIC,DA,X,Y,DIQ
 BC ;
+ I $G(PSOAFYN)="Y",$G(PSZAR)="1" Q  ;vfah - VOE
  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
+ 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
+ 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
+ I $G(PSOAFYN)="Y" S X=RXN,PSZAR="1" ;vfah - VOE
  I $D(DIRUT)!($D(DTOUT))!($D(DUOUT)) K DIRUT,DTOUT,DUOUT G AC1
  I X'["-" D BCI W:'$G(RXP) !,"INVALID PRESCRIPTION NUMBER" G:'$G(RXP) BC S MAN=1 G BC1
 …
  .I $$MANREL^PSOBPSUT(RXP,0,$G(PSOPID))="^" K LBLP Q
  .;
  .S:$D(^PSDRUG(QDRUG,660.1)) ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
+ .S:$D(^PSDRUG(QDRUG,660.1))&($G(PSOAFYN)'="Y") ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY ;vfah - VOE
  .D NOW^%DTC S DIE="^PSRX(",DA=RXP,DR="31///"_%_";23////"_PSRH_";32.1///@;32.2///@",PSODT=% D ^DIE K DIE,DR,DA,LBL
  .;
 …
  N BFILL S BFILL=0
  S PSOCPRX=$P(^PSRX(RXP,0),"^") D CP^PSOCP
  W !?7,"Prescription Number "_$P(^PSRX(RXP,0),"^")_" Released"
+ I $G(PSOAFYN)'="Y" W !?7,"Prescription Number "_$P(^PSRX(RXP,0),"^")_" Released" ;vfah - VOE
  ;initialize bingo board variables
  I $G(LBLP),$P(^PSRX(RXP,0),"^",11)["W" S BINGRO="W",BINGNAM=$P(^PSRX(RXP,0),"^",2),BINGDIV=$P(^PSRX(RXP,2),"^",9)

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODISPS.m

-              r628
+              r636
 PSODISPS ;BIR/SAB-CONTINUATION OF RELEASE FUNCTION ;3/2/93
+ ;;7.0;OUTPATIENT PHARMACY;**15,13,9,27,67,71,156,118,148,247,200**;DEC 1997;Build 7
+ ;;7.0;OUTPATIENT PHARMACY;**15,13,9,27,67,71,156,118,148,247,200,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External reference ^PS(59.7 supported by DBIA 694
  ;External reference to ^PSDRUG("AQ" supported by DBIA 3165
 …
  .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)
  W:$G(IFN) !?7,"Prescription Number "_$P(^PSRX(RXP,0),"^")_$S('$G(XTYPE):" Partial Fill",1:" Refill(s)")_" Released" I $G(SPEED) G XMIT
  W:'$G(IFN) !?7,"No "_$S($G(XTYPE):"Refill(s)",1:"Partial(s)")_" to be Released"
+ I $G(PSOAFYN)'="Y" W:'$G(IFN) !?7,"No "_$S($G(XTYPE):"Refill(s)",1:"Partial(s)")_" to be Released" ;vfah - VOE
 XMIT I $G(PSODISP)=2.4 D  ;build an send HL7 v2.4 messages to dispense system
  . F I=0:0 S SUB=$O(^PSRX(RXP,"A",I)) Q:'I  I $P(^PSRX(RXP,"A",I,0),"^",2)="N" D

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODRDUP.m

-              r628
+              r636
 PSODRDUP ;BIR/SAB - Dup drug class checker ;11/1/04 3:38pm
+ ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,39,56,130,132,192,207,222,243**;DEC 1997;Build 22
+ ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,39,56,130,132,192,207,222,243,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+ ;
  ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
+ I $G(PSOAFYN)="Y" Q  ;vfam No Dup Drug Check by AutoFinish,Rx - VOE
  S $P(PSONULN,"-",79)="-",(STA,DNM)="" K CLS
  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"))

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODRG.m

-              r628
+              r636
 PSODRG ;IHS/DSD/JCM-ORDER ENTRY DRUG SELECTION ;03/30/93
+ ;;7.0;OUTPATIENT PHARMACY;**20,23,36,53,54,46,112,139,207,148,243,268**;DEC 1997;Build 9
+ ;;7.0;OUTPATIENT PHARMACY;**20,23,36,53,54,46,112,139,207,148,243,268,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;Reference ^PSDRUG supported by DBIA 221
  ;Reference ^PS(50.7 supported by DBIA 2223
 …
  K NFI Q
 POST ;order checks
+ I $G(PSOAFYN)="Y" G POSTX ;vfam - VOE
  K PSORX("INTERVENE") N STAT,SIG,PTR,NDF,VAP S PSORX("DFLG")=0
  D ^PSOBUILD

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHELP.m

-              r628
+              r636
 PSOHELP ;BHAM ISC/SAB-outpatient utility routine ; 10/17/07 7:41am
  ;;7.0;OUTPATIENT PHARMACY;**3,23,29,48,46,117,131,222,268,206**;DEC 1997;Build 39
+PSOHELP ;BHAM ISC/SAB-outpatient utility routine ; 2/17/93 18:00:36
+ ;;7.0;OUTPATIENT PHARMACY;**3,23,29,48,46,117,131,222,268**;DEC 1997;Build 9
  ;External reference ^PS(51 supported by DBIA 2224
  ;External reference ^PSDRUG( supported by DBIA 221
 …
  S PSODEA=$P(^PSDRUG(P(5),0),"^",3),CS=0
  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
  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
+ 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
  F DEA=1:1 Q:$E(PSODEA,DEA)=""  I $E(+PSODEA,DEA)>1,$E(+PSODEA,DEA)<6 S CS=1
  S PSOELSE=CS I PSOELSE D

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHELP3.m

-              r628
+              r636
 PSOHELP3 ;BHAM ISC/SAB - outpatient utility routine #4 ;2/17/93 18:00:36
  ;;7.0;OUTPATIENT PHARMACY;**20,291**;DEC 1997;Build 2
+ ;;7.0;OUTPATIENT PHARMACY;**20**;DEC 1997
 XREF ;code to create 'APD' xref on Drug Interaction file (#56)
  ;I '$D(ZTSK),'$D(PSMSG) D WAIT^DICD W "Building 'APD' X-Ref."
 …
+ Q
 DRUG ;selects drug and updates Rx file with cost (pso*7*20)
- W !!,"This option will update the drug cost on all fills in the PRESCRIPTION"
- W !,"file (#52) based on the selected date range and the current cost in the"
- W !,"DRUG file (#50).",!
  K X,Y,DA,DIC S DIC(0)="AQEM",DIC=50 D ^DIC I $G(DUOUT) K DIC,Y,X,DA Q
  I Y<0 G OUT
  S (DRG,DA)=+Y K DIC,DR,DIQ S DIC=50,DR=16,DIQ="PSODRG",DIQ(0)="I"
  D EN^DIQ1 S COST=PSODRG(50,DA,16,"I") K PSODRG,DIC,DA,DR,DIQ,DIR
+ 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
+ S REF=$S(Y:0,1:1)
+ S X1=DT,X2=-485 D C^%DTC S (DEF,Y)=X X ^DD("DD")
+ 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
+ S REF=$S(Y:Y,1:0),X1=DT,X2=-485 D C^%DTC S (DEF,Y)=X X ^DD("DD")
  W !!,"You can only go back One Year plus 120 days."
  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
  S (FBCK,%DT(0))=Y,%DT("A")="Enter ending fill date: " D ^%DT
+ 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
+ S (FBCK,%DT(0))=Y,%DT("A")="How far AHEAD do you want to go: " D ^%DT
  K %DT I Y<0!($D(DTOUT)) K FBCK,REF,COST,DRG,X,Y Q
+ S FAHD=Y
+ S PSOFUTR=0 I FAHD>(DT-1) S PSOFUTR=1 D
+ .W !!,"Since you selected an end fill date of today or in the future, this option"
+ .W !,"will update the cost for all existing and suspended fills that have a"
+ .W !,"fill date in the future.",!
+ 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
+ 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
  I Y S PSOQ=1 K ZTDTH D  G OUT
  .S ZTRTN="EN^PSOHELP3",ZTIO="",ZTDESC="Outpatient Pharmacy Rx Cost Update"
+ .F G="REF","COST","DRG","FBCK","FAHD","PSOQ","PSOFUTR" S:$D(@G) ZTSAVE(G)=""
+ .D ^%ZTLOAD I $D(ZTSK) W !!,"Rxs Cost Update Queued",! K ZTSK
+EN W:'$G(PSOQ) !,"Updating cost. Please wait... "
+ S FDT=FBCK-1 F  S FDT=$O(^PSRX("ADL",FDT)) Q:'FDT  D  Q:FDT>FAHD
+ .I '$G(PSOFUTR) I FDT>FAHD Q
+ .S RXN=0 F  S RXN=$O(^PSRX("ADL",FDT,DRG,RXN)) Q:'RXN  D  W:'$G(PSOQ) "."
+ ..I $P($G(^PSRX(RXN,0)),"^",6)=DRG,$P($G(^(2)),"^",2)=FDT S $P(^PSRX(RXN,0),"^",17)=COST
+ I 'REF G OUT
+ D REFILL,PARTIAL
+OUT K G,COST,I,X,Y,REF,RXN,FDT,FAHD,FBCK,DRG,PSOQ,DIRUT,PSOFUTR I $D(ZTQUEUED) S ZTREQ="@"
+ .F G="REF","COST","DRG","FBCK","FAHD","PSOQ" S:$D(@G) ZTSAVE(G)=""
+ .D ^%ZTLOAD I $D(ZTSK) W !,"Rxs Cost Update Queued" K ZTSK
+EN 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) "."
+ .I $P($G(^PSRX(RXN,0)),"^",6)=DRG,$P($G(^(2)),"^",2)=FDT S $P(^PSRX(RXN,0),"^",17)=COST
+ .Q:'REF
+ .F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I  S $P(^PSRX(RXN,1,I,0),"^",11)=COST
+ .F I=0:0 S I=$O(^PSRX(RXN,"P",I)) Q:'I  S $P(^PSRX(RXN,"P",I,0),"^",11)=COST
+OUT K G,COST,I,X,Y,REF,RXN,FDT,FAHD,FBCK,DRG,PSOQ,DIRUT I $D(ZTQUEUED) S ZTREQ="@"
+ Q
 POST ;post install entry point.  builds new "ADL" xref for file 52 pso*7*20
 …
  K X,Y,DEF,FTY,IFN S ZTREQ="@"
+ Q
-REFILL ;
- N FILL,FDT,RXN
- S FDT=FBCK-1 F  S FDT=$O(^PSRX("AD",FDT)) Q:'FDT  D  Q:FDT>FAHD
- .I '$G(PSOFUTR),FDT>FAHD Q
- .S RXN="" F  S RXN=$O(^PSRX("AD",FDT,RXN)) Q:'RXN  D
- ..I $P($G(^PSRX(RXN,0)),"^",6)'=DRG Q
- ..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
+ Q
-PARTIAL ;
-  N FILL,FDT,RXN
-  S FDT=FBCK-1 F  S FDT=$O(^PSRX("ADP",FDT)) Q:'FDT  D  Q:FDT>FAHD
- .I '$G(PSOFUTR),FDT>FAHD Q
- .S RXN="" F  S RXN=$O(^PSRX("ADP",FDT,RXN)) Q:'RXN  D
- ..I $P($G(^PSRX(RXN,0)),"^",6)'=DRG Q
- ..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
+ Q

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLD.m

-              r628
+              r636
 PSOHLD ;BIR/SAB - hold unhold functionality ;07/15/96
  ;;7.0;OUTPATIENT PHARMACY;**1,16,21,24,27,32,55,82,114,130,166,148,268,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**1,16,21,24,27,32,55,82,114,130,166,148,268**;DEC 1997;Build 9
  ;External reference to ^DD(52-DBIA 999,  VA(200-DBIA 224, NA^ORX1-DBIA 2186,
  ; L, UL, PSOL, and PSOUL^PSSLOCK-DBIA 2789, ^%DTC-DBIA 10000, ^DIE-DBIA 10018, ^DIR-DBIA 10026,
 …
  . D ECMESND^PSOBPSU1(RX,RFL,,$S(RFL:"RF",1:"OF"))
  . I $$FIND^PSOREJUT(RX,RFL) D
  . . S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","Q")
+ . . S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","I")
+ ;
  I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=DA_"," D ULP G EX

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLEXP.m

-              r628
+              r636
+PSOHLEXP ;BIR/RTR-Auto expire prescriptions ; 10/10/07 11:16am
+ ;;7.0;OUTPATIENT PHARMACY;**10,22,36,73,148,257**;DEC 1997;Build 19
+PSOHLEXP ;BIR/RTR-Auto expire prescriptions ;10/10/96
+ ;;7.0;OUTPATIENT PHARMACY;**10,22,36,73,148**;DEC 1997
+ ;External reference to STATUS^ORQOR2 is supported by DBIA 3458
+ ;
+ ;External reference to ^PS(59.7 supported by DBIA 694
+ ;External reference to STATUS^ORQOR2 is supported by DBIA 3458
+ ;External references to LOCK1^ORX2 and UNLK1^ORX2 are supported by DBIA 867
+EN N PSOEXRX,PSOEXCOM,PSOEXSTS,SUSD,PSOEXSTA,ZZDT,ZZEDT,IFN,NODE,RF,PIFN,PSUSD,PRFDT,PDA,PSDTEST,ORN,CPRSDC
+EN N PSOEXRX,PSOEXCOM,PSOEXSTS,SUSD,PSOEXSTA,ZZDT,IFN,NODE,RF,PIFN,PSUSD,PRFDT,PDA,PSDTEST,ORN
  I '$G(DT) S DT=$$DT^XLFDT
+ S X1=DT,X2=-1 D C^%DTC S ZZEDT=X
+ 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
+ F  S ZZDT=$O(^PSRX("AG",ZZDT)) Q:ZZDT>ZZEDT  Q:ZZDT=""  D EN1
+ Q
+EN1 F PSOEXRX=0:0 S PSOEXRX=$O(^PSRX("AG",ZZDT,PSOEXRX)) Q:'PSOEXRX  D:$D(^PSRX(PSOEXRX,0))
+ .N CPRSDC,CPRSSTA
+ .S CPRSDC=",1,7,12,13,"
+ .S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2),CPRSSTA=""
+ .I ORN S CPRSSTA=+$$STATUS^ORQOR2(ORN) I CPRSSTA=0 S ORN=""
+ S X1=DT,X2=-1 D C^%DTC S ZZDT=X
+ F PSOEXRX=0:0 S PSOEXRX=$O(^PSRX("AG",ZZDT,PSOEXRX)) Q:'PSOEXRX  D:$D(^PSRX(PSOEXRX,0))
  .Q:$P($G(^PSRX(PSOEXRX,2)),"^",6)'=ZZDT
- .K CMOP S DA=PSOEXRX I DA D ^PSOCMOPA  ;*257 ;SET UP CMOP() ARRAY
  .S DA=$O(^PS(52.5,"B",PSOEXRX,0))
  .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
 …
  .I $G(^PSRX(PSOEXRX,"H"))]"" K:$P(^PSRX(PSOEXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOEXRX,"H"),"^"),PSOEXRX) S ^PSRX(PSOEXRX,"H")=""
  .S PSOEXSTA=$P($G(^PSRX(PSOEXRX,"STA")),"^")
+ .I PSOEXSTA=13 D  Q
+ ..I 'ORN D EN^PSOHDR("PRES",PSOEXRX)
+ .I PSOEXSTA=12!(PSOEXSTA=14)!(PSOEXSTA=15) I ORN,CPRSDC'[(","_CPRSSTA_",") D
+ ..D EN^PSOHLSN1(PSOEXRX,"OD","","","A")
+ ..I ORN S CPRSSTA=+$$STATUS^ORQOR2(ORN)
+ .I PSOEXSTA=11 I ORN,CPRSDC'[(","_CPRSSTA_",") D
+ .Q:PSOEXSTA=13!(PSOEXSTA="")
+ .I '$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) D EN^PSOHLSN1(PSOEXRX,"ZC","") I $P($G(^PSRX(PSOEXRX,"OR1")),"^",2) D
+ ..I PSOEXSTA=12!(PSOEXSTA=14)!(PSOEXSTA=15) D EN^PSOHLSN1(PSOEXRX,"OD","","","A")
+ .I PSOEXSTA=11 S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) I ORN,+$$STATUS^ORQOR2(ORN)=6 D
  ..S $P(^PSRX(PSOEXRX,0),"^",19)=1
  ..D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired")
  .I PSOEXSTA>9&(PSOEXSTA'=16) Q
+ .Q:PSOEXSTA>9
  .S $P(^PSRX(PSOEXRX,"STA"),"^")=11
  .D REVERSE^PSOBPSU1(PSOEXRX,0,"DE",5,"RX EXPIRED")
+ .I '$G(PSUSD) D REVERSE^PSOBPSU1(PSOEXRX,0,"DE",5,"RX EXPIRED")
  .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)),"^")
- .S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2)
  .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
  ..D REVERSE^PSOBPSU1(PSOEXRX,PSUSD,"DE",5,"RX EXPIRED")
  ..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
+ ..I $G(CMOP(CMOP("L")))="",".L.X."[("."_$G(CMOP("S"))_".") S PSDTEST=1
+ ..N PSOORL
+ ..S PSOORL=$$LOCK1^ORX2(ORN) S:'PSOORL PSDTEST=1 I PSOORL D UNLK1^ORX2(ORN)
+ ..N PDA0
+ ..;S PDAQ=0
+ ..F PDA=0:0 S PDA=$O(^PSRX(PSOEXRX,4,PDA)) Q:'PDA  D
+ ...S PDA0=$G(^PSRX(PSOEXRX,4,PDA,0))
+ ...I $P(PDA0,"^",3)=PSUSD S PSDTEST=1   ;*257
+ ..;Q:'PDAQ
+ ..;S PSDTEST=1
+ .I 'ORN D EN^PSOHDR("PRES",PSOEXRX) Q
+ .I CPRSDC[(","_CPRSSTA_",") D EN^PSOHDR("PRES",PSOEXRX) Q
+ ..S DA=PSOEXRX K CMOP D ^PSOCMOPA I $G(CMOP(CMOP("L")))="",$G(CMOP("S"))'="L" Q
+ ..S PSDTEST=1
+ .Q:'$P($G(^PSRX(PSOEXRX,"OR1")),"^",2)
  .S $P(^PSRX(PSOEXRX,0),"^",19)=1
  .S PSOEXCOM="Prescription past expiration date" D EN^PSOHLSN1(PSOEXRX,"SC","ZE",PSOEXCOM)
- S DIE=59.7,DA=1,DR="49.95///"_ZZDT D ^DIE K DIE,DA,DR
+ Q
 NSET ;

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN.m

-              r628
+              r636
 PSOHLSN ;BIR/RTR-Send order information to OERR from file 52.41 ;10/10/94
  ;;7.0;OUTPATIENT PHARMACY;**1,7,15,24,27,30,55,46,98,88,121,292**;DEC 1997;Build 1
+ ;;7.0;OUTPATIENT PHARMACY;**1,7,15,24,27,30,55,46,98,88,121**;DEC 1997
  ;Externel reference EN^ORERR supported by DBIA 2187
+ ;
 …
  I '$G(PSIEN) Q
  I $G(STAT)="OC"!($G(STAT)="OD")!($G(STAT)="CR")!($G(STAT)="DR") D
- .D CHKOLDRX
  .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)
  S PSZERO=$G(^PS(52.41,PSIEN,0)),PSOHSTAT=$G(STAT)
 …
  .S PVAR=$S(PVAR="":PVAR1,1:PVAR_PVAR1)
+ Q
-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
- N PSOOLD
- S PSOOLD=$P($G(^PS(52.41,PSIEN,0)),"^",21)
- I PSOOLD'="",$P($G(^PSRX(PSOOLD,"STA")),"^")=11 S $P(^PSRX(PSOOLD,0),"^",19)=1
+ Q

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN1.m

-              r628
+              r636
 PSOHLSN1 ;BIR/RTR - Send order info to OERR from file 52 ;10/10/94
  ;;7.0;OUTPATIENT PHARMACY;**1,10,24,27,55,46,71,101,99,121,139,157,181,143,235,239,292**;DEC 1997;Build 1
+ ;;7.0;OUTPATIENT PHARMACY;**1,10,24,27,55,46,71,101,99,121,139,157,181,143,235,239**;DEC 1997
  ;Ref #50.606-DBIA 2174
  ;#50.607-2221
 …
  S COUNT=0,NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)="""""
  I '$D(^PSRX(PSRXIEN,0)) Q
- 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
  I STAT'="SN",STAT'="ZC",'$P($G(^PSRX(PSRXIEN,"OR1")),"^",2) Q
  I $G(STAT)="SC",$G(PSSTAT)="ZE" S $P(^PSRX(PSRXIEN,0),"^",19)=2

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL.m

-              r628
+              r636
 PSOLBL ;BIR/SAB/RTR-BOTTLE LABEL ;5/9/07 8:57am
  ;;7.0;OUTPATIENT PHARMACY;**8,19,30,36,47,71,92,120,157,244,206**;DEC 1997;Build 39
+PSOLBL ;BIR/SAB/RTR-BOTTLE LABEL ;6/29/06 11:39am
+ ;;7.0;OUTPATIENT PHARMACY;**8,19,30,36,47,71,92,120,157,244**;DEC 1997
  ;DBIAs PSDRUG-221, PS(55-2228, IBARX-125, PSXSRP-2201, %ZIS-3435, DPT-3097
+ ;
  ;*244 rem test for part fill when testing status > 11
+ ;*244 remove test for partial fill when testing status > 11
+ ;
 DQ I $D(PSOIOS),PSOIOS]"" D DEVBAR^PSOBMST
 …
  .K PSMP(PSI)
  S X=$S($D(^PS(55,DFN,0)):^(0),1:""),PSCAP=$P(X,"^",2),PS55=$P($G(X),"^",3),PS55X=$P($G(X),"^",5)
  I (($G(PS55X)]"")&(PS55>1)&(PS55X<DT)) S PS55=0
+ I (($G(PS55X)]"")&(PS55>1)&(PS55X<DT)) S PS55=1
  S:MW="M" MW=$S((PS55=1!(PS55=4)):"R",1:MW)
  S MW=$S(MW="M":"REGULAR",MW="R":"CERTIFIED",1:"WINDOW")
 …
  ;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")
  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
  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
+ 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
  S VRPH=$P(^PSRX(RX,2),"^",10),PSCLN=+$P(RXY,"^",5),PSCLN=$S($D(^SC(PSCLN,0)):$P(^(0),"^",2),1:"UNKNOWN")
  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)

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL4.m

-              r628
+              r636
 PSOLBL4 ;BIR/RTR-Set up routine for HL7 interface ;12/19/06 10:45am
  ;;7.0;OUTPATIENT PHARMACY;**26,70,156,244,233,246**;DEC 1997;Build 12
+PSOLBL4 ;BIR/RTR-Set up routine for HL7 interface ;10/20/96
+ ;;7.0;OUTPATIENT PHARMACY;**26,70,156,244,233**;DEC 1997;Build 8
  ;External reference to ^PSDRUG supported by DBIA 221
+ ;
  ;*244 - ignore RX's with a status > 11
- ;*246 - send marked drugs & print label (option 4) now working
+ ;
  N DIC,AP,X,Y,DPRT,QPRT
 …
  .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
  .I '$G(QPRT) S $P(PSOPAR,"^",30)=0
  Q:'$P($G(PSOPAR),"^",30)                ;HL7 interface turned off
+ Q:'$P($G(PSOPAR),"^",30)
  Q:$G(PSOEXREP)
 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
+HL 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
  S HLOSITE=$P($G(PSOPAR),"^",30)
  K ^UTILITY($J,"PSOHL"),^UTILITY($J,"PSOHLL"),HLRXY
  S PPLHL=PPL
  S HLFLAG=0 F II=1:1 S HLRX=$P(PPLHL,",",II) D  Q:$G(HLFLAG)
  .S HLNEXT=$P(PPLHL,",",(II+1)) I HLNEXT=""!(HLNEXT=",") S HLFLAG=1
+ S PPLHL=PPL G:HLOSITE=4 SOMD
+ S HLFLAG=0 F HLLOOP=1:1 S HLRX=$P(PPLHL,",",HLLOOP) D  Q:$G(HLFLAG)
+ .S HLNEXT=$P(PPLHL,",",(HLLOOP+1)) I HLNEXT=""!(HLNEXT=",") S HLFLAG=1
  .Q:'$G(HLRX)
  .Q:'$D(^PSRX(HLRX,0))
 …
  .I $P($G(^PSRX(HLRX,"STA")),"^")>11!('$P(^PSRX(HLRX,0),"^",2)) Q
  .I $G(PSODBQ) S HLRR=$O(^PS(52.5,"B",HLRX,0)) Q:'HLRR  I $G(^PS(52.5,+HLRR,"P"))=1 Q
+ .;   marked drug options 3 & 4
+ .I (HLOSITE=3)!(HLOSITE=4) S NOTMD=0 D  Q:NOTMD     ;quit, not marked
+ ..S HLJUST=+$P($G(^PSRX(HLRX,0)),"^",6)
+ ..S:'$P($G(^PSDRUG(HLJUST,6)),"^") NOTMD=1
+ .S HLRXY(II,HLRX)=""                                ;Valid Rx for HL7
+ .S:HLOSITE=3 HLRXYZ(HLRX)=""
+ ;
+ I $G(HLOSITE)=3,$D(HLRXY) D                 ;rebuild PPL print string
+ .K PPL F II=1:1 S HLRX=$P(PPLHL,",",II) Q:'HLRX  D
+ ..Q:$D(HLRXYZ(HLRX))
+ ..S PPL=$G(PPL)_HLRX_","
+ ;
+SOMDQ S (II,PSOQUE)=0 F  S II=$O(HLRXY(II)) Q:'II  S ^UTILITY($J,"PSOHLL",II)=$O(HLRXY(II,0)),PSOQUE=II
+ I PSOQUE=0 G ENDHL                ;Nothing set, bypass Call to Queue
+ F II=0:0 S II=$O(^UTILITY($J,"PSOHLL",II)) Q:'II  S HLINRX=^(II),HLINRX0=$G(^PSRX(HLINRX,0)) D
+ .S ^UTILITY($J,"PSOHLL",II)=HLINRX_"^"_+$P(HLINRX0,"^",6)_"^"_$S($G(RXPR(HLINRX)):"P",1:"F")
+ .;Here, if Site Parameter is 3, check entry in Drug File for National Id
+ .I $G(HLOSITE)=3 S HLJUST=+$P($G(^PSRX(HLRX,0)),"^",6) I '$P($G(^PSDRUG(HLJUST,6)),"^") Q
+ .S HLRXY(HLLOOP,HLRX)="" ; VALID RXS
+ .S:$G(HLOSITE)=3 HLRXYZ(HLRX)=""
+ I $G(HLOSITE)=3,$D(HLRXY) D
+ .N HLZFLAG,HLZ,HLZRX,HLZNEXT
+ .S HLZFLAG=0 K PPL F HLZ=1:1 S HLZRX=$P(PPLHL,",",HLZ) D  Q:$G(HLZFLAG)
+ ..S HLZNEXT=$P(PPLHL,",",(HLZ+1)) I HLZNEXT=""!(HLZNEXT=",") S HLZFLAG=1
+ ..Q:'$G(HLZRX)
+ ..Q:$D(HLRXYZ(HLZRX))
+ ..I $G(RXRP(HLZRX,"RP")) D  Q
+ ...I $G(PPL)="" S PPL=HLZRX_"," Q
+ ...S PPL=PPL_HLZRX_","
+ ..I $G(PPL)="" S PPL=HLZRX_"," Q
+ ..S PPL=PPL_HLZRX_","
+SOMDQ S HLCOT=1,PSHALP="" F  S PSHALP=$O(HLRXY(PSHALP)) Q:PSHALP=""  S ^UTILITY($J,"PSOHLL",HLCOT)=$O(HLRXY(PSHALP,0)),HLCOT=HLCOT+1
+ I HLCOT=1 G ENDHL ; NOTHING SET, BYPASS CALL TO QUEUE
+ F HLCOT=0:0 S HLCOT=$O(^UTILITY($J,"PSOHLL",HLCOT)) Q:'HLCOT  S HLINRX=^(HLCOT),HLINRX0=$G(^PSRX(HLINRX,0)) D
+ .S ^UTILITY($J,"PSOHLL",HLCOT)=HLINRX_"^"_+$P(HLINRX0,"^",6)_"^"_$S($G(RXPR(HLINRX)):"P",1:"F")
  .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
  .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))
  .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
  .S HLINGF=0 I $P(^UTILITY($J,"PSOHLL",II),"^",5),$O(^PSRX(HLINRX,"DAI",0)) S HLINGF=1 D
  ..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
  .S $P(^UTILITY($J,"PSOHLL",II),"^",6)=$S($G(HLINGF):1,1:0)
  .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
  .E  S $P(^UTILITY($J,"PSOHLL",II),"^",7)=0
  .S $P(^UTILITY($J,"PSOHLL",II),"^",8)=0 D RPT Q:'$G(^PSRX(HLINRX,"IB"))
+ .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
+ .S HLINGF=0 I $P(^UTILITY($J,"PSOHLL",HLCOT),"^",5),$O(^PSRX(HLINRX,"DAI",0)) S HLINGF=1 D
+ ..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
+ .S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",6)=$S($G(HLINGF):1,1:0)
+ .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
+ .E  S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",7)=0
+ .S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",8)=0 D RPT Q:'$G(^PSRX(HLINRX,"IB"))
  .I $P(^PSRX(HLINRX,"STA"),"^")>0,$P(^("STA"),"^")'=2,'$G(PSODBQ) Q
  .S $P(^UTILITY($J,"PSOHLL",II),"^",8)=1
+ .S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",8)=1
+ ;
 AAA D STRT^PSOHLSG5
 …
+ Q
 RPT ;
  S $P(^UTILITY($J,"PSOHLL",II),"^",9)=$S($G(PSOSUREP)!($G(RXRP(HLINRX))):1,1:0)
  S $P(^UTILITY($J,"PSOHLL",II),"^",10)=+$G(PDUZ)
+ S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",9)=$S($G(PSOSUREP)!($G(RXRP(HLINRX))):1,1:0)
+ S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",10)=+$G(PDUZ)
+ Q
 SETZ ;
 …
  D ^%ZTLOAD
+ Q
+SOMD ;send only mark drugs to external interface and print in vista
+ S HLFLG=0 F HLLP=1:1 S HLRX=$P(PPLHL,",",HLLP) D  Q:$G(HLFLG)
+ .S HLNEXT=$P(PPLHL,",",(HLLP+1)) I HLNEXT=""!(HLNEXT=",") S HLFLG=1
+ .Q:'$G(HLRX)
+ .Q:'$D(^PSRX(HLRX,0))
+ .Q:$P($G(^PSRX(HLRX,"STA")),"^")=4
+ .I $P($G(^PSRX(HLRX,"STA")),"^")>11!('$P(^PSRX(HLRX,0),"^",2)) Q
+ .Q:$G(RXRP(HLRX,"RP"))
+ .S HLRR=$O(^PS(52.5,"B",HLRX,0)) Q:'HLRR  I $G(^PS(52.5,+HLRR,"P"))=1 K HLRR Q
+ .S DRG=+$P($G(^PSRX(HLRX,0)),"^",6) I '$P($G(^PSDRUG(DRG,6)),"^") Q
+ .S HLRXY(HLRX)="" ; VALID RXS
+ I $D(HLRXY) G SOMDQ
+ Q

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLN.m

-              r628
+              r636
+PSOLBLN ;BIR/RTR-NEW PRINTS LABEL ;11/18/92
+ ;;7.0;OUTPATIENT PHARMACY;**16,36,71,107,110,117,135,233**;DEC 1997;Build 8
+PSOLBLN ;BIR/RTR-NEW PRINTS LABEL ; 3/11/07 1:56pm
+ ;;7.0;OUTPATIENT PHARMACY;**16,36,71,107,110,117,135,233,208**;DEC 1997;Build 39
+ ; Modified from FOIA VistA
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External reference to ^PSDRUG supported by DBIA 221
  ;External reference to ^VA(200 supported by DBIA 224
 …
  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:" ")_")"
  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:""))
+ ;
+ I $G(PSOAFYN)="Y" G PSOAFPL1 ;vfah
+ ;
 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)"
  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
 …
 L13 I $G(WARN)'="",'$G(PSOBLALL) I '$G(PSDFNFLG),'$G(PSOLAPPL) D WARN^PSOLBL2
  W @IOF
+ ;
+PSOAFPL1 I $G(PSOAFYN)="Y" D PSOAFP ;vfah
+ ;
 REP I COPIES>0 S SIDE=1 G ST
  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
 …
  .S ^PSRX(RX,"L",IR,0)=NOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_"ROUTING="_$G(MW)_" (BAD ADDRESS)"_"^"_PDUZ
  S ^PSRX(RX,"TYPE")=0 K RXF,IR,FDA,NOW,I,PCOMH(RX)
+PSOAFPL2 I $G(PSOAFYN)="Y" G PSOAFPL3 ;vfah
  I $G(WARN)'="" I $G(PSDFNFLG)!($G(PSOLAPPL)) D ALLWARN^PSOLBLN1
  I $G(WARN)="" I $G(PSDFNFLG)!($G(PSOLAPPL)) D ALL^PSOLBLS
  I $G(PSOBLALL) D:$G(WARN)="" ALL^PSOLBLS D:$G(WARN)'="" ALLWARN^PSOLBLN1
  I '$D(PSSPND),$P(PSOPAR,"^",18) I $G(PSDFNFLG)!($G(PSOLAPPL))!($G(PSOBLALL)) D CHCK2^PSOTRLBL
+PSOAFPL3 ;vfah
  D:$G(PSOBLALL) TRAIL^PSOLBL2
 END ;
  I $D(RXFLX(RX)) S RXFL(RX)=$G(RXFLX(RX)) K RXFLX
+ ;
+ I '$D(REPRINT)&($G(PSOAFYN)="Y") D ^PSODISP ;vfah auto-release
+ ;
  D KILL^PSOLBL2 Q
+ ;
+ Q  ;vfah
+ ;
+PSOAFP ;Patient prescription print starts here;vfah
+ S PSOAFPRV=$P($G(^PSRX(RX,0)),"^",4)
+ S PSDU=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),660)),"^",8) ;vfah sets dispense units
+ I $G(VFASDD)="Y" S $P(^PSRX(RX,"RXFIN"),"^",1)="Y" ;Sets complex order flag in File#52
+ K VFASDD
+ ;
+AFFAX ;
+ I $G(REPRINT)'=1 D
+ .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
+ ..I $D(^DIZ(22900)) D
+ ...S DIC="^DIZ(22900,",DIC(0)="MOZ",X=LZZ
+ ...D ^DIC K DIC
+ ...I +Y'=-1 D
+ ....S PSOAFFXP=X
+ ....S PSOAFFXL=$P(Y,"^",2)
+ ....S ^PSRX(RX,"PRC",LZ,0)=$TR(^PSRX(RX,"PRC",LZ,0),":","+")
+ ....S STOP=1
+ ...I +Y=-1 D
+ ....S ^PSRX(RX,"PRC",LZ,0)=$TR(^PSRX(RX,"PRC",LZ,0),":","-")
+ K STOP,LZ,LZZ
+ I $G(REPRINT)=1 S PSOAFFXP=$G(PSOAFFXR)
+ I $G(PSOAFFXP)>1 G AFPTL
+ ;
+AFPTS I PSOLAP["STAR" D PRNT^PSOAFPTS
+ I PSOLAP["STAR" G AFKILL
+ I PSOLAP["STRL" D PRNT^PSOAFPT1
+ I PSOLAP["STRL" G AFKILL
+ ;
+AFPTL D BEGLP^PSOAFPTL
+ ;
+AFKILL K PSOAFPRV
+ I $G(REPRINT)'=1 D ^%ZISC

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLN2.m

-              r628
+              r636
+PSOLBLN2 ;BHAM ISC/RTR - NEW LABEL TRAILER ;06/06/94
+ ;;7.0;OUTPATIENT PHARMACY;**92,107,110**;DEC 1997
+PSOLBLN2 ;BHAM ISC/RTR - NEW LABEL TRAILER ; 11/12/06 8:02pm
+ ;;7.0;OUTPATIENT PHARMACY;**92,107,110,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  Q:'+$G(RXN)!('$G(PSOTRAIL))!('+$G(DFN))
  I $G(PSOBLALL),$P(PPL,",",PI+1)'="" Q
 …
  .S ^TMP($J,"PSOSUSP",PSSPCNT)="  "_$$ZZ^PSOSUTL(PSSSRX) S PSSPCNT=PSSPCNT+1 K SPNUM,SPDATE,Y
 PRINT S PSOTRDFN=$P(VADM(2),"^"),PSOTRDFN=$S(PSOTRDFN]"":PSOTRDFN,1:"Unavailable") S Y=DT X ^DD("DD") S EDT=Y
  W ?54,VADM(1)_" "_$E($P(VADM(2),"^",2),5,12)_" "_EDT
+ ;W ?54,VADM(1)_" "_$E($P(VADM(2),"^",2),5,12)_" "_EDT ;vfah
  W ! I PRCOPAY,$G(PSOBARS) S X="S",X2=PSOTRDFN,X1=$X W ?54,@PSOBAR1,PSOTRDFN,@PSOBAR0,$C(13) S $X=0
  I PRCOPAY,'$G(PSOBARS) W !!!
  I 'PRCOPAY W !
  I 'PSSUFLG D PRSUS G END
  S (PSNONARR,PSNOADDR,PSNOBOTH)=0 F TTT=1:1 Q:$G(PSNOBOTH)  D
  .W $G(^TMP($J,"PSOMAIL",TTT)) S:'$O(^(TTT)) PSNOADDR=1
  .W ?54,$G(^TMP($J,"PSONARR",TTT)),! S:'$O(^(TTT)) PSNONARR=1
  .I PSNOADDR,PSNONARR S PSNOBOTH=1
+ ;S (PSNONARR,PSNOADDR,PSNOBOTH)=0 F TTT=1:1 Q:$G(PSNOBOTH)  D  ;vfah
+ ;.W $G(^TMP($J,"PSOMAIL",TTT)) S:'$O(^(TTT)) PSNOADDR=1 ;vfah
+ ;.W ?54,$G(^TMP($J,"PSONARR",TTT)),! S:'$O(^(TTT)) PSNONARR=1 ;vfah
+ ;.I PSNOADDR,PSNONARR S PSNOBOTH=1 ;vfah
 END K ^TMP($J,"PSONARR"),^TMP($J,"PSOMAIL"),^TMP($J,"PSOSUSP"),^UTILITY($J,"W")
  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
+ I $P(PSOPAR,"^",31) D BLANK^PSOLBLD W @IOF
+ ;I $P(PSOPAR,"^",31) D BLANK^PSOLBLD W @IOF
+ I $P(PSOPAR,"^",31)="1" D BLANK^PSOLBLD W @IOF ;vfah
+ Q
 PRSUS S (PSNONARR,PSNOADDR,PSNOSUSP,PSNTHREE)=0 F TTT=1:1 Q:$G(PSNTHREE)  D

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLLLI.m

-              r628
+              r636
 PSOLLLI ;BIR/JLC - LASER LABELS INITIALIZATION ;4/25/07 9:00am
  ;;7.0;OUTPATIENT PHARMACY;**120,157,189,161,244,200,206**;DEC 1997;Build 39
+PSOLLLI ;BIR/JLC - LASER LABELS INITIALIZATION ;10 Oct 2006  4:56 PM
+ ;;7.0;OUTPATIENT PHARMACY;**120,157,189,161,244,200**;DEC 1997;Build 7
+ ;
  ;DBIAs PSDRUG-221, PS(55-2228, SC-10040, IBARX-125, PSXSRP-2201, %ZIS-3435, DPT-3097, ^TMP($J,"PSNPPIO"-3794
 …
  S MAILCOM=""
  S X=$G(^PS(55,DFN,0)),PSCAP=$P(X,"^",2),PS55=$P(X,"^",3),PS55X=$P(X,"^",5)
  I PS55X]"",PS55>1,PS55X<DT S PS55=0
+ I PS55X]"",PS55>1,PS55X<DT S PS55=1
  S:MW="M" MW=$S((PS55=1!(PS55=4)):"R",1:MW)
  S MAILCOM=$P($G(^PS(59,PSOSITE,9)),"^")
 …
  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
  S (X,PSOFLAST)=$G(PSOLASTF) I X?1N.E D ^%DT X ^DD("DD") S PSOFLAST=Y
  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
+ 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
  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"
  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)

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMPO.m

-              r628
+              r636
+PSOLMPO ;ISC-BHAM/LC - pending orders ; 13-MAR-1995
+ ;;7.0;OUTPATIENT PHARMACY;**46**;DEC 1997
+PSOLMPO ;ISC-BHAM/LC - pending orders ; 11/3/06 9:58pm
+ ;;7.0;OUTPATIENT PHARMACY;**46,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
 EN ; -- main entry point for PSO LM PENDING ORDER
+ S PSOLMC=0 D EN^VALM("PSO LM PENDING ORDER") K PSOLMC
+ I $G(PSOAFYN)'="Y" S PSOLMC=0 D EN^VALM("PSO LM PENDING ORDER") K PSOLMCP ;vfam
+ I $G(PSOAFYN)="Y" D ACP^PSOORNEW ;vfam
+ Q
+ ;

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLSET.m

-              r628
+              r636
+PSOLSET ;BHAM ISC/SAB - site parameter set up ;12/03/92
+VERS ;;7.0;OUTPATIENT PHARMACY;**10,22,32,40,120,247**;DEC 1997;Build 18
+PSOLSET ;BHAM ISC/SAB - site parameter set up ;3/13/07  19:50
+VERS ;;7.0;OUTPATIENT PHARMACY;**10,22,32,40,120,247,208**;DEC 1997;Build 39
+ ; Modified from FOIA VistA
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;Reference to ^PS(59.7 supported by DBIA 694
  ;Reference to ^PSX(550 supported by DBIA 2230
 …
  .S %ZIS="MNQ",%ZIS("A")="Select PROFILE PRINTER: " S:$G(PSOCLBL)&($D(PSOPROP)) %ZIS("B")=PSOPROP
  .D ^%ZIS K %ZIS,IO("Q"),IOP Q:POP  S PSOPROP=ION D ^%ZISC
+LBL S %ZIS="MNQ",%ZIS("A")="Select LABEL PRINTER: " S:$G(PSOCLBL)&($D(PSOLAP))!($G(SUSPT)) %ZIS("B")=$S($G(SUSPT):PSLION,1:PSOLAP)
+ S PSOAFIN=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",1) ;vfah
+ S PSOAFPFX=$S(PSOAFIN="Y":"Select LABEL PRINTER or FAX DEVICE: ",1:"Select LABEL PRINT: ") ;vfah
+LBL S %ZIS="MNQ",%ZIS("A")=PSOAFPFX S:$G(PSOCLBL)&($D(PSOLAP))!($G(SUSPT)) %ZIS("B")=$S($G(SUSPT):PSLION,1:PSOLAP) ;vfah
  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))
  N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
  S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19),PSOIOS=IOS D ^%ZISC
 LASK I $G(PSOPIOST),$D(^%ZIS(2,PSOPIOST,55,"B","LL")) G EXIT
+ ;
+ ;vfah AutoFinish fax additions begin here
+ K PSOAFFXP,PSOAFFXL
+ I PSOLAP["FAX" D
+ .S PSOAFFXP="",PSOAFFXL="",PSOAFFXR=""
+ .S PSOLAP="AFFAX" D
+ ..S PSOION="" S PSOION=$O(^%ZIS(1,"B",PSOLAP,PSOION))
+ ..I $D(^DIZ(22900)) D
+ ...S DIC="^DIZ(22900,",DIC(0)="AEQMZ",DIC("A")="SEND FAX TO: "
+ ...D ^DIC K DIC
+ ...I Y=-1 W !,"Invalid selection" G LBL
+ ...S PSOAFFXL=$P(Y,"^",2)
+ ...S PSOAFFXP=$P($G(^DIZ(22900,+Y,3)),"^",3)
+ ...S PSOAFFXR=PSOAFFXP
+ ...I PSOAFFXL=""!(PSOAFFXP="") G LBL
+ I $G(PSOAFFXP)&(PSOLAP="AFFAX")'="" G EXIT
+ ;vfah Autofinish fax additions end here
+ ;
  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
 P2 S IOP=$G(PSOLAP) D ^%ZIS K IOP I POP W $C(7),!?5,"Printer is busy.",! G LASK

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOMAUEX.m

-              r628
+              r636
 PSOMAUEX ;BIR/SAB-Auto expire of prescriptions ; 10/10/07 11:17am
  ;;7.0;OUTPATIENT PHARMACY;**40,73,139,148,257**;DEC 1997;Build 19
  ;;
+PSOMAUEX ;BIR/SAB-Auto expire of prescriptions ;10/10/96
+ ;;7.0;OUTPATIENT PHARMACY;**40,73,139,148**;DEC 1997
+ ;External reference to ^PS(59.7 is supported by DBIA 694
  ;External reference to STATUS^ORQOR2 is supported by DBIA 3458
- ;External reference to ^PS(59.7 is supported by DBIA 694
- ;External reference to LOCK1^ORX2 and UNLK1^ORX2 are supported by DBIA 867
+ ;
  I '$G(DT) S DT=$$DT^XLFDT
 …
  W !,"*******************************************************************************"
  W !!
  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))
  I 'ZZDT D  Q  ; V7.0 inst. dt not found, quit this job
+ 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))
+ I 'ZZIDT D  Q  ; V7.0 inst. dt not found, quit this job
  .W !!!,"***** Outpatient installation date was not found, *****"
  .W !,"***** therefore this job cannot be run!!!!!       *****",!!
 …
  ; - Ask for START DATE
  K %DT S %DT(0)=-DT,%DT="AEP",%DT("A")="Start Date: "
  S %DT("B")=$$FMTE^XLFDT($$FMADD^XLFDT(ZZDT\1,-121))
+ S %DT("B")=$$FMTE^XLFDT($$FMADD^XLFDT(ZZIDT\1-121))
  W ! D ^%DT I Y<0!($D(DTOUT)) Q
  S ZZDT=Y
+ S ZZIDT=Y
+ ;
  K %DT D NOW^%DTC S %DT="RAEX",%DT(0)=%,%DT("A")="Select the Date/Time to queue this job: "
  W ! D ^%DT K %DT I $D(DTOUT)!(Y<0) W !!!?10,"Job not queued!" Q
  S ZTDTH=$G(Y),ZTSAVE("ZZDT")="",ZTIO="",ZTRTN="EN^PSOMAUEX",ZTDESC="Auto expire of Rxs "
+ S ZTDTH=$G(Y),ZTSAVE("ZZIDT")="",ZTIO="",ZTRTN="EN^PSOMAUEX",ZTDESC="Auto expire of Rxs "
  D ^%ZTLOAD
  W:$D(ZTSK) !!,"Task Queued !",!
+ Q
+EN ;
+ N PSOSVDT
+ S PSOSVDT=""
+ S X1=DT,X2=-1 D C^%DTC S CDT=X  ; setting the end date to to today-1
+ F  S ZZDT=$O(^PSRX("AG",ZZDT)) Q:'ZZDT!(ZZDT>CDT)  D EN1 S PSOSVDT=ZZDT
+ I PSOSVDT>($P(^PS(59.7,1,49.99),"^",8)) D
+ .S DIE=59.7,DA=1,DR="49.95///"_PSOSVDT D ^DIE K DIE,DA,DR
+ K PSOEXRX,PSOEXSTA,ZZDT,CDT,ORN,PIFN,PSUSD,PRFDT,PDA,PSDTEST S:$D(ZTQUEUED) ZTREQ="@"
+EN S X1=ZZIDT,X2=-121 D C^%DTC S ZZDT=X  ;setting the start date to 120 days before the install date
+ S X1=DT,X2=-1 D C^%DTC S CDT=X  ; setting the end date to todate-1
+ F  S ZZDT=$O(^PSRX("AG",ZZDT)) Q:'ZZDT!(ZZDT>CDT)  D EN1
+ K PSOEXRX,PSOEXSTA,ZZIDT,ZZDT,CDT,ORN,PIFN,PSUSD,PRFDT,PDA,PSDTEST S:$D(ZTQUEUED) ZTREQ="@"
+ Q
 EN1 ;
 …
+ Q
 EN2 ;
-  N CPRSDC,CPRSSTA
- S CPRSDC=",1,7,12,13,"
- S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2),CPRSSTA=""
- I ORN S CPRSSTA=+$$STATUS^ORQOR2(ORN)
- S DA=PSOEXRX K CMOP D ^PSOCMOPA
  S DA=$O(^PS(52.5,"B",PSOEXRX,0))
  I DA,$P($G(^PS(52.5,DA,0)),"^",2),$P($G(^(0)),"^",3) S DIK="^PS(52.5," D ^DIK K DIK
 …
  I $G(^PSRX(PSOEXRX,"H"))]"" K:$P(^PSRX(PSOEXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOEXRX,"H"),"^"),PSOEXRX) S ^PSRX(PSOEXRX,"H")=""
  S PSOEXSTA=$P($G(^PSRX(PSOEXRX,"STA")),"^")
+ I PSOEXSTA=11 D
+ .S $P(^PSRX(PSOEXRX,0),"^",19)=1
+ .S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2)
+ .I ORN,+$$STATUS^ORQOR2(ORN)=6 D
+ ..D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired")
+ I (PSOEXSTA="")!(PSOEXSTA>9) Q
+ ;
+ I PSOEXSTA=11 S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) I ORN I CPRSDC'[(","_CPRSSTA_",") D
+ .S $P(^PSRX(PSOEXRX,0),"^",19)=1
+ .D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired")
+ ;
+ I PSOEXSTA=13 D  Q
+ .I 'ORN D EN^PSOHDR("PRES",PSOEXRX)
+ ;
+ I PSOEXSTA>9&(PSOEXSTA'=16) Q
+ ;
+ I +$P($G(^PSRX(PSOEXRX,2)),"^",6),+$P($G(^(2)),"^",6)<DT D
+ ;get only those Rxs whoes status lies within 0 & 9
+ I PSOEXSTA?1N,+$P($G(^PSRX(PSOEXRX,2)),"^",6),+$P($G(^(2)),"^",6)<DT D
  .S $P(^PSRX(PSOEXRX,"STA"),"^")=11
+ .I $P($G(^PSRX(PSOEXRX,"OR1")),"^",2) D
+ ..D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription past expiration date")
  .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)),"^")
  .D REVERSE^PSOBPSU1(PSOEXRX,+PSUSD,"DE",5,"RX EXPIRED")
  .I $G(PSUSD),'$P($G(^PSRX(PSOEXRX,1,PSUSD,0)),"^",18) D EN3
- .S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) I 'ORN D EN^PSOHDR("PRES",PSOEXRX) Q
- .;If CPRS side already DC'd or expired, just send the expiration to the HDR
- .I CPRSDC[(","_CPRSSTA_",") D EN^PSOHDR("PRES",PSOEXRX) Q
- .S $P(^PSRX(PSOEXRX,0),"^",19)=1
- .D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription past expiration date")
+ Q
 EN3 ;
  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
  Q:PSDTEST
+ I $G(CMOP(CMOP("L")))="",".L.X."[("."_$G(CMOP("S"))_".") S PSDTEST=1
+ N PSOORL
+ S PSOORL=$$LOCK1^ORX2(ORN) S:'PSOORL PSDTEST=1 I PSOORL D UNLK1^ORX2(ORN)
+ N PDAQ,PDA0
+ S PDAQ=0
+ F PDA=0:0 S PDA=$O(^PSRX(PSOEXRX,4,PDA)) Q:'PDA  D
+ .S PDA0=$G(^PSRX(PSOEXRX,4,PDA,0)) Q:PDA0=""
+ .I $P(PDA0,"^",3)=PSUSD S PSDTEST=1
+ S DA=PSOEXRX K CMOP D ^PSOCMOPA
+ I $G(CMOP(CMOP("L")))="",$G(CMOP("S"))="L" S PSDTEST=1
 ENX I 'PSDTEST K ^PSRX(PSOEXRX,1,PSUSD),^PSRX("AD",PRFDT,PSOEXRX,PSUSD),^PSRX(PSOEXRX,1,"B",PRFDT,PSUSD) D NSET
+ Q

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSON52.m

-              r628
+              r636
 PSON52 ;BIR/DSD - files new entries in prescription file ;08/09/93
+ ;;7.0;OUTPATIENT PHARMACY;**1,16,23,27,32,46,71,111,124,117,131,139,157,143,219,148,239,201,268,260**;DEC 1997;Build 84
+ ;;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
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External reference ^PS(55 supported by DBIA 2228
  ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
  ;External reference to ^XUSEC supported by DBIA 10076
  ;External reference SWSTAT^IBBAPI supported by DBIA 4663
- ;External reference SAVNDC^PSSNDCUT supported by DBIA 4707
 EN(PSOX) ;Entry Point
 START ;
 …
  ;Next line, set SC question based on Copay status?
 IBQ ;I $G(PSOBILL)=2 S ^PSRX(PSOX("IRXN"),"IBQ")=$S($G(PSOX("NEWCOPAY")):0,1:1)
+ I $G(PSOAFYN)="Y" S PSOSCP="" ;vfah
  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"))
  I PSOSCP<50&($TR(PSOSCFLD,"^")'="")&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1) D
 …
+ ;
  ; - Calling ECME for claims generation and transmission / REJECT handling
+ N ACTION,PSOERX
+ S PSOERX=PSOX("IRXN")
+ I $$SUBMIT^PSOBPSUT(PSOERX,0) D  I ACTION="Q"!(ACTION="^") Q
+ . S ACTION="" D ECMESND^PSOBPSU1(PSOERX,0,PSOX("FILL DATE"),"OF")
+ . I $$FIND^PSOREJUT(PSOERX,0) D
+ . . S ACTION=$$HDLG^PSOREJU1(PSOERX,0,"79,88","OF","IOQ","I")
+ . I $$STATUS^PSOBPSUT(PSOERX,0)="E PAYABLE" D
+ . . D SAVNDC^PSSNDCUT(+$$GET1^DIQ(52,PSOERX,6,"I"),$G(PSOSITE),$$GETNDC^PSONDCUT(PSOERX,0))
+ N ACTION
+ I $$SUBMIT^PSOBPSUT(PSOX("IRXN"),0) D  I ACTION="Q"!(ACTION="^") Q
+ . S ACTION="" D ECMESND^PSOBPSU1(PSOX("IRXN"),0,PSOX("FILL DATE"),"OF")
+ . I $$FIND^PSOREJUT(PSOX("IRXN"),0) D
+ . . S ACTION=$$HDLG^PSOREJU1(PSOX("IRXN"),0,"79,88","OF","IOQ","I")
+ ;
 FINISHP ;

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEW.m

-              r628
+              r636
+PSONEW ;BIR/SAB-new rx order main driver ;07/26/96
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,94,130,268**;DEC 1997;Build 9
+PSONEW ;BIR/SAB-new rx order main driver ; 11/5/06 6:35pm
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,94,130,268,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External references L and UL^PSSLOCK supported by DBIA 2789
  ;External reference to ^VA(200 supported by DBIA 224
 …
 COUN ;patient counseling
  G:$G(PSORX("EDIT"))&('$G(PSOSIGFL)) NOORX K DIR,DUOUT,DTOUT,DIRUT
+ S DIR("B")="NO",DIR(0)="52,41" D ^DIR S PSOCOU=$S(Y:Y,1:0)
+ I $G(PSOAFYN)'="Y" S DIR("B")="NO",DIR(0)="52,41" D ^DIR S PSOCOU=$S(Y:Y,1:0) ;vfam
+ I $G(PSOAFYN)="Y" S PSOCOU=0 ;vfam No Patient Counseling by AutoFinihs
  I $D(DIRUT)!('PSOCOU) S PSOCOUU=0 D:'$G(SPEED) PRONTE Q
  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)
 PRONTE K PSONOTE,DIR,DIRUT,DUOUT
  I $T(MAIN^TIUEDIT)]"",'$G(SPEED) D  K DIR,DIRUT,DUOUT
+ .S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to enter a Progress Note",DIR("A",1)="" D ^DIR K DIR
+ .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
+ .I $G(PSOAFYN)="Y" S Y="0" ;vfam No Progress Notes in AutoFinish
  .S PSONOTE=+Y Q  ;I 'Y!($D(DIRUT)) Q
 NOORX K X,Y,DIR,DUOUT,DTOUT,DIRUT

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEWF.m

-              r628
+              r636
 PSONEWF ;BIR/RTR - Copay finish questions ;07/26/96
+ ;;7.0;OUTPATIENT PHARMACY;**71,157,143,219,226,239**;DEC 1997
+ ;;7.0;OUTPATIENT PHARMACY;**71,157,143,219,226,239,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External reference VADPT supported by DBIA 10061
 START ;
+ I $G(PSOAFYN)="Y" Q  ; vfam
  N PSOPENIB,PSOSCOTH,PSOSCOTX,PSOMESFI
  S PSOPENIB=$S($G(ORD):$G(^PS(52.41,+$G(ORD),"IBQ")),1:"")

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORAL.m

-              r628
+              r636
 PSOORAL ;BHAM-ISC/SAB - activity log list ; 28-APR-1995
  ;;7.0;OUTPATIENT PHARMACY;**148,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**148**;DEC 1997
 EN ; -- main entry point for PSO LM ACTIVITY LOGS
  D EN^VALM("PSO LM ACTIVITY LOGS")
 …
+ ;
 INIT ; -- init variables and list array
  I $G(PS)="VIEW"!($G(PS)="DELETE")!($G(PS)="REJECT")!($G(PS)="REJECTMP") D
+ I $G(PS)="VIEW"!($G(PS)="DELETE")!($G(PS)="REJECT") D
  .I ST<12,$P(RX2,"^",6)<DT S ST=11
  .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)_")"

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORAL1.m

-              r628
+              r636
 PSOORAL1 ;BHAM ISC/SAB - Build Listman activity logs ; 12/4/07 12:25pm
  ;;7.0;OUTPATIENT PHARMACY;**71,156,148,247,240**;DEC 1997;Build 5
+PSOORAL1 ;BHAM ISC/SAB - Build Listman activity logs ;11/16/92 13:11
+ ;;7.0;OUTPATIENT PHARMACY;**71,156,148,247**;DEC 1997;Build 18
  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))
  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"
 …
  .I $P(P1,"^",5)]"" N PSOACBRK,PSOACBRV D
  ..S PSOACBRV=$P(P1,"^",5)
+ ..;PSO*7*240 Use fileman for parsing
+ ..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))
+ ..I $L(PSOACBRV)<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_PSOACBRV Q
+ ..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
+ ..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
  .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)
  .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
  ..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)
  K MIG,SG,I,^UTILITY($J,"W"),DIWF,DIWL,DIWR
+ K MIG,SG,I
+ Q
 LBL ;label log
 …
  .I $P(P1,"^",5)]"" D
  ..S PSOACBRV=$P(P1,"^",5)
+ ..;PSO*7*240 Use fileman for parsing
+ ..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))
+ ..I $L(PSOACBRV)<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_PSOACBRV Q
+ ..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
+ ..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
  .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
  ..F SG=1:1:$L(MIG) D
 …
  ...S:$P(MIG," ",SG)'="" ^TMP("PSOAL",$J,IEN,0)=$G(^TMP("PSOAL",$J,IEN,0))_" "_$P(MIG," ",SG)
  D DISPREJ
- K ^UTILITY($J,"W"),DIWR,DIWF,DIWL
+ Q
+ ;

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED1.m

-              r628
+              r636
 PSOORED1 ;ISC-BHAM/SAB - edit orders from backdoor ;5/10/07 8:25am
  ;;7.0;OUTPATIENT PHARMACY;**5,23,46,78,114,117,131,146,223,148,244,249,268,206**;DEC 1997;Build 39
+PSOORED1 ;ISC-BHAM/SAB - edit orders from backdoor ;6/30/06 10:21am
+ ;;7.0;OUTPATIENT PHARMACY;**5,23,46,78,114,117,131,146,223,148,244,249,268**;DEC 1997;Build 9
  ;External reference ^PS(55 supported by DBIA 2228
  ;External reference ^PS(50.7 supported by DBIA 2223
 …
  .S PSOX1=PTRF,PSOX=$S(PSOX1=11:11,1:PSOX1),PSOX=$S('PSOX:0,PSDAYS=90:3,1:PSOX)
  .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)
  I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) S PSORENW("# OF REFILLS")=0
+ I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") S PSORENW("# OF REFILLS")=0
  K PSDY,PSDY1,PTRF,PSOX,PSOX1,PSDAYS,CS
+ Q

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED2.m

-              r628
+              r636
 PSOORED2 ;ISC-BHAM/SAB-edit orders from backdoor con't ;03/06/95 10:24
  ;;7.0;OUTPATIENT PHARMACY;**2,51,46,78,102,114,117,133,159,148,247,260,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**2,51,46,78,102,114,117,133,159,148,247,260**;DEC 1997;Build 84
  ;Reference to $$DIVNCPDP^BPSBUTL supported by IA 4719
  ;Reference to $$ECMEON^BPSUTIL supported by IA 4410
 …
  D GETS^DIQ(52.1,DA_","_DA(1)_",",".01;1;1.1;8;11;81","I","FLDS")
  S:$D(^PSRX(DA(1),1,DA,0)) PSORXED("RX1")=^PSRX(DA(1),1,DA,0),(RFED,RFL)=DA
- 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
  D ^DIE S QUIT=$D(Y) K FEV,RFN,RFM,X,Y,DR
  I '$G(DA) D REVERSE^PSOBPSU1(PSORXED("IRXN"),RFL,"DE",5) K CMRL,RFED D:$D(PSORX("PSOL"))&($G(DI)=.01) RFD Q
  I 'CMRL,'QUIT S DR="1;1.2:5;8" D ^DIE S QUIT=$D(Y)
 RFE I '$D(^PSRX(PSORXED("IRXN"),1,RFL)) Q
+ I '$D(^PSRX(PSORXED("IRXN"),1,RFL)) Q
  I 'QUIT,$$STATUS^PSOBPSUT(PSORXED("IRXN"),RFL)'="" D
  . S NDC=$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL)
 …
  . . D ECMESND^PSOBPSU1(RX,RFL,,"ED",$$GETNDC^PSONDCUT(RX,RFL),,$S($P(CHANGED,"^",2):"REFILL DIVISION CHANGED",1:"REFILL EDITED"),,+$G(CHGNDC))
  . . ;- Checking/Handling DUR/79 Rejects
  . . I $$FIND^PSOREJUT(RX,RFL) S X=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","Q")
+ . . I $$FIND^PSOREJUT(RX,RFL) S X=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","I")
  K DIE,CMRL,DA,DR
+ Q

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED6.m

-              r628
+              r636
 PSOORED6 ;BIR/SAB - edit orders from backdoor ;03/06/96
  ;;7.0;OUTPATIENT PHARMACY;**78,104,117,133,143,219,148,247,268,260,269**;DEC 1997;Build 4
+ ;;7.0;OUTPATIENT PHARMACY;**78,104,117,133,143,219,148,247,268,260**;DEC 1997;Build 84
  ;External reference to ^PSDRUG supported by DBIA 221
  ;External reference to ^PS(50.7 supported by DBIA 2223
 …
  S DIC("B")=$P(^PS(50.7,PSOI,0),"^"),DIC="^PS(50.7,",DIC(0)="AEMQZ"
  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  "
+ S DIC("S")=DIC("S")_"I $P($G(^PSDRUG(PSOL,2)),U,3)[""O"",'$G(^(""I""))!($G(^(""I""))'<DT) S PSOF=1"
+ ;BHW;PSO*7*269;Modify ^DIC call to call MIX^DIC to use only the B and C Cross-References.
+ S D="B^C" D MIX^DIC1 I "^"[X S PSORXED("DFLG")=1 Q
+ 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
  G:Y<1 PSOI Q:PSOI=+Y
  S PSODRUG("OI")=+Y,PSODRUG("OIN")=Y(0,0) K DIC

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED7.m

-              r628
+              r636
 PSOORED7 ;ISC-BHAM/MFR-edit orders from backdoor con't ;03/06/95 10:24
  ;;7.0;OUTPATIENT PHARMACY;**148,247,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**148,247**;DEC 1997;Build 18
  ;called from psooredt. cmop edit checks.
  ;Reference to file #50 supported by IA 221
 …
  . . D ECMESND^PSOBPSU1(RX,0,,"ED",$$GETNDC^PSONDCUT(RX,0),,$S($P(CHANGED,"^",2):"RX DIVISION CHANGED",1:"RX EDITED"),,+$G(CHGNDC))
  . . ;- Checking/Handling DUR/79 Rejects
  . . I $$FIND^PSOREJUT(RX,0) S X=$$HDLG^PSOREJU1(RX,0,"79,88","ED","IOQ","Q")
+ . . I $$FIND^PSOREJUT(RX,0) S X=$$HDLG^PSOREJU1(RX,0,"79,88","ED","IOQ","I")
+ Q
+ ;
 …
  I $$DIVNCPDP^BPSBUTL(+$G(PRIOR(52,RX_",",20,"I")))'=$$DIVNCPDP^BPSBUTL(+$G(SAVED(52,RX_",",20,"I"))) S CHANGED="1^1"
  Q CHANGED
- ;;
-NDCDAWDE(ST,FLN,RXN) ; allow edit of NDC & DAW for DC'd/expired ECME RXs
- ;;  input: (r) ST  - the Rx status code
- ;;         (r) FLN - field number selected for editing
- ;;         (r) RXN - prescription #
- ;; output: VALMSG for inappropriate field selection or use
- ;;         PSODRUG & RSORXED arrays updated if edited
- Q:$G(ST)=""!($G(FLN)="")!($G(RXN)="")
- I '((ST=11)!(ST=12)) S VALMSG=("Invalid selection!") Q
- I '((FLN=2)!(FLN=20)!(FLN=21)) S VALMSG=("Invalid selection!") Q
- I $$STATUS^PSOBPSUT(RXN,$$LSTRFL^PSOBPSU1(RXN))="" S VALMSG=("Invalid selection!") Q
+ ;
- ; edit NDCs
- I FLN=2 D  Q
- .N NDC
- .S NDC=$$GETNDC^PSONDCUT(RXN,0)
- .D NDCEDT^PSONDCUT(RXN,"",$G(DRG),$G(PSOSITE),.NDC)
- .I $G(NDC)="^" Q
- .S (PSODRUG("NDC"),PSORXED("FLD",27))=NDC
- ;;
- ; edit refill NDCs/DAWs
- I FLN=20 D  Q
- .I $$LSTRFL^PSOBPSU1(RXN)=0 S VALMSG="Invalid selection!" Q
- .D REF^PSOORED2
- ;;
- ; edit DAW
- I FLN=21 D  Q
- .N DAW
- .D EDTDAW^PSODAWUT(RXN,0,.DAW)
- .I $G(DAW)="^" Q
- .S (PSODRUG("DAW"),PSORXED("FLD",81))=DAW
+ Q
- ;;

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOOREDT.m

-              r628
+              r636
+PSOOREDT ;BIR/SAB - edit orders from backdoor ;03/06/96
+ ;;7.0;OUTPATIENT PHARMACY;**4,20,27,37,57,46,78,102,104,119,143,148,260,281**;DEC 1997;Build 41
+PSOOREDT ;BIR/SAB - edit orders from backdoor ;1/27/07  13:22
+ ;;7.0;OUTPATIENT PHARMACY;**4,20,27,37,57,46,78,102,104,119,143,148,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
  ;External reference to ^PSDRUG supported by DBIA 221
  ;External reference to PSSLOCK supported by DBIA 2789
 …
+ Q
+ ;
+EDT ; Rx Edit (Backdoor)
+ K NCPDPFLG
+EDT S NCPDPFLG=0
  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)
  S (RX0,PSORXED("RX0"))=^PSRX($P(PSOLST(ORN),"^",2),0),PSORXED("RX2")=$G(^(2)),PSORXED("RX3")=$G(^(3)),PSOSIG=$P(^("SIG"),"^")
 …
  .D:'$G(CHK) POP^PSOSIGNO(DA),CHK Q:$G(PSORXED("DFLG"))
  .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"
- .I $G(ST)=11!($G(ST)=12) D NDCDAWDE^PSOORED7(ST,FLN,$G(RXN)) Q
  .I FLN=20,'$G(REF) S VALMSG="There is no Refill Data to be edited." Q
  .S DR=$P(FDR,"^",FLN) I DR="RF" D REF^PSOORED2 Q
  .I DR="PSOCOU" D PSOCOU^PSOORED6 Q
  .I FLN=2,'$P(PSOPAR,"^",3),$$RXRLDT^PSOBPSUT(RXN,0),$$STATUS^PSOBPSUT(RXN,0)'="" D  Q
+ .I FLN=2,'$P(PSOPAR,"^",3) D  Q
  ..N NDC D NDC^PSODRG(RXN,0,,.NDC) I $G(NDC)="^"!($G(NDC)="") Q
  ..S (PSODRUG("NDC"),PSORXED("FLD",27))=NDC
 …
+ ;
  I $P(^PSRX(PSORXED("IRXN"),"STA"),"^")=14!($P(^("STA"),"^")=15) S PSORXED("DFLG")=1 S VALMSG="Discontinued prescriptions cannot be edited." Q
+ ;
+ S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
+ D ^DIC K DIC ;vfah
+ S PSOZAF=+Y ;vfah
+ 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
+ ;
  I $P(^PSRX(PSORXED("IRXN"),"STA"),"^")=16 S PSORXED("DFLG")=1 S VALMSG="Prescriptions on Provider Hold cannot be edited." Q
 CHKX K PSPOP,DIR,DTOUT,DUOUT,Y,X Q

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI1.m

-              r628
+              r636
+PSOORFI1 ;BIR/SAB - finish OP orders from OE/RR continued ;5/23/05 2:11pm
+ ;;7.0;OUTPATIENT PHARMACY;**7,15,23,27,32,44,51,46,71,90,108,131,152,186,210,222,258,260**;DEC 1997;Build 84
+PSOORFI1 ;BIR/SAB - finish OP orders from OE/RR continued ;1/27/07  13:24
+ ;;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
+ ; Modified from FOIA VISTA,
+ ; GPL Copyright (C) 2007 WorldVistA
  ;Ref. ^PS(50.7 supp. DBIA 2223
  ;Ref. ^PSDRUG( supp. DBIA 221
 …
  S (OI,PSODRUG("OI"))=$P(OR0,"^",8),PSODRUG("OIN")=$P(^PS(50.7,$P(OR0,"^",8),0),"^"),OID=$P(OR0,"^",9)
  I $P($G(OR0),"^",9) S POERR=1,DREN=$P(OR0,"^",9) D DRG^PSOORDRG K POERR G DRG
+ I '$P(OR0,"^",9)&($G(PSOAFYN)="Y") D DISPD^PSOAFIN G DSPL ;vfah 060924
  I '$P(OR0,"^",9) D DREN^PSOORNW2
 DRG I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),"CLOZ1")),"^")="PSOCLO1" D CLOZ^PSOORFI2
 …
  . I $G(PSOMAX) S PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11)) Q
  .S PSONEW("# OF REFILLS")=+$P(OR0,"^",11)
  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:" (  )")_": "
+ 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)
  S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_$S($D(CLOZPAT):+$G(PSONEW("QTY")),1:$P(OR0,"^",10))
  I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),5)),"^")]"" D
 …
  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
  S PSOACT=$S($D(^XUSEC("PSORPH",DUZ)):"DEF",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"")
- ; - PSOACTOV is used to force the Pending Order to be Read-Only (no updates) even if invoked by a Pharmacist
- I $G(PSOACTOV) S PSOACT=""
  D:'$G(ACP) EN^PSOLMPO S:$G(ACP) VALMBCK="Q" D:$G(PKI1)=2 DCP^PSOPKIV1
+ Q
 POST ;post patient selection
+ D POST^PSOORFI2 Q
+ I $G(PSOAFYN)'="Y" D POST^PSOORFI2 Q  ;vfah
+ I $G(PSOAFYN)="Y" Q  ;vfah
 SIG ;displays possible sig
  D SIG^PSOORFI2 Q

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI2.m

-              r628
+              r636
+PSOORFI2 ;BIR/BHW-finish cprs orders cont. ;07/29/96
+ ;;7.0;OUTPATIENT PHARMACY;**7,15,23,27,46,130,146,177,222**;DEC 1997;Build 12
+ ;External reference ^YSCL(603.01 supported by DBIA 2697
+ ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
+PSOORFI2 ;BIR/BHW-finish cprs orders cont. ;1/27/07  13:25
+ ;;7.0;OUTPATIENT PHARMACY;**7,15,23,27,46,130,146,177,222,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; GPL Copyright (C) 2007 WorldVistA
+ ;Ext ref ^YSCL(603.01 supported by DBIA 2697
+ ;Ext refs PSOL and PSOUL^PSSLOCK supported by DBIA 2789
 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
 HELP ;
 …
  .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
+ Q
+PROFILE ;display med profile
+ S MEDA=3 ;3=question asked already
+ 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)
+ I Y S MEDP=1
+PROFILE ;
+ S MEDA=3
+ 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)
+ I $G(PSOAFYN)'="Y" I Y S MEDP=1
+ I $G(PSOAFYN)="Y" K MEDP
  K DIR,DUOUT,DIRUT,DTOUT
+ Q
 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
  N VALMCNT W ! K DIR,DUOUT,DIROUT,DTOUT,PSOELSE I '$G(PSOERR("DEAD")) S PSOELSE=1 D  Q:$D(DIRUT)
+ I $G(PSOAFYN)'="Y" N VALMCNT W ! K DIR,DUOUT,DIROUT,DTOUT,PSOELSE I '$G(PSOERR("DEAD")) S PSOELSE=1 D  Q:$D(DIRUT)
  .D NOOR^PSOCAN4 Q:$D(DIRUT)
  .S DIR("A")="Comments",DIR(0)="F^10:75",DIR("B")="Per Pharmacy Request" D ^DIR K DIR
+ I $G(PSOAFYN)="Y" N VALMCNT K DIR,DUOUT,DIROUT,DTOUT,PSOELSE I '$G(PSOERR("DEAD")) S PSOELSE=1 D  Q:$D(DIRUT)  ;vfah
+ .D NOOR^PSOCAN4 Q:$D(DIRUT)  ;vfah
+ .S Y="Rx AutoFinish" ;vfah
+ I $G(PSOAFYN)'="Y" S PSOELSE="1"
  I '$G(PSOELSE) K PSOELSE S PSONOOR="A" G DE
  K PSOELSE I $D(DIRUT) K DIRUT,DUOUT,DTOUT,Y Q
  S ACOM=Y
+DE Q:'$D(^PS(52.41,ORD,0))
+DE I $G(PSOAFYN)="Y" Q
+ I $G(PSOAFYN)'="Y" Q:'$D(^PS(52.41,ORD,0))
  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)
  S $P(^PS(52.41,ORD,0),"^",3)="DC",POERR("PLACER")=$P(^(0),"^"),POERR("STAT")="OC"
 …
  S Y=-1 Q
+ ;
 RF ;process refill request from CPRS
+RF ;
  S PSOREF("IRXN")=$P(OR0,"^",19) D PSOL^PSSLOCK($P(OR0,"^",19)) I '$G(PSOMSG) D  D PAUSE^VALM1 K PSOREF,PSOMSG Q
  .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P(PSOMSG,"^",2),! Q
 …
  S PSONEW("DAYS SUPPLY")=$P(^PSRX(PSOREF("IRXN"),0),"^",8),PSONEW("# OF REFILLS")=$P(^(0),"^",9) D FULL^VALM1
  W !!,"Processing Refill Request for Rx "_$P(^PSRX(PSOREF("IRXN"),0),"^")
- ;S:$G(PSOREQFD)]"" PSORX("FILL DATE")=PSOREQFD
  D FILLDT^PSODIR2(.PSOREF) I PSOREF("DFLG") S VALMBCK="R" G END
- ;S:$G(PSORX("FILL DATE"))]"" PSOREQFD=PSORX("FILL DATE")
+ ;
- ;S:$G(PSOREQMP)]"" PSORX(" METHOD OF PICK-UP")=PSOREQMP
  S PSORX("MAIL/WINDOW")=$S($P(OR0,"^",17)="M":"MAIL",1:"WINDOW") D MW^PSODIR2(.PSOREF) I PSOREF("DFLG") S VALMBCK="R" G END
- ;S:$G(PSORX("METHOD OF PICK-UP"))]"" PSOREQMP=PSORX("METHOD OF PICK-UP")
  S:'$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0
  D ^PSOREF0
 …
 KPRIZ K PSOQUIT,POERR("QFLG")
+ Q
 INST ;Select Institution
+INST ;
  I '$G(PSOSITE) D ^PSOLSET I '$G(PSOSITE) S PSOIQUIT=1 Q
  N PSIR,PSCT,PSINST K PSOPINST
+ 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)),"^")
+ I $G(PSOAFYN)="Y" S PSCT=1,PSOPINST=+ORL ;vfah selects CPRS Ordering Institution if autofinishing and non-interactive
+ 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
  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
  I PSCT=1 Q
 …
  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)),"^")
+ Q
 CLOZ ;checks clozapine status of patient
+CLOZ ;
  S CLOZPAT=$O(^YSCL(603.01,"C",PSODFN,0))
  S CLOZPAT=$P($G(^YSCL(603.01,+CLOZPAT,0)),"^",3)
 …
  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"
+ Q
 USER(USER) ;returns .01 of 200
+USER(USER) ;
  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
+ Q

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI3.m

-              r628
+              r636
+PSOORFI3 ;BIR/RTR-finish CPRS orders by Clinic ;11/09/98
+ ;;7.0;OUTPATIENT PHARMACY;**15,27,32,46,84,99,130,117,139,172**;DEC 1997
+PSOORFI3 ;BIR/RTR-finish CPRS orders by Clinic ;5/14/07  10:07
+ ;;7.0;OUTPATIENT PHARMACY;**15,27,32,46,84,99,130,117,139,172,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; GPL Copyright (C) 2007 WorldVistA
  ;PPPPDA1-1374,SC(-2675,40.8-728,51.2-2226,50.607-2221,55-2228,PSSLOCK-2789,DPT-10035,ORX2-867
+ ;
 …
 L1 ;Lock single order
  I '$G(ORD) Q
  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
+ 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
+ Q
 UL1 ;Unlock single order

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI4.m

-              r628
+              r636
+PSOORFI4 ;BIR/SAB-CPRS order checks and display con't ; 6/28/07 7:36am
+ ;;7.0;OUTPATIENT PHARMACY;**46,74,78,99,117,131,207,258,274**;DEC 1997;Build 8
+PSOORFI4 ;BIR/SAB-CPRS order checks and display con't ;1/27/07  13:26
+ ;;7.0;OUTPATIENT PHARMACY;**46,74,78,99,117,131,207,258,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; GPL Copyright (C) 2007 WorldVistA
  ;External reference to ^PS(51.2 supported by DBIA 2226
  ;External reference to ^PS(50.607 supported by DBIA 2221
 …
  .D EN^DDIOL("Provider Comments: ","","!")
  .F I=0:0 S I=$O(PRC(I)) Q:'I  D EN^DDIOL(PRC(I),"","!")
+ .D KV^PSOVER1 S DIR(0)="Y",DIR("A")="Copy Provider Comments into the Patient Instructions",DIR("B")="No"
+ .D ^DIR Q:'Y!($D(DIRUT))
+ .I $G(PSOAFYN)="Y" D KV^PSOVER1 ;vfam
+ .I $G(PSOAFYN)'="Y" D KV^PSOVER1 S DIR(0)="Y",DIR("A")="Copy Provider Comments into the Patient Instructions",DIR("B")="No"  ;vfam
+ .I $G(PSOAFYN)'="Y" D ^DIR Q:'Y!($D(DIRUT))  ;vfam
+ .I $G(PSOAFYN)="Y" Q  ;vfam Provider Comments NOT Copied Into Patient Instructions
  .S PSOPRC=1,NI=0 F I=0:0 S I=$O(PSONEW("SIG",I)) Q:'I  S NI=I
  .S NC=0 F I=0:0 S I=$O(PRC(I)) Q:'I  S NC=NC+1
+ .I NI'>1,NC=1,($L($G(PSONEW("SIG",NI)))+$L(PRC(1)))'>250 D  Q
+ ..S X=PRC(1) D SIGONE^PSOHELP
+ ..S PSONEW("SIG",1)=$G(PSONEW("SIG",NI))_INS1 K INS1,X
+ .I NI'>1,NC=1,($L($G(PSONEW("SIG",NI)))+$L(PRC(1)))'>250 D  Q
+ ..S PSONEW("SIG",1)=$G(PSONEW("SIG",NI))_" "_PRC(1)
  ..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
  .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
+ .F I=0:0 S I=$O(PRC(I)) Q:'I  S NI=NI+1,(PSONEW("SIG",NI),PSONEW("INS",NI))=PRC(I)
  .I $E(PSONEW("SIG",1))=" " S PSONEW("SIG",1)=$E(PSONEW("SIG",1),2,250)
  .D EN^PSOFSIG(.PSONEW,1) K NI,NC,X
+ .D EN^PSOFSIG(.PSONEW,1) K NI,NC
+ Q
 DOSE ;displays dosing info for pending orders.  called from psoorfi1

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFIN.m

-              r628
+              r636
+PSOORFIN ;BIR/SAB-finish cprs orders ;12/21/04 3:24pm
+ ;;7.0;OUTPATIENT PHARMACY;**7,15,27,32,44,46,84,106,111,117,131,146,139,195**;DEC 1997
+PSOORFIN ;BIR/SAB-finish cprs orders ;5/14/07  09:47
+ ;;7.0;OUTPATIENT PHARMACY;**7,15,27,32,44,46,84,106,111,117,131,146,139,195,208**;DEC 1997;Build 39
+ ; Modified from FOIA VistA
+ ; Copyright (C) GNU GPL 2007 WorldVistA
+ ;
  ;PSSLOCK-2789,PSDRUG-221,50.7-2223,55-2228,50.606-2174
+ D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) D MSG^PSODPT G EX
+ I $G(PSOAFYN)'="Y" D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) D MSG^PSODPT G EX ;vfah
+ I $G(PSOAFYN)="Y" D:'$D(PSOPAR) ^PSOAFSET I '$D(PSOPAR) D MSG^PSODPT G EX  ;vfah
  D INST^PSOORFI2 I $G(PSOIQUIT) K PSOIQUIT G EX
  I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1
+ 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
+ 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
+ I $G(PSOAFYN)'="Y" S (PSOFIN,POERR)=1 K PSOBCK,MEDA,MEDP,SRT,DIR D KQ ;vfah
+ I $G(PSOAFYN)="Y" S Y="PA" ;vfah
  G:Y="PA" PAT G:Y="PR" PRI G:Y="CL" ^PSOORFI3
  K DIR S PSOSORT="ROUTE"
  S DIR("?")="^D RT^PSOORFI1",DIR("A")="Route",DIR(0)="SBM^W:WINDOW;M:MAIL;C:CLINIC;E:EXIT",DIR("B")="WINDOW"
  D ^DIR G:$D(DIRUT)!(Y="E") EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y
+ I $G(PSOAFYN)="Y" S PSOSORT="ROUTE^WINDOW",PSRT="WINDOW" ;vfah
  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
  .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)
 …
  .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
+ Q
+PAT W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="PATIENT"
+ S DIR("?")="^D PT^PSOORFI1",DIR("A")="All Patients or Single Patient",DIR(0)="SBM^A:ALL;S:SINGLE;E:EXIT",DIR("B")="SINGLE"
+ D ^DIR K DIR G:$D(DIRUT)!(Y="E") EX I Y="S" S PSOSORT=PSOSORT_"^"_"SINGLE" G SPAT
+PAT I $G(PSOAFYN)'="Y" W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="PATIENT" ;vfah
+ I $G(PSOAFYN)="Y" K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="PATIENT" ;vfah
+ 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
+ I $G(PSOAFYN)'="Y" D ^DIR K DIR G:$D(DIRUT)!(Y="E") EX I Y="S" S PSOSORT=PSOSORT_"^"_"SINGLE" G SPAT ;vfah
+ I $G(PSOAFYN)="Y" S PSOSORT=PSOSORT_"^"_"SINGLE" G SPAT ;vfah
  S PSOSORT=PSOSORT_"^ALL"
  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))
 …
  G EX
 SPAT K MEDA,MEDP,PSOQFLG,PSORX("FN") D KQ,KV^PSOVER1
+ S DIR(0)="FO^2:30",DIR("A")="Select Patient",DIR("?")="^D HELP^PSOORFI2" D ^DIR I $E(X)="?" G SPAT
+ G:$D(DIRUT) EX D KV^PSOVER1
+ S DIC(0)="EQM",DIC=2,DIC("S")="I $D(^PS(52.41,""AOR"",+Y,PSOPINST))"
+ D ^DIC K DIC G:"^"[X EX G:Y=-1 SPAT S (PSODFN,PAT)=+Y,PSOFINY=Y
+ ;PSOAFIN begin SPAT
+ I $G(PSOAFDON)=1 G EX ;vfah
+ 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
+ I $G(PSOAFYN)'="Y" G:$D(DIRUT) EX D KV^PSOVER1 ;vfah
+ I $G(PSOAFYN)'="Y" S DIC(0)="EQM",DIC=2,DIC("S")="I $D(^PS(52.41,""AOR"",+Y,PSOPINST))" ;vfah
+ I $G(PSOAFYN)'="Y" D ^DIC K DIC G:"^"[X EX G:Y=-1 SPAT S (PSODFN,PAT)=+Y,PSOFINY=Y ;vfah
+ ;PSOAFIN end SPAT
  D LK I $G(POERR("QFLG")) G SPAT
  N SNGLPAT S SNGLPAT=1
 …
  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
  .S X=PAT D ULP
  S ORD=0 F  S ORD=$O(^PS(52.41,"P",PAT,ORD)) Q:'ORD!($G(POERR("QFLG")))  D
+ I PSOAFYN'="Y" S ORD=0 F  S ORD=$O(^PS(52.41,"P",PAT,ORD)) Q:'ORD!($G(POERR("QFLG")))  D  ;vhah
  .D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE")&($P(^(0),"^",3)'="HD") LK1,ORD
+ 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
  I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL
+ I $G(PSOAFYN)="Y" S PSOAFDON=1 ;vfah
  S PSOFIN=1,X=PAT D ULP G SPAT
 ORD I $G(PSOBCK) N LST,ORN
 …
  .K PSOREEDT S (PSOORRNW,PSOFDR)=1,PSORENW("OIRXN")=$P(OR0,"^",21),PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"))=0 D ^PSOORRNW,SQR^PSOORFI3
  I $P(OR0,"^",3)="RF",$D(^PSRX(+$P(OR0,"^",19),0)) D RF^PSOORFI2 G SUCC
  N PSODRUG,PSONEW S PSOFROM="PENDING" D:'$G(PSOTPBFG) DSPL^PSOTPCAN(ORD) D DSPL^PSOORFI1,SQN^PSOORFI3
+ N PSODRUG,PSONEW S PSOFROM="PENDING" D:'$G(PSOTPBFG) DSPL^PSOTPCAN(ORD) D DSPL^PSOORFI1:'$D(ZTSK),SQN^PSOORFI3
 SUCC ;
+ D UL1^PSOORFI3,FULL^VALM1
+ 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")
+ .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),"^")))
+ S:$G(POERR("DFLG")) POERR("QFLG")=1 K POERR("DFLG"),PSONEW,ACP,OR0,DRET,SIG,OID,OI,PSORX("SC"),PSORX("CLINIC"),PSODRUG
+ D SUCC^PSOORFI5
+ Q
+LBL S PSOFROM="NEW" D ^PSORXL K PSORX("PSOL"),PPL,RXRS
+ D:$D(BINGCRT)&($D(BINGRTE)&($D(DISGROUP))) ^PSOBING1 K BINGCRT,BINGRTE,PSONEW,BBFLG,BBRX
+ ;
+LBL ;
+ D LBL^PSOORFI5
+ Q
+ ;
 CHK ;
+ D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) W !,$C(7),"Outpatient Division MUST be selected!",! G EX
+ D INST1^PSOORFI2
+ S PSZCNT=0 F PSZZI=0:0 S PSZZI=$O(^PS(59,PSZZI)) Q:'PSZZI  S PSZCNT=PSZCNT+1
+ 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
+ W !!?10,$C(7),"Orders to be completed"_$S(PSZCNT=1:": ",1:" for all divisions: ")_TC,! Q:'TC
+ D SUMM^PSOORNE1 K PSZZI,PSZCNT,PSTZ
+ D CHK^PSOORFI5
+ Q
+ ;
 PRI K DIR S PSOSORT="PRIORITY"
  S DIR("A")="Select Priority",DIR(0)="SBM^S:STAT;E:EMERGENCY;R:ROUTINE",DIR("B")="ROUTINE"

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE2.m

-              r628
+              r636
 PSOORNE2 ;BIR/SAB-display finished orders from backdoor ; 9/11/06 10:24am
  ;;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
+ ;;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
  ;^PSDRUG( -  221
  ;^YSCL(603.01 - 2697
 …
  .S CLOZPAT=$S(CLOZPAT="M":2,CLOZPAT="B":1,1:0)
  I $D(^XUSEC("PSORPH",DUZ)) S RPH=1 D
  .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")
+ .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")
  .D GET^PSOORNE5 S PSOACT=PSOACT_$S(ACTREN:"N",1:""),PSOACT=PSOACT_$S(ACTREF:"R",1:"")
  .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

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE4.m

-              r628
+              r636
+PSOORNE4 ;BIR/SAB-display renew RXs from backdoor ;07/29/96
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,32,36,46,75,96,103,99,117,131**;DEC 1997
+PSOORNE4 ;BIR/SAB-display renew RXs from backdoor ;1/27/07  13:28
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,32,36,46,75,96,103,99,117,131,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; GPL Copyright (C) 2007 WorldVistA
  ;^SC DBIA-10040;^PS(50.7-2223;^PS(50.606-2174;^PS(50.607-2221;^PS(51.2-2226;^PSDRUG-221;^PS(55-2228
 EN(PSONEW) N FLD,LST,VALMCNT
 …
  .K PSONEW("DOSE"),PSONEW("UNITS"),PSONEW("DOSE ORDERED"),PSONEW("ROUTE")
  .K PSONEW("SCHEDULE"),PSONEW("DURATION"),PSONEW("CONJUNCTION"),PSONEW("NOUN"),PSONEW("VERB"),PSOPRC,PSONEW("ODOSE")
+RDD D DSPL,^PSOLMRN D:$G(PKI1)=2 DCP^PSOPKIV1 I $G(PSORX("FN")) S VALMBCK="Q" K PSOREEDT Q
+ G:'$G(PSOQUIT) RDD
+RDD I $G(PSOAFYN)'="Y" D DSPL,^PSOLMRN D:$G(PKI1)=2 DCP^PSOPKIV1 I $G(PSORX("FN")) S VALMBCK="Q" K PSOREEDT Q  ;vfah
+ 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
+ I $G(PSOAFYN)'="Y" G:'$G(PSOQUIT) RDD ;vfah
+ Q
 EDT D KV^PSOVER1 S DIR("A")="Select Field to Edit by number",DIR(0)="LO^1:"_$S($G(PSOREEDT):10,1:8)

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE5.m

-              r628
+              r636
 PSOORNE5 ;BIR/SAB - display orders from backdoor con't ;5/10/07 8:29am
  ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,78,99,117,131,146,171,180,210,222,268,206**;DEC 1997;Build 39
+PSOORNE5 ;BIR/SAB - display orders from backdoor con't ;5/23/05 1:46pm
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,78,99,117,131,146,171,180,210,222,268**;DEC 1997;Build 9
  ;External reference to ^PSDRUG supported by DBIA 221
  ;External references L and UL^PSSLOCK supported by DBIA 2789
 …
  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
  I $P($G(PSODIR("CS")),"^",2)=1 S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0 Q
  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
+ I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0 Q
  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
  I PSODIR("CS") D
 …
  S:PSORFRM<0 PSORFRM=0 S:PSORFRM=0 ACTREF=0
  I $G(RXFL(RXN))]"",'$P(PSOPAR,"^",6) S ACTREF=0
  I $P(PSODRUG0,"^",3)["A"&($P(PSODRUG0,"^",3)'["B")!($P(PSODRUG0,"^",3)["F")!($P(PSODRUG0,"^",3)[1)!($P(PSODRUG0,"^",3)[2) S ACTREF=0
+ I $P(PSODRUG0,"^",3)["A"&($P(PSODRUG0,"^",3)'["B")!($P(PSODRUG0,"^",3)["F") S ACTREF=0
  ;renews
  I $P(PSOPAR,"^",4)=0 S ACTREN=0 Q
 …
  I $G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) S ACTREN=0,VALMSG="This Drug has been Inactivated."
  I '$P($G(^PSDRUG(PSODRG,2)),"^"),'$P($G(^PSRX(RXN,"OR1")),"^") S ACTREN=0,VALMSG="Drug must be Matched to an Orderable Item!"
+ I ($P(PSODRUG0,"^",3)["W")!($P(PSODRUG0,"^",3)[1)!($P(PSODRUG0,"^",3)[2) S ACTREN=0
+ I $P(PSODRUG0,"^",3)["A",$P(PSODRUG0,"^",3)'["B" S ACTREN=0
+ I $P(PSODRUG0,"^",3)["W" S ACTREN=0
  I $D(^PS(53,+$P(RX0,"^",3),0)),'$P(^(0),"^",5) S ACTREN=0
  S PSOLC=$P(RX0,"^"),PSOLC=$E(PSOLC,$L(PSOLC)) I $A(PSOLC)'<90 S ACTREN=0

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNEW.m

-              r628
+              r636
+PSOORNEW ;BIR/SAB - display orders from oerr ;4/25/07 8:50am
+ ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,55,46,71,90,94,106,131,133,143,237,222,258,206**;DEC 1997;Build 39
+PSOORNEW ;BIR/SAB - display orders from oerr ;1/27/07  13:29
+ ;;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
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
  ;^PS(50.7 -2223
  ;^PSDRUG -221
  ;^PS(50.606 -2174
  ;^PS(55 -2228
+ ;
  ;PSO*237 quit Finish if Today > Issue date + 365
+ ;
 DSPL I $G(PSODSPL) S VALMBCK="Q" K PSODSPL,PSOANSQD Q
  Q:'$D(PSOLMC)  K ^TMP("PSOPO",$J) S PSOLMC=PSOLMC+1
 …
  .S (OI,PSODRUG("OI"))=$P(OR0,"^",8),PSODRUG("OIN")=$P(^PS(50.7,$P(OR0,"^",8),0),"^"),OID=$P(OR0,"^",9)
  .I $P($G(OR0),"^",9) S POERR=1,DREN=$P(OR0,"^",9) D DRG^PSOORDRG K POERR
  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
+ I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A",$G(PSODRUG("DEA"))'["B"!($G(PSODRUG("DEA"))["F") S PSONEW("# OF REFILLS")=0
  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)
  S IEN=0 D OBX^PSOORFI1,DIN^PSONFI(PSODRUG("OI"),$S($G(PSODRUG("IEN")):PSODRUG("IEN"),1:""))
 …
  S:PSOLMC>1 VALMBCK="R"
+ Q
+ORCHK D PROVCOM^PSOORFI4,ORCHK^PSOORFI4
+ORCHK D PROVCOM^PSOORFI4
+ I $G(PSOAFYN)'="Y" D ORCHK^PSOORFI4
+ Q
 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))
 …
  D RXNCHK^PSOORNE1 I $G(PSONEW("QFLG")) S PSONEW("DFLG")=1 Q
  I DT>$$FMADD^XLFDT($P(OR0,"^",6),365) D EXPR^PSONEW2 G DSPL
+ D STOP^PSONEW2,DISPLAY^PSONEW2,^PSONEWF
+ I $G(PSOAFYN)'="Y" D STOP^PSONEW2,DISPLAY^PSONEW2,^PSONEWF
+ I $G(PSOAFYN)="Y" D STOP^PSONEW2
  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
+ 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
+ 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
+ I $G(PSOAFYN)="Y" S Y="1"
  D KV I 'Y K PSOANSQ G DSPL
  I $G(PSONEW("MAIL/WINDOW"))["W" D:$P($G(PSOPAR),"^",12)  S BINGCRT="Y",BINGRTE="W",PSORX("MAIL/WINDOW")="WINDOW" K RTN
+ .W ! K DIR,DIRUT S DIR(0)="52,35O"
+ .S:$G(PSORX("METHOD OF PICK-UP"))]"" DIR("B")=PSORX("METHOD OF PICK-UP") D ^DIR I $D(DIRUT) K DIR,DIRUT Q
+ .S (PSONEW("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y K X,Y
+ .I $G(PSOAFYN)'="Y" W ! K DIR,DIRUT S DIR(0)="52,35O"
+ .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
+ .I $G(PSOAFYN)'="Y" S (PSONEW("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y K X,Y
+ .I $G(PSOAFYN)="Y" S (PSONEW("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))="AutoFinished for Rx Printing"
  S PSONEW("POE")=1 D EN^PSON52(.PSONEW) G:$G(PSONEW("DFLG")) ABORT D DCORD^PSONEW2
  D NPSOSD^PSOUTIL(.PSONEW),FULL^VALM1 K PSORX("MAIL/WINDOW")
  D EOJ^PSONEW
+ABORT S VALMBCK="Q",DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR,CLEAN^PSOVER1,KV
+ABORT ;
+ I $G(PSOAFYN)'="Y" S VALMBCK="Q",DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR,CLEAN^PSOVER1,KV ;vfah
+ I $G(PSOAFYN)="Y" D CLEAN^PSOVER1,KV ;vfah
+ Q
 KV K DIRUT,DUOUT,DTOUT,DIR
 …
+ ;
 DRGMSG ;
+ 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
+ .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)
+ K SG Q
+ D DRGMSG^PSOORNW2 Q  ;vfam
+ ;

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNW1.m

-              r628
+              r636
 PSOORNW1 ;ISC BHAM/SAB - continuation of finish of new order ;5/10/07 8:30am
  ;;7.0;OUTPATIENT PHARMACY;**23,46,78,117,131,133,172,148,222,268,206**;DEC 1997;Build 39
+PSOORNW1 ;ISC BHAM/SAB - continuation of finish of new order ;07/19/96 12:58 PM
+ ;;7.0;OUTPATIENT PHARMACY;**23,46,78,117,131,133,172,148,222,268**;DEC 1997;Build 9
  ;Reference ^YSCL(603.01 supported by DBIA 2697
  ;Reference ^PS(55 supported by DBIA 2228
 …
  E  D
  .S PSOX=$S($P($G(OR0),"^",11)'>PTRF&($P($G(OR0),"^",11)'>11):11,1:PTRF)
  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
+ 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
  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
  S PSONEW("# OF REFILLS")=$S($G(PSONEW("# OF REFILLS"))'="":$G(PSONEW("# OF REFILLS")),1:PSOX) K PSDY,PSDY1,PTRF

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNW2.m

-              r628
+              r636
+PSOORNW2 ;ISC-BHAM/SAB - edit orders from oerr ; 6/28/07 11:36am
+ ;;7.0;OUTPATIENT PHARMACY;**10,23,37,46,117,131,133,148,222,269,206**;DEC 1997;Build 39
+PSOORNW2 ;ISC-BHAM/SAB - edit orders from oerr ; 12/10/06 9:55pm
+ ;;7.0;OUTPATIENT PHARMACY;**10,23,37,46,117,131,133,148,222,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;Reference to ^YSCL(603.01 supported by DBIA 2697
  ;Reference to ^PS(55 supported by DBIA 2228
 …
  S DIC("B")=$S($G(PSODRUG("OIN"))]"":PSODRUG("OIN"),1:""),DIC="^PS(50.7,",DIC(0)="AEMQZ"
  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  "
+ S DIC("S")=DIC("S")_"I $P($G(^PSDRUG(PSOL,2)),U,3)[""O"",'$G(^(""I""))!($G(^(""I""))'<DT) S PSOF=1"
+ ;BHW;PSO*7*269;Modify ^DIC call to call MIX^DIC to use only the B and C Cross-References.
+ S D="B^C" D MIX^DIC1 K DIC,D I X["^"!($D(DTOUT)) S OUT=1 Q
+ 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
  S PSOY=Y
  I +Y'=OI D  I 'Y!($D(DIRUT)) D KV,MP1^PSOOREDX K DIC,Y,PSOY S OUT=1 Q
 …
  .S PSONEW("# OF REFILLS")=$S(PSONEW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSONEW("# OF REFILLS"))
  I $G(PSOMAX) S PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11))
  I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F")!($G(PSODRUG("DEA"))[1)!($G(PSODRUG("DEA"))[2) D
  .S PSONEW("# OF REFILLS")=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["A":"this narcotic drug.",1:"this drug.")
+ I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F") D
+ .S PSONEW("# OF REFILLS")=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics ...")
+ Q
+ ;
 …
  .S:'$G(PSONEW("# OF REFILLS")) PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11))
  .S (PSONEW("N# REF"),PSONEW("# OF REFILLS"))=$S(PSONEW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSONEW("# OF REFILLS"))
  .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
  ..S (PSOMAX,PSONEW("N# REF"),PSONEW("# OF REFILLS"))=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["A":"this narcotic drug.",1:"this drug.")
+ .I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F") D  Q
+ ..S (PSOMAX,PSONEW("N# REF"),PSONEW("# OF REFILLS"))=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics ...")
  .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
  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
  .S (PSONEW("N# REF"),PSONEW("# OF REFILLS"))=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["A":"this narcotic drug.",1:"this drug.")
+ I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F") D  Q
+ .S (PSONEW("N# REF"),PSONEW("# OF REFILLS"))=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics ...")
  S (PSONEW("N# REF"),PSOMAX,PSONEW("# OF REFILLS"))=+$P(OR0,"^",11)
 ASK S PSONEW("FLD")=9 D REFILL^PSODIR1(.PSONEW) ; Get # of refills
 …
 S PSONEW("FLD")=13 D RMK^PSODIR2(.PSONEW) ; Get Remarks
+ Q
+ ;
+DRGMSG ;From PSOORNEW
+ 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
+ .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)
+ K SG Q
+ ;
 DREN ;
  S (PSDC,PSI)=0

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORRNW.m

-              r628
+              r636
+PSOORRNW ;BIR/SAB-finish OP renew orders from OE/RR ;4/25/07 8:46am
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,51,46,71,94,130,131,146,206**;DEC 1997;Build 39
+PSOORRNW ;BIR/SAB-finish OP renew orders from OE/RR ; 11/3/06 10:02pm
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,51,46,71,94,130,131,146,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External reference to ^PSDRUG supported by DBIA 221
  ;External reference to ^PS(50.607 supported by DBIA 2221
 …
  ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
  S PSORENXX=$P($G(OR0),"^",21),PSOFROM="NEW" K PRC,PHI
  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
+ 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
  .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P(PSOMSG,"^",2) Q
  .W $C(7),!!,"Another person is editing Rx "_$P($G(^PSRX(PSORENXX,0)),"^")
+ K PSOMSG N OI,VALMCNT K POERR("DFLG") D FULL^VALM1 S (PSORX("DFLG"),PSORENW("DFLG"))=0,(PSORNW("FILL DATE"),PSORENW("FILL DATE"))=DT
+ I $G(PSOAFYN)="Y" I $G(PSORENXX) D PSOL^PSSLOCK(PSORENXX) ;vfah
+ 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
+ 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
  S Y=DT X ^DD("DD") S PSORX("FILL DATE")=Y K 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
+ 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
  I $P($G(^PSRX($P(OR0,"^",21),"OR1")),"^",4) D  D PROCESSX^PSORENW0 D UL Q
  .W !!,"Cannot Renew Rx # "_$P(^PSRX($P(OR0,"^",21),0),"^"),!," Drug: "_$P($G(^PSDRUG($P(^PSRX($P(OR0,"^",21),0),"^",6),0)),"^")_"."
 …
  .S PSOCS=0 K DIR,DIC,PSOX
  .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
+ .;PSO*7*206
+ .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
+ .S PSOMAX=$S(PSOCS:5,1:11) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") S PSOMAX=0
  E  S PSOMAX=$P(OR0,"^",11)
  S RXPT=+$P(PSORENW("RX0"),"^",3) I $G(^PS(53,RXPT,0))]"" D

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORUT1.m

-              r628
+              r636
 PSOORUT1 ;BIR/SAB - Utility routine for oerr interface ; 6/28/07 7:36am
  ;;7.0;OUTPATIENT PHARMACY;**1,14,30,46,132,148,233,274**;DEC 1997;Build 8
+PSOORUT1 ;BIR/SAB - Utility routine for oerr interface ;02/22/95
+ ;;7.0;OUTPATIENT PHARMACY;**1,14,30,46,132,148,233**;DEC 1997;Build 8
  ;External reference to ^PSDRUG supported by DBIA 221
  ;External reference to ^PSXOPUTL supported by DBIA 2203
 …
  .I $$SUBMIT^PSOBPSUT(DA) D ECMESND^PSOBPSU1(DA,,$$RXFLDT^PSOBPSUT(DA),$S('$O(^PSRX(DA,1,0)):"OF",1:"RF"))
  G EXIT^PSOORUTL
 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
+ACT1 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
  S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA  S IR=FDA
  S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORUTL.m

-              r628
+              r636
 PSOORUTL ;ISC BHAM/SAB  - updates order status from oerr ; 6/28/07 7:36am
  ;;7.0;OUTPATIENT PHARMACY;**14,46,146,132,118,199,223,148,249,274**;DEC 1997;Build 8
+PSOORUTL ;ISC BHAM/SAB  - updates order status from oerr ;02/22/95
+ ;;7.0;OUTPATIENT PHARMACY;**14,46,146,132,118,199,223,148,249**;DEC 1997;Build 9
  ;External reference to EN^ORERR - 2187
  ;External reference to ^PS(55 - 2228
 …
  S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA  S IR=FDA
  S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
- S RXF=$S(RXF>5:RXF+1,1:RXF)
  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."
+ Q

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPMP0.m

-              r628
+              r636
 PSOPMP0 ;BIRM/MFR - Patient Medication Profile - Listmanager ;10/28/06
  ;;7.0;OUTPATIENT PHARMACY;**260,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**260**;DEC 1997;Build 84
  ;Reference to EN1^GMRADPT supported by IA #10099
  ;Reference to EN6^GMRVUTL supported by IA #1120
 …
  ; - Patient selection
  W !! S DIC=2,DIC(0)="QEAM" D ^DIC G EXIT:Y<0  S DFN=+Y
+ ;
- S PSODFN=DFN D CHKADDR^PSOBAI(DFN,1,1)  ;bad address flag/update
+ ;
  D LST(PSOSITE,DFN)
 …
+ ;
 SETSORT(FIELD) ; - Sets the data sorted by the FIELD specified
  N SEQ,RX,RXNUM,DRUG,DRNAME,QTY,STATUS,STS,ISSDT,DOCDAT,LSTFD,REFREM,DAYSUP,SIG,Z,ORD,GRPCNT,GROUP,RFRX,OI,PSOBADR
+ N SEQ,RX,RXNUM,DRUG,DRNAME,QTY,STATUS,STS,ISSDT,DOCDAT,LSTFD,REFREM,DAYSUP,SIG,Z,ORD,GRPCNT,GROUP,RFRX,OI
+ ;
  K ^TMP("PSOPMPSR",$J)
 …
  . S REFREM=$$REFREM^PSOPMP1(RX)
  . S DAYSUP=$$GET1^DIQ(52,RX,8)
- . S PSOBADR=$O(^PSRX(RX,"L",9999),-1)
- . I PSOBADR'="" S PSOBADR=$G(^PSRX(RX,"L",PSOBADR,0)) I PSOBADR["(BAD ADDRESS)" S PSOBADR="B"
- . I PSOBADR'="B" S PSOBADR=""
  . S Z="",$P(Z,"^")=RX,$P(Z,"^",2)=RXNUM_$$COPAY^PSOPMP1(RX)_$$ECME^PSOBPSUT(RX),$P(Z,"^",3)=$E(DRNAME,1,30)
  . S $P(Z,"^",4)=QTY,$P(Z,"^",5)=$P(STATUS,"^",3)_$$CMOP^PSOPMP1(DRUG,RX)_PSOBADR,$P(Z,"^",6)=$P(ISSDT,"^",2)
+ . S $P(Z,"^",4)=QTY,$P(Z,"^",5)=$P(STATUS,"^",3)_$$CMOP^PSOPMP1(DRUG,RX),$P(Z,"^",6)=$P(ISSDT,"^",2)
  . S $P(Z,"^",7)=$P(LSTFD,"^",2),$P(Z,"^",8)=REFREM,$P(Z,"^",9)=DAYSUP
  . S SORT=$S(FIELD="RX":RXNUM_" ",FIELD="DR":DRNAME_RXNUM,FIELD="ID":+ISSDT_RXNUM_" ",FIELD="LF":+LSTFD_RXNUM_" ")
 …
+ ;
  ; - Regular prescription
  I TYPE="RX" D  S VALMBCK="R" D REF
+ I TYPE="RX" D
  . N PSOVDA,PSOSAVE,DA,PS
  . S (PSOVDA,DA)=ORD,PS="REJECTMP"
+ . S (PSOVDA,DA)=ORD,PS="REJECT"
  . N LINE,TITLE,PSODFN D DP^PSORXVW
+ ;

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPMP1.m

-              r628
+              r636
 PSOPMP1 ;BIRM/MFR - Patient Medication Profile - Listmanager ;04/28/05
  ;;7.0;OUTPATIENT PHARMACY;**260,285,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**260**;DEC 1997;Build 84
  ;Reference to ^PSDRUG("AQ" supported by IA 3165
  ;Reference to EN1^GMRADPT supported by IA 10099
 …
  . . S LBL=GRPLN(LN),POS=41-($L(LBL)\2)
  . . D CNTRL^VALM10(LN,1,POS-1,IOUON_IOINHI,IOINORM)
  . . D CNTRL^VALM10(LN,POS,$L(LBL),IORVON_IOINHI,IORVOFF_IOINORM)
+ . . D CNTRL^VALM10(LN,POS,$L(LBL),IORVON_IOINHI,IOINORM)
  . . D CNTRL^VALM10(LN,POS+$L(LBL),81-POS-$L(LBL),IOUON_IOINHI,IOINORM)
+ Q
 …
 FILTER(RX) ; - Filter Rx's that should not be displayed
  I $$GET1^DIQ(52,RX,26,"I")<PSOEXPDC Q 1
  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
+ 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
  I $$GET1^DIQ(52,RX,100,"I")=""!($$GET1^DIQ(52,RX,100,"I")=13) Q 1
  I $$GET1^DIQ(52,RX,.01)="" Q 1
 …
  I GMRAL S ALLERGY="<A>"
  E  D ALLERGY^PSOORUT2 I PSONOAL'="" S ALLERGY="<NO ALLERGY ASSESSMENT>"
  S ALLERGY=IORVON_ALLERGY_IORVOFF_IOINORM
+ S ALLERGY=IORVON_ALLERGY_IOINORM
  I '$G(POS) S POS=80-$L(ALLERGY)
  S LINE=$$SETSTR^VALM1(ALLERGY,LINE,POS,80)

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOR52.m

-              r628
+              r636
 PSOR52 ;IHS/DSD/JCM - Files refill entries in prescription file ;03/10/93
  ;;7.0;OUTPATIENT PHARMACY;**10,22,27,181,148,201,260,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**10,22,27,181,148,201,260**;DEC 1997;Build 84
  ;Reference to ^PSDRUG supported by DBIA 221
  ;Reference to PSOUL^PSSLOCK supported by DBIA 2789
 …
  . S ACTION="" D ECMESND^PSOBPSU1(PSOERX,PSOERF,PSOX("FILL DATE"),"RF")
  . I $$FIND^PSOREJUT(PSOERX,PSOERF) D
  . . S ACTION=$$HDLG^PSOREJU1(PSOERX,PSOERF,"79,88","OF","IOQ","Q")
+ . . S ACTION=$$HDLG^PSOREJU1(PSOERX,PSOERF,"79,88","OF","IOQ","I")
  . I $$STATUS^PSOBPSUT(PSOERX,PSOERF)="E PAYABLE" D
  . . D SAVNDC^PSSNDCUT(+$$GET1^DIQ(52,PSOERX,6,"I"),$G(PSOSITE),$$GETNDC^PSONDCUT(PSOERX,PSOERF))

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREF.m

-              r628
+              r636
+PSOREF ;BIR/SAB-refill data entry ;4/25/07 8:45am
+ ;;7.0;OUTPATIENT PHARMACY;**1,23,27,36,46,78,130,131,148,206**;DEC 1997;Build 39
+PSOREF ;BIR/SAB-refill data entry ;1/27/07  13:31
+ ;;7.0;OUTPATIENT PHARMACY;**1,23,27,36,46,78,130,131,148,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
  ;External reference to ^PSDRUG supported by DBIA 221
  ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
 …
+ Q
 OERR ;single refil
+ ;
+ S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
+ D ^DIC K DIC ;vfah
+ S PSOZAF=+Y ;vfah
+ I $P($G(^PSRX(RXN,"OR1")),"^",5)=$G(PSOZAF) S VALMBCK="",VALMSG="Refill option is not available for Autofinshed Rxs" K PSOZAF Q  ;vfah
  I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2),,.VALMSG,.VALMBCK) Q
  I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!" Q
 …
  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
  .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""!($G(PSOREF("QFLG")))  S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52
+ ..S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
+ ..D ^DIC K DIC ;vfah
+ ..S PSOZAF=+Y ;vfah
+ ..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
  ..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
  ..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
 …
  I '$P($G(^PSRX(RXN,"OR1")),"^"),$P($G(^PSDRUG(PSODRG,2)),"^") S $P(^PSRX(RXN,"OR1"),"^")=$P(^PSDRUG(PSODRG,2),"^")
  S CLOZPAT=$S($P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1":1,1:0)
  I 'CLOZPAT I PSODEA["A"&(PSODEA'["B")!(PSODEA["F")!(PSODEA[1)!(PSODEA[2) Q "0^"_$S(PSODEA["A":"Narcotic Drug. ",1:"")_"Order Non-Refillable."
+ I 'CLOZPAT I PSODEA["A"&(PSODEA'["B")!(PSODEA["F") Q "0^"_$S(PSODEA["F":"",1:"Narcotic Drug. ")_"Order Non-Refillable."
  K CLOZPAT I DT>$P($G(^PSRX(RXN,2)),"^",6) Q "0^Non-Refillable.  Prescription has Expired."
  I $P(^PSRX(RXN,3),"^",2)>$P(^PSRX(RXN,2),"^",6) Q "0^Next Refill Date Past Expiration Date.  New Order Required."

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREJP1.m

-              r628
+              r636
 PSOREJP1 ;BIRM/MFR - Third Party Reject Display Screen ;04/29/05
  ;;7.0;OUTPATIENT PHARMACY;**148,247,260,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**148,247,260**;DEC 1997;Build 84
  ;Reference to File 9002313.93 - BPS NCPDP REJECT CODES supported by IA 4720
  ;Reference to ^PS(59.7 supported by IA 694
 …
  K ^TMP("PSOREJP1",$J) S VALMCNT=0,LINE=0
  D GET^PSOREJU2(RX,FILL,.DATA,REJ,1)
  D REJ           ; Display REJECT Info
  D OTH           ; Display Other Rejects Info
  D COM^PSOREJP3  ; Display Comment
  D INS           ; Display Insurance Info
  D CLS           ; Display Resolution Info
+ D REJ                   ; Display the REJECT Information
+ D OTH                   ; Display the Other Rejects Information
+ D COM^PSOREJP3          ; Display the Comment
+ D INS                   ; Display the Insurance Information
+ D CLS                   ; Display the Resolution Information
  S VALMCNT=LINE
+ Q
 …
+ ;
 OUT(RX) ; - Supported call by outside PROTOCOLs to act on specific REJECTs
+ N I,RFL,DATA,REJ,PSOBACK,VALMCNT,RXN
+ I '$D(^XUSEC("PSORPH",DUZ)) S VALMSG="PSORPH key required to use the REJ action.",VALMBCK="R" Q
+ I $G(PS)="REJECT" D  Q
+ . S VALMSG="REJ action is not available at this point.",VALMBCK="R"
+ N I,RFL,DATA,REJ,PSOBACK,VALMCNT
  S PSOBACK=1
  S (RFL,I)=0 F I=1:1 Q:'$D(^PSRX(RX,1,I))  S RFL=I

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORELD1.m

-              r628
+              r636
+PSORELD1 ;BIR/PWC-HL7 V.2.4 EXTERNAL INTERFACE RELEASE DATE/TIME CONT. ;03/22/04
+ ;;7.0;OUTPATIENT PHARMACY;**156**;DEC 1997
+PSORELD1 ;BIR/PWC-HL7 V.2.4 EXTERNAL INTERFACE RELEASE DATE/TIME CONT. ;5:23 AM  31 Jan 2008
+ ;;7.0;OUTPATIENT PHARMACY;**156**;DEC 1997;Build 4
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
  ;HLFNC supp. by DBIA 10106
  ;PSNAPIS supp. by DBIA 2531
 …
  D PID(.PSI),PV1(.PSI),PV2(.PSI),ORC(.PSI),RXE(.PSI),RXD(.PSI)
  ; clean up data set by GETDATA
+ K BINGO,RELDT,SITE,SITADD,SITPHN,PSOXN,PSOXN2,PSND1,PSND2,PSND3,PRODUCT,PSOPROD,VANAME,UNIT,PSDOSE,PODOSENM,POIPTR,NRFL,DISPDT,COPAY,ERR,PSONDC,NFDL,NFLD,PSZIP,PSOHZIP,TRADENM,X,Y,UU
+ Q
+ K BINGO,RELDT,SITE,SITADD,SITPHN,PSOXN,PSOXN2,PSND1,PSND2,PSND3,PRODUCT,PSOPROD,VANAME
+ K UNIT,PSDOSE,PODOSENM,POIPTR,NRFL,DISPDT,COPAY,ERR,PSONDC,NFDL,NFLD,PSZIP,PSOHZIP,TRADENM,X,Y,UU
+ QUIT
+ ;  ========
 GETDATA ; this is the place to set all data needed for several segments
  I $G(FP)="F"&('$G(FPN)) D    ;original
 …
  . S PVDR=$P(^PSRX(IRXN,0),"^",4),QTY=$P(^(0),"^",7),DASPLY=$P(^(0),"^",8),MW=$P(^(0),"^",11),EBY=$P(^(0),"^",16)
  I $G(FP)="F"&($G(FPN)) D    ;refill
+ . S FDT=$P(^PSRX(IRXN,1,FPN,0),"^"),MW=$P(^(0),"^",2),QTY=$P(^(0),"^",4),DASPLY=$P(^(0),"^",10),DISPDT=$P(^(0),"^",19),EXDT=$S($P(^(0),"^",15):$P(^(0),"^",15),1:$P(^PSRX(IRXN,2),"^",6))
+ . S FDT=$P(^PSRX(IRXN,1,FPN,0),"^"),MW=$P(^(0),"^",2),QTY=$P(^(0),"^",4),DASPLY=$P(^(0),"^",10),DISPDT=$P(^(0),"^",19)
+ . S EXDT=$S($P(^(0),"^",15):$P(^(0),"^",15),1:$P(^PSRX(IRXN,2),"^",6))
  . S VPHARMID=$S($P(^PSRX(IRXN,1,FPN,0),"^",5)'="":$P(^(0),"^",5),1:$P(^PSRX(IRXN,2),"^",10))
+ . S EBY=$S($P(^PSRX(IRXN,1,FPN,0),"^",5):$P(^(0),"^",5),1:$P(^(0),"^",7)),PVDR=$P(^(0),"^",17),PSONDC=$S($P($G(^PSRX(IRXN,1,FPN,1)),"^",3):$P(^(1),"^",3),1:$P(^PSRX(IRXN,2),"^",7))
+ . S EBY=$S($P(^PSRX(IRXN,1,FPN,0),"^",5):$P(^(0),"^",5),1:$P(^(0),"^",7)),PVDR=$P(^(0),"^",17)
+ . S PSONDC=$S($P($G(^PSRX(IRXN,1,FPN,1)),"^",3):$P(^(1),"^",3),1:$P(^PSRX(IRXN,2),"^",7))
  I $G(FP)="P" D  ;partial
+ . S FDT=$P(^PSRX(IRXN,"P",FPN,0),"^"),MW=$P(^(0),"^",2),QTY=$P(^(0),"^",4),DASPLY=$P(^(0),"^",10),DISPDT=$P(^(0),"^",13),PVDR=$P(^(0),"^",17),EXDT=$P(^PSRX(IRXN,2),"^",6)
+ . S EBY=$S($P(^PSRX(IRXN,"P",FPN,0),"^",5):$P(^(0),"^",5),1:$P(^(0),"^",7)),VPHARMID=$S($P(^(0),"^",5)'="":$P(^(0),"^",5),1:$P(^PSRX(IRXN,2),"^",10)),PVDR=$P(^PSRX(IRXN,"P",FPN,0),"^",17)
+ . S FDT=$P(^PSRX(IRXN,"P",FPN,0),"^"),MW=$P(^(0),"^",2),QTY=$P(^(0),"^",4),DASPLY=$P(^(0),"^",10),DISPDT=$P(^(0),"^",13)
+ . S PVDR=$P(^(0),"^",17),EXDT=$P(^PSRX(IRXN,2),"^",6)
+ . S EBY=$S($P(^PSRX(IRXN,"P",FPN,0),"^",5):$P(^(0),"^",5),1:$P(^(0),"^",7))
+ . S VPHARMID=$S($P(^(0),"^",5)'="":$P(^(0),"^",5),1:$P(^PSRX(IRXN,2),"^",10)),PVDR=$P(^PSRX(IRXN,"P",FPN,0),"^",17)
  . S PSONDC=$S($P(^PSRX(IRXN,"P",FPN,0),"^",12):$P(^(0),"^",12),1:$P(^PSRX(IRXN,2),"^",7))
  S EFDT=$P(^PSRX(IRXN,2),"^",2) S:$G(EFDT) EFDT=$$HLDATE^HLFNC(EFDT,"DT")
 …
  S DEAID=$$GET1^DIQ(200,PVDR_",",53.2)
  K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=VPHARMID D ^DIC
  S VPHARM=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)):1,"""""") K DIC,X,Y
+ S VPHARM=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
  K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=EBY D ^DIC
  S EBY1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)):1,"""""") K DIC,X,Y
+ S EBY1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
  K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=PVDR D ^DIC
  S PVDR1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)):1,"""""") K DIC,X,Y
+ S PVDR1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
  S PRIORDT=$P(^PSRX(IRXN,3),"^",4),PRIORDT=$$HLDATE^HLFNC(PRIORDT,"DT")
  S FDT=$$HLDATE^HLFNC(FDT,"DT")
 …
  S FIN=$P(^PSRX(IRXN,"OR1"),"^",5)
  K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=FIN D ^DIC
  S FIN1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)):1,"""""") K DIC,X,Y
+ S FIN1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
  S SITE=$S($D(^PS(59,PSOSITE,0)):^(0),1:"")
  S PSZIP=$P(SITE,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
 …
  S CSINER=$P(^PSRX(IRXN,3),"^",3)
  K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=CSINER D ^DIC
  S CSINER1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)):1,"""""") K DIC,X,Y
+ S CSINER1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
  D 6^VADPT
  I MW="W" S MP=$S($P($G(^PSRX(IRXN,"MP")),"^"):$P(^("MP"),"^"),1:"""""")
 …
  S NFLD=0,UU="" F  S UU=$O(^PSRX(IRXN,1,UU)) Q:UU=""  S:$D(^PSRX(IRXN,1,UU,0)) NFLD=NFLD+1
  S NRFL=$P(^PSRX(IRXN,0),"^",9),RFRM=(NRFL-NFLD)
+ Q
+ QUIT
+ ;  =========
 PID(PSI) ;patient ID segment
+ Q:'$D(DFN)!$D(PAS)
+ QUIT:'$D(DFN)!$D(PAS)
+ ;
  S HLFS=HL1("FS"),HLECH=HL1("ECH"),HLQ=HL1("Q"),HLVER=HL1("VER")
  K PSPID,PSPID1
 …
  S PAS=1
  K PSPID,PSPID1,PRSEPID,PRSEZTA,SPOT,TMPADD,ADDSEQ
+ Q
+ QUIT
+ ;  =========
 PV1(PSI) ;patient visit segment
  N PV1  ;hardcoded to letter O for Outpatient (Patient class)
 …
  S ^TMP("PSO",$J,PSI)=PV1
  S PSI=PSI+1
+ Q
+ QUIT
+ ;  =========
 PV2(PSI) ;patient visit segment (additional information)
  ;PATIENT STATUS AND COPAY
 …
  S ^TMP("PSO",$J,PSI)="PV2|"_PV2
  S PSI=PSI+1
+ Q
+ QUIT
+ ;  =========
 ORC(PSI) ;common order segment
+ Q:'$D(DFN)
+ QUIT:'$D(DFN)
+ ;
  N ORC S ORC=""
  S $P(ORC,"|",1)="OE"
 …
  S $P(ORC,"|",17)=CLN_CS_CLN1_CS_"99PSC"
  S $P(ORC,"|",19)=$S(CSINER'="":CSINER_CS_CSINER1,1:"")
+ S $P(ORC,"|",21)=$P(SITE,"^",1)_CS_CS_$P(SITE,"^",6)_
+ ;  3080129 - RCR
+ ;  Segment 21 is incomplete.  Truncated.
+ ; S $P(ORC,"|",21)=$P(SITE,"^",1)_CS_CS_$P(SITE,"^",6)_
+ S $P(ORC,"|",21)=$P(SITE,"^",1)_CS_CS_$P(SITE,"^",6)
  S PSZIP=$P(SITE,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
  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
  S $P(ORC,"|",23)="("_$P(SITE,"^",3)_")"_$P(SITE,"^",4)
  S ^TMP("PSO",$J,PSI)="ORC|"_ORC,PSI=PSI+1
+ Q
+ QUIT
+ ;  ===========
 RXE(PSI) ;Pharmacy/treatment Encoded Order segment
+ Q:'$D(DFN)
+ N RXE S RXE=""
+ QUIT:'$D(DFN)
+ ;
+ N RXE,PSDRG10
+ S RXE=""
  S $P(RXE,"|",1)=""""""
+ S $P(RXE,"|",2)=$S($P($G(^PSDRUG(IDGN,"ND")),"^",10)'="":$P(^("ND"),"^",10),($G(PSND1)&$G(PSND3)):$P($G(PSOXN2),"^",2),1:"""""")_CS_$G(PSND2)_CS_"99PSNDF"_CS_PSND1_"."_PSND3_"."_$G(IDGN)_CS_$P($G(^PSDRUG(IDGN,0)),"^")_CS_"99PSD"
+ S PSDRG10=$P($G(^PSDRUG(IDGN,"ND")),"^",10)
+ ;
+ ;  29JAN2008 - RCR ; The problem is tha/home/rcr/PSORELD1.mt the last $PIECE is incomplete.  This needs to be validated
+ ; S $P(RXE,"|",2)=$S($P($G(^PSDRUG(IDGN,"ND")),"^",10)'="":$P(^("ND"),"^",10),($G(PSND1)&$G(PSND3)):$P($G(PSOXN2),"^",2),1:"""""")_CS_$G(PSND2)_CS_"99PSNDF"_CS_PSND1_"."_PSND3_"."_$G(IDGN)_CS_$P($G(^PSDRUG(IDGN,0)),"^"_CS_"99PSD"
+ S $P(RXE,"|",2)=$S(PSDRG10'="":PSDRG10,($G(PSND1)&$G(PSND3)):$P($G(PSOXN2),"^",2),1:"""""")_CS_$G(PSND2)_CS_"99PSNDF"_CS_PSND1_"."_PSND3_"."_$G(IDGN)_CS_$P($G(^PSDRUG(IDGN,0)),"^")_CS_"99PSD"
  S $P(RXE,"|",3)=""
  I $G(PSOXN)="" S PSOXN=""""""
  S $P(RXE,"|",5)=PSOXN_CS_$S($G(UNIT)'="":$G(UNIT),1:"""""")_CS_"99PSU"
+ S POIPTR=$P($G(^PSRX(IRXN,"OR1")),"^") I POIPTR S PODOSE=$P($G(^PS(50.7,POIPTR,0)),"^",2),PODOSENM=$G(^PS(50.606,PODOSE,0))
+ S POIPTR=$P($G(^PSRX(IRXN,"OR1")),"^")
+ I POIPTR S PODOSE=$P($G(^PS(50.7,POIPTR,0)),"^",2),PODOSENM=$G(^PS(50.606,PODOSE,0))
  I '$G(POIPTR) S PODOSE=$P($G(^PS(50.7,$P($G(^PSDRUG(IDGN,2)),"^"),0)),"^",2),PODOSENM=$G(^PS(50.606,PODOSE,0))
  S TRADENM=$G(^PSRX(IRXN,"TN"))
  S $P(RXE,"|",6)=PODOSE_CS_PODOSENM_CS_"99PSF"
  S $P(RXE,"|",8)=MP
+ S $P(RXE,"|",9)=TRADENM_
+ ;
+ ; 3080129 - RCR
+ ; Segment 9 is incomplete, truncated.
+ ; S $P(RXE,"|",9)=TRADENM_
+ S $P(RXE,"|",9)=TRADENM
  S $P(RXE,"|",15)=$P(^PSRX(IRXN,0),"^")
  S ^TMP("PSO",$J,PSI)="RXE|"_RXE,PSI=PSI+1
+ Q
+ QUIT
+ ;  =========
 RXD(PSI) ;pharmacy dispense segment
+ Q:'$D(DFN)
+ QUIT:'$D(DFN)
+ ;
  N RXD S RXD=""
  S $P(RXD,"|",1)=$S($G(NFLD):NFLD,1:0)
 …
  S $P(RXD,"|",7)=$P(^PSRX(IRXN,0),"^")
  S $P(RXD,"|",9)=RELDT_RS_BINGO_RS_PSONDC
+ Q
+ QUIT
+ ;  ========

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW.m

-              r628
+              r636
 PSORENW ;BIR/SAB-renew main driver ;4/25/07 8:42am
  ;;7.0;OUTPATIENT PHARMACY;**11,27,30,46,71,96,100,130,148,206**;DEC 1997;Build 39
+PSORENW ;BIR/SAB-renew main driver ;07/07/96
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,30,46,71,96,100,130,148**;DEC 1997
  ;External reference to ^PSDRUG supported by DBIA 221
  ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
 …
  I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" Q "0^Drug is No longer used by Outpatient Pharmacy."
  I $G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) Q "0^This Drug has been Inactivated."
+ 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.")
+ I $P(PSODRUG0,"^",3)["A",$P(PSODRUG0,"^",3)'["B" Q "0^Non-Renewable Drug Narcotic."
+ I $P(PSODRUG0,"^",3)["W" Q "0^Non-Renewable Drug."
  I $D(^PS(53,+$P(RX0,"^",3),0)),'$P(^(0),"^",5) Q "0^Non-Renewable Prescription."
  S PSOLC=$P(RX0,"^"),PSOLC=$E(PSOLC,$L(PSOLC)) I $A(PSOLC)'<90 Q "0^Max number of renewals (26) has been reached."

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW0.m

-              r628
+              r636
 PSORENW0 ;IHS/DSD/JCM-renew main driver continuation ;4/24/07 9:05am
  ;;7.0;OUTPATIENT PHARMACY;**11,27,32,59,64,46,71,96,100,130,237,206**;DEC 1997;Build 39
+PSORENW0 ;IHS/DSD/JCM-renew main driver continuation ;2/8/06 8:40am
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,32,59,64,46,71,96,100,130,237**;DEC 1997
  ;External reference to ^PS(50.7 supported by DBIA 2223
  ;External reference to ^PSDRUG supported by DBIA 221
 …
+ ;
  S (PSOS,PSOX,PSOY)="" K ACOM,DIR,DIRUT,DIRUT,DUOUT
  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
+ 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
  . S PSORENW("DFLG")=1
  . W !,$C(7),"Cannot renew Rx # ",$P(PSORENW("RX0"),"^")

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52.m

-              r628
+              r636
+PSORN52 ;BIR/DSD - files renewal entries in prescription file ;08/09/93
+ ;;7.0;OUTPATIENT PHARMACY;**1,11,27,37,46,79,71,100,117,157,143,219,148,239,201**;DEC 1997
+PSORN52 ;BIR/DSD - files renewal entries in prescription file ; 3/11/07 4:42pm
+ ;;7.0;OUTPATIENT PHARMACY;**1,11,27,37,46,79,71,100,117,157,143,219,148,239,201,208**;DEC 1997;Build 39
+ ; Modified from FOIA VistA
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;Ext ref to ^PS(55 sup by DBIA 2228
  ;Ext ref to PSOUL^PSSLOCK sup by DBIA 2789
 …
  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
  ;I PSOSCP>49!($P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)=1) S PSOFLAG=0 D SC^PSOMLLD2
+ I PSOAFYN="Y" G AFIN ;vfah
  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
  I $$DT^PSOMLLDT D
 …
  I $G(PSONEW("NEWCOPAY")) S ^PSRX(PSOX("IRXN"),"IB")=PSONEW("NEWCOPAY")
+ ;
+ D FINISH,ACP^PSOUTIL
+AFIN D FINISH,ACP^PSOUTIL ;vfah copay not evaluated by Autofinish,Rx
+ ;
  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"))

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORX1.m

-              r628
+              r636
+PSORX1 ;BIR/SAB-medication processing driver ;3/28/05 1:14pm
+ ;;7.0;OUTPATIENT PHARMACY;**7,22,23,57,62,46,74,71,90,95,115,117,146,139,135,182,195,233,268**;DEC 1997;Build 9
+PSORX1 ;BIR/SAB-medication processing driver ; 1/7/07 3:32pm
+ ;;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
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External reference PDA^PPPPDA1 supported by DBIA 1374
  ;External reference ^PS(55 supported by DBIA 2228
 …
  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
  ;PSO*195 move SSN write to here and add DISPPRF call
  S SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")
  W " ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")" K SSN
+ D ^VADPT W !!?10,$C(7),PSORX("NAME") ; correction for VOE
+ W " ",VA("PID") ; Correction with VOE, VA shouldn't be using SSN here!
  S PSONOAL="" D ALLERGY^PSOORUT2 D  I PSONOAL'="" D PAUSE
  .I PSONOAL'="" W !,$C(7),"     No Allergy Assessment!"

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXDL.m

-              r628
+              r636
 PSORXDL ;BIR/SAB - Deletes one prescription ;06/10/96
  ;;7.0;OUTPATIENT PHARMACY;**4,17,9,27,117,131,148,201,291**;DEC 1997;Build 2
+ ;;7.0;OUTPATIENT PHARMACY;**4,17,9,27,117,131,148,201**;DEC 1997
  ;External reference to ^PS(55 supported by DBIA 2228
  ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
 …
  I '$D(^XUSEC("PSORPH",DUZ)) W !,$C(7),"Requires Pharmacy Key (PSORPH) !" Q
  I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"SITE PARAMETERS MUST BE DEFINED!",! Q
+ 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") I $G(DA)<1 G KILL
+ 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
  D FULL^VALM1
  S RXN=+$G(DA)

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXED.m

-              r628
+              r636
 PSORXED ;IHS/DSD/JCM-edit rx utility ; 5/18/07 2:53pm
  ;;7.0;OUTPATIENT PHARMACY;**2,16,21,26,56,71,125,201,246**;DEC 1997;Build 12
+PSORXED ;IHS/DSD/JCM-edit rx utility ;02/18/98  3:14 PM
+ ;;7.0;OUTPATIENT PHARMACY;**2,16,21,26,56,71,125,201**;DEC 1997
  ;External reference to ^PSXEDIT supported by DBIA 2209
  ;External reference to ^DD(52 supported by DBIA 999
 …
 L1 D LOG,POST
 PROCESSX Q
 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
+CHECK 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
  I $G(^PSDRUG($P(PSORXED("RX0"),"^",6),"I"))]"",^("I")<DT D  G CHECKX
  . W !,$C(7),"This drug has been inactivated. ",! S PSORXED("DFLG")=1 Q
 …
  I $L(PSORX("PSOL",PSOX2))+$L(PSORXED("IRXN"))<220 D  G LOGX
  .I PSORX("PSOL",PSOX2)'[PSORXED("IRXN")_"," S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSORXED("IRXN")_"," D SETRP
  E  I $G(PSORX("PSOL",PSOX2+1))'[PSORXED("IRXN")_"," S PSORX("PSOL",PSOX2+1)=PSORXED("IRXN")_"," D SETRP   ;;PSO*7*246
+ E  I PSORX("PSOL",PSOX2+1)'[PSORXED("IRXN")_"," S PSORX("PSOL",PSOX2+1)=PSORXED("IRXN")_"," D SETRP
 LOGX K PSOEDITF,PSOEDITR,PSOEDITL D:$G(RFED) ^PSORXED1
+ Q

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL.m

-              r628
+              r636
+PSORXL ;BHAM ISC/SAB - action to be taken on prescriptions ;03/01/96  9:35
+ ;;7.0;OUTPATIENT PHARMACY;**8,21,24,32,47,135,148**;DEC 1997
+ ;External reference to File #50 supported by DBIA 221
+ ;External references CHPUS^IBACUS and TRI^IBACUS supported by DBIA 2030
+PSORXL ;BHAM ISC/SAB - action to be taken on prescriptions ;3/13/07  19:21
+ ;;7.0;OUTPATIENT PHARMACY;**8,21,24,32,47,135,148,208**;DEC 1997;Build 39
+ ; Modified from FOIA VistA
+ ; Copyright (C) GNU GPL 2007 WorldVistA
+ ;
+ ;Ext ref to File #50 supported by DBIA 221
+ ;Ext refs CHPUS^IBACUS and TRI^IBACUS supported by DBIA 203
  I $G(PSOTRVV),$G(PPL) S PSORX("PSOL",1)=PPL K PPL
  N SLBL,PSOSONE,PSOKLRXS
  S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$P(PSOPAR,"^",26) P
 LBL W !! S DIR("A",1)="Label Printer: "_$S($G(SUSPT):PSLION,1:$G(PSOLAP))
+LBL I $G(PSOAFYN)'="Y" W !! S DIR("A",1)="Label Printer: "_$S($G(SUSPT):PSLION,1:$G(PSOLAP))
  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 "
  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"
 …
  S DIR("?",5)="Enter 'C' to select another label printer"
  S:$P(PSOPAR,"^",26) DIR("?",5)="Enter 'L' to print labels without queuing"
 TRI ;Tricare
+TRI ;
  S X="IBACUS" X ^%ZOSF("TEST") K X I '$T G PASS
  I '$$TRI^IBACUS() G PASS
 …
  I '$D(^TMP($J,"PSOBILL")) K ^TMP($J,"PSONOB") G PASS
  I '$D(^TMP($J,"PSONOB")),$D(^TMP($J,"PSOBILL")) S (Y,LBL)="H" G H1
  ;If some Rx's are billable, and some are not
+ ;
 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
  .I $G(PSORX("PSOL",1))="" S PSORX("PSOL",1)=TRIRX_"," Q
 …
  K ^TMP($J,"PSONOB") S PPL=$G(PSORX("PSOL",1))
 PASS ;
+ I $E($G(DIR("A")),1,6)'="LABEL:" D RESDIR^PSOCPTRI
+ 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
+ .I $D(DIRUT)!($D(DUOUT)) D AL^PSOLBL("UT") I $G(PSOEXREP) S PSOEXREX=1
+ .I $G(PSOPULL) I $D(DIRUT)!($D(DUOUT)) S PSOQFLAG=1
+ I $G(PSOAFYN)'="Y" I $E($G(DIR("A")),1,6)'="LABEL:" D RESDIR^PSOCPTRI
+ 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
+ .I $G(PSOAFYN)'="Y" I $D(DIRUT)!($D(DUOUT)) D AL^PSOLBL("UT") I $G(PSOEXREP) S PSOEXREX=1
+ .I $G(PSOAFYN)'="Y" I $G(PSOPULL) I $D(DIRUT)!($D(DUOUT)) S PSOQFLAG=1
+ I $G(PSOAFYN)="Y" S PSOLAP=$G(^SC(+ORL,"AFRXCLINPRNT"))
+ I $G(PSOAFYN)="Y" I PSOLAP="" S DIRUT="^" G:$D(DIRUT)!($D(DUOUT)) EX
+ I $G(PSOAFYN)="Y" S PSOLAP=$P(^%ZIS(1,PSOLAP,0),"^",1)
  S:$G(PSOBEDT) NOPP=Y
  I $G(Y)="C" K PSOCLBL,%ZIS("B") S PSOCLBL=1 D @$S('$D(PSOPAR):"^PSOLSET",1:"PLBL^PSOLSET") K PSOCLBL G LBL
 …
  D ^%ZISC S PSL=0
 QLBL I $G(PSXSYS),('$G(RXLTOP)),('$G(PSOEXREP)) D RXL^PSOCMOP G:'$G(PPL) D1
+ ;
  ;- Submitting list of Rx to ECME for DUR/79 REJECT check and possible submission to 3rd Pary Payer
  D ECME^PSORXL1
+ I $G(PSOAFYN)'="Y" D ECME^PSORXL1 ;vfah
+ ;
  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
  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)=""
+ S ZTSAVE("PSOAFDFN")="",ZTSAVE("PSOAFDUZ")="",ZTSAVE("PSOAFYN")="",ZTSAVE("PSOAFPAT")="",ZTSAVE("PSOAFPNM")="",ZTSAVE("VFASDD")="",ZTSAVE("ORL")="" ;vfah
  S ZTSAVE("PSORX(")="",ZTSAVE("RXRP(")="",ZTSAVE("RXPR(")="",ZTSAVE("RXRS(")="",ZTSAVE("RXFL(")="",ZTSAVE("PCOMH(")=""
  D ^%ZISC,^%ZTLOAD K:$G(PSOSONE) RXRS W:$D(ZTSK)&('$G(SUSPT))&('$G(PSOEXREP)) !!,"LABEL(S) QUEUED TO PRINT",!!

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL1.m

-              r628
+              r636
 PSORXL1 ;BIR/SAB-action to be taken on prescriptions ; 10/5/07 2:40pm
  ;;7.0;OUTPATIENT PHARMACY;**36,46,148,260,274**;DEC 1997;Build 8
+PSORXL1 ;BIR/SAB-action to be taken on prescriptions ;03/01/96
+ ;;7.0;OUTPATIENT PHARMACY;**36,46,148,260**;DEC 1997;Build 84
 S S SPPL="",PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1)) G:$G(PPL)']"" D1
 S1 F PI=1:1 Q:$P(PPL,",",PI)=""  S DA=$P(PPL,",",PI) D
 …
  K COMM
 SUSQ Q
+ ;PSO*7*274 allways recalculate RXF
+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
+ACT 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
  S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA  S IR=FDA
  S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXPA1.m

-              r628
+              r636
+PSORXPA1 ;BIR/SAB - listman partial prescriptions ;07/14/93
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,56,77,130,152,181,174**;DEC 1997
+PSORXPA1 ;BIR/SAB - listman partial prescriptions ; 1/15/07 5:42pm
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,56,77,130,152,181,174,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External references L,UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
  ;External reference to ^PSDRUG supported by DBIA 221
  ;External reference to ^DD(52 supported by DBIA 999
+ S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
+ D ^DIC K DIC ;vfah
+ S PSOZAF=+Y  ;vfah Quits if AUTOFINISH,RX not a user
+ I $P($G(^PSRX(RXN,"OR1")),"^",5)=$G(PSOZAF) S VALMBCK="",VALMSG="Partial option is not available for Autofinshed Rxs" K PSOZAF Q  ;vfah
  I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!" Q
  ;I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial has already been requested!" Q

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRP1.m

-              r628
+              r636
+PSORXRP1 ;BIR/SAB-rx speed reprint listman ;03/06/95
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,120,156,148**;DEC 1997
+PSORXRP1 ;BIR/SAB-rx speed reprint listman ; 12/10/06 9:50pm
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,120,156,148,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
 SEL N PSODISP,VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
 …
+ ;
 RX ;process reprint request
+ ;
+ S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
+ D ^DIC K DIC ;vfah
+ S PSOZAF=+Y ;vfah
+ 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
+ ;
  Q:$P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^")>11
  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

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRP2.m

-              r628
+              r636
+PSORXRP2 ;BIR/SAB-main menu entry reprint of a Rx label ;10/5/07 7:45am
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,120,138,135,156,185,280**;DEC 1997;Build 5
+PSORXRP2 ;BIR/SAB-main menu entry reprint of a Rx label ; 12/10/06 9:51pm
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,120,138,135,156,185,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
  ;External reference ^PS(55 supported by DBIA 2228
 …
  S (PPL,DA,RX,PSORPRX)=+Y,PDA=Y(0),RXF=0,ZD(DA)=DT,REPRINT=1,STA=+$G(^PSRX(+Y,"STA"))
  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
+ S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
+ D ^DIC K DIC ;vfah
+ S PSOZAF=+Y ;vfah
+ I $P(^PSRX(RX,"OR1"),"^",5)=$G(PSOZAF) W $C(7),!,"Cannot Reprint Labels for Autofinished Rxs" D ULR,KILL Q  ;vfah
  I $P(^PSRX(RX,"STA"),"^")=14 W $C(7),!,"Cannot Reprint! Discontinued by Provider." D ULR,KILL Q
  I $P(^PSRX(RX,"STA"),"^")=15 W $C(7),!,"Cannot Reprint! Discontinued due to editing." D ULR,KILL Q
 …
  E  D EN3^PSOUTLA1(DA,75) S D=0 F  S D=$O(BSIG(D)) W !,BSIG(D) Q:'$O(BSIG(D))
  K D,BSIG
+ ;PSO*7*280 If Trade name, don't lookup in ^PSDRUG
+ 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
+ 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
  W ?25,$S($D(^VA(200,+P(16),0)):$P(^(0),"^"),1:"Unknown"),!,"# of Refills: "_$G(P(9))
  I $G(RX) D

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRPT.m

-              r628
+              r636
+PSORXRPT ;BIR/SAB-reprint of a prescription label ;9/20/07 9:40am
+ ;;7.0;OUTPATIENT PHARMACY;**3,21,27,34,120,138,156,148,280**;DEC 1997;Build 5
+PSORXRPT ;BIR/SAB-reprint of a prescription label ; 12/10/06 8:42pm
+ ;;7.0;OUTPATIENT PHARMACY;**3,21,27,34,120,138,156,148,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External reference to ^PSDRUG supported by DBIA 221
  ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
 …
  .S RX=$P(PSOLST(ORN),"^",2) D VALID^PSORXRP1 S:$G(QFLG) VALMBCK="",VALMSG="A New Label has been requested already!"
  S (PPL,DA,RX)=+Y,PDA=Y(0),RXF=0,ZD(DA)=DT,REPRINT=1,STA=+$G(^PSRX(+Y,"STA"))
+ ;
+ S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
+ D ^DIC K DIC ;vfah
+ S PSOZAF=+Y ;vfah
+ 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
+ ;
  I $P(^PSRX(RX,"STA"),"^")=14 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued by Provider.",QFLG=1 D ULR,KILL Q
  I $P(^PSRX(RX,"STA"),"^")=15 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued due to editing.",QFLG=1 D ULR,KILL Q
 …
  E  D EN3^PSOUTLA1(DA,75) S D=0 F  S D=$O(BSIG(D)) W !,BSIG(D) Q:'$O(BSIG(D))
  K D,BSIG
+ ;PSO*7*280 If trade name is used Stop the DRUG Lookup.
+ 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
+ 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
  W ?25,$S($D(^VA(200,+P(16),0)):$P(^(0),"^"),1:"Unknown"),!,"# of Refills: "_$G(P(9))
  I $G(RX) S RXFL(RX)=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(RX,1,ZZZ)) Q:'ZZZ  S RXFL(RX)=ZZZ

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXVW.m

-              r628
+              r636
 PSORXVW ;BHAM ISC/SAB - listman view of a prescription ;5/25/05 2:10pm
  ;;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
+ ;;7.0;OUTPATIENT PHARMACY;**14,35,46,96,103,88,117,131,146,156,185,210,148,233,260,264**;DEC 1997;Build 19
  ;External reference to File ^PS(55 supported by DBIA 2228
  ;External reference to ^PS(50.7 supported by DBIA 2223
 …
  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)_")"
  S:$P($G(^PSRX(DA,"PKI")),"^") VALMSG="Digitally Signed Order"
  D EN^PSOORAL,KILL I $G(PS)="VIEW" G PSORXVW
+ D EN^PSOORAL,KILL G:PS="VIEW" PSORXVW
+ Q
+ ;
 KILL K ^TMP("PSOAL",$J),PSOAL,IEN,^TMP("PSOHDR",$J) I $G(PS)="VIEW" K DA
+KILL K ^TMP("PSOAL",$J),PSOAL,IEN,^TMP("PSOHDR",$J) K:PS="VIEW" DA
  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
  K LBL,I,RFDATE,%H,%I,RN,RFT,%,%I,DFN,GMRA,GMRAL,HDR,POERR,PTST,REFL,RF,RLD,RX3

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXVW1.m

-              r628
+              r636
 PSORXVW1 ;BIR/SAB-view prescription con't ; 12/4/07 12:28pm
  ;;7.0;OUTPATIENT PHARMACY;**35,47,46,71,99,117,156,193,210,148,258,260,240,281**;DEC 1997;Build 41
+PSORXVW1 ;BIR/SAB-view prescription con't ;5/26/05 10:07am
+ ;;7.0;OUTPATIENT PHARMACY;**35,47,46,71,99,117,156,193,210,148,258,260**;DEC 1997;Build 84
  ;External reference to ^DD(52 supported by DBIA 999
  ;External reference to ^VA(200 supported by DBIA 10060
 …
  .I $P(P1,"^",5)]"" N PSOACBRK,PSOACBRV D
  ..S PSOACBRV=$P(P1,"^",5)
+ ..;PSO*7*240 Use fileman to format
+ ..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))
+ ..I $L(PSOACBRV)<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_PSOACBRV Q
+ ..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
+ ..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
  .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)
  .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
  ..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)
+ K MIG,SG,I,^UTILITY($J,"W"),DIWF,DIWL,DIWR
+ Q
+ K MIG,SG,I Q
 LBL ;label log
  S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Label Log:"
 …
+ ;
 HLP ; Help Text for the VIEW PRESCRIPTION prompt
+ W !," A prescription number or ECME # may be entered.  The ECME"
+ W !," number must be entered in E.NNNNNNN format, where NNNNNNN"
+ W !," is the prescription ECME # (example: E.0289332).  Or just"
+ W !," You may enter E.NNNNNNN, where NNNNNNN is the"
+ W !," prescription ECME# (e.g., E.0289332) or,"
  D LKP("?")
+ Q

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSD0.m

-              r628
+              r636
 PSOSD0 ;BHAM ISC/SAB - action or informational profile cont. ;6/21/07 8:20am
  ;;7.0;OUTPATIENT PHARMACY;**2,19,40,66,107,110,258,206**;DEC 1997;Build 39
+PSOSD0 ;BHAM ISC/SAB - action or informational profile cont. ;3/24/93
+ ;;7.0;OUTPATIENT PHARMACY;**2,19,40,66,107,110,258**;DEC 1997;Build 4
  ;External reference to ^PS(50.605 supported by DBIA 696
  ;External reference to ^SC supported by DBIA 10040
 …
  I 'PSTYPE D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") ^PSOLAB G RXN2
  G:$G(DOD(DFN))]"" RXN2
  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
+ 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
  S PSOIFSUP=$S(PSODEA']"":0,PSODEA["S":1,1:0),RXX=$P(RX0,"^"),RXX(1)="",RXX=$O(^PSRX("B",RXX,RXX(1)))
  W:$P($G(^PSRX(RXX,"IB")),"^") !?11,"****COPAY****" D PSRENW^PSOSD2
 …
  I 'PSTYPE D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") ^PSOLAB G RXN2
  G:$G(DOD(DFN))]"" RXN3
  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
+ 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
  S PSOIFSUP=$S(PSODEA']"":0,PSODEA["S":1,1:0),RXX=$P(RX0,"^"),RXX(1)="",RXX=$O(^PSRX("B",RXX,RXX(1)))
  W:$P($G(^PSRX(RXX,"IB")),"^") !?11,"****COPAY****" D PSRENW^PSOSD2

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSD1.m

-              r628
+              r636
 PSOSD1 ;BHAM ISC/SAB/JMB - action or informational profile cont. ; 10/30/07 10:39am
  ;;7.0;OUTPATIENT PHARMACY;**2,17,19,22,40,49,66,107,110,132,233,258,240**;DEC 1997;Build 5
+PSOSD1 ;BHAM ISC/SAB/JMB - action or informational profile cont. ;11/18/92
+ ;;7.0;OUTPATIENT PHARMACY;**2,17,19,22,40,49,66,107,110,132,233,258**;DEC 1997;Build 4
  ;External reference to ^PS(59.7 is supported by DBIA 694
+ ;
 …
  D KVA^VADPT K DOD,FILL,DIC,PSCNT,PSDT,PCLASS,PHYS,ZCLASS,PSOPRINT,RXNODE,DIR,X1,X2,PSONUM,PSOPOLP,PSSN4
+ Q
+ ;
+ ;
 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."
  D ^DIR Q:$D(DTOUT)!($D(DUOUT))  S PSDAYS=X K DIR S X1=DT,X2=-PSDAYS D C^%DTC S (PSDATE,PSDAY)=X
 …
  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"
  D ^DIR G:Y="E"!($D(DUOUT))!($D(DIRUT)) EXIT S PSORM=$S(Y=1:1,1:0) K DIR,X,Y
+ ;PSO*7*240 Go to exit if DUOUT or DTOUT
+ASK D DAYS G:($D(DUOUT))!($D(DTOUT)) EXIT S PRF=PSODFN_"," D DEV I $D(ZTSK) S VALMSG="Action Profile Queued to Printer."
+ASK D DAYS S PRF=PSODFN_"," D DEV I $D(ZTSK) S VALMSG="Action Profile Queued to Printer."
  D EXIT K LM
+ Q

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSIGMX.m

-              r628
+              r636
 PSOSIGMX ;BIR/RTR-Utility routine to calculate Max Refills for CPRS ; 7/25/07 11:17am
  ;;7.0;OUTPATIENT PHARMACY;**46,78,108,131,222,206**;DEC 1997;Build 39
+PSOSIGMX ;BIR/RTR-Utility routine to calculate Max Refills for CPRS ;12/28/00
+ ;;7.0;OUTPATIENT PHARMACY;**46,78,108,131,222**;DEC 1997;Build 12
  ;External reference to PS(55 supported by DBIA 2228
  ;External reference to PSDRUG( supported by DBIA 221
 …
  .I PSOCDEA["2"!(PSOCDEA["3")!(PSOCDEA["4")!(PSOCDEA["5") S PSOCSX=1
  I PSOCSX D
  .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)
+ .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)
  .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)
  I 'PSOCSX!('$G(PSOQX("DRUG"))) D
 …
  .S PSOMXPAT=$O(^YSCL(603.01,"C",+$G(PSOQX("PATIENT")),0)) I 'PSOMXPAT S PSOQX("MAX")=0 Q
  .S PSOMXPAT=$P($G(^YSCL(603.01,PSOMXPAT,0)),"^",3)
  .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
+ .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
  .S PSOQX("MAX")=$S(PSOMXPAT="M":3,PSOMXPAT="B":1,1:0)
  I $G(PSOQX("DRUG")) I PSOCDEA["A"&(PSOCDEA'["B")!(PSOCDEA["F")!(PSOCDEA[1)!(PSOCDEA[2) S PSOQX("MAX")=0
+ I $G(PSOQX("DRUG")) I PSOCDEA["A"&(PSOCDEA'["B")!(PSOCDEA["F") S PSOQX("MAX")=0
  I PSONODD S PSOQX("DRUG")=0
+ Q

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSUPOE.m

-              r628
+              r636
 PSOSUPOE ;BIR/RTR - Suspense pull via Listman ;3/1/96
  ;;7.0;OUTPATIENT PHARMACY;**8,21,27,34,130,148,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**8,21,27,34,130,148**;DEC 1997
  ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
 SEL I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
 …
  . D ECMESND^PSOBPSU1(RXREC,RFL,,"PP")
  . I $$FIND^PSOREJUT(RXREC,RFL) D
  . . S ACTION=$$HDLG^PSOREJU1(RXREC,RFL,"79,88","PP","IOQ","Q")
+ . . S ACTION=$$HDLG^PSOREJU1(RXREC,RFL,"79,88","PP","IOQ","I")
+ ;
  D ULRX K PSOGET,PSOGETF

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOTPCAN.m

-              r628
+              r636
+PSOTPCAN ;BIR/RTR - TPB Utility routine ;08/23/03
+ ;;7.0;OUTPATIENT PHARMACY;**146,153,163,227**;DEC 1997
+PSOTPCAN ;BIR/RTR - TPB Utility routine ;3/13/07  21:21
+ ;;7.0;OUTPATIENT PHARMACY;**146,153,163,227,208**;DEC 1997;Build 39
+ ; Modified from FOIA VistA
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External reference to PS(55 supported by DBIA 2228
  ;External reference to VA(200 supported by DBIA 224
 …
  . S PSOTPWR1=$P($G(^PSRX(+$P(^PS(52.41,PSOTPWRN,0),"^",21),0)),"^",3)
  . S PSOTPWR2=$P($G(^PS(53,+PSOTPWR1,0)),"^"),PSOTPWR3=$$UP^XLFSTR(PSOTPWR2)
  . I PSOTPWR3="NON-VA" D
+ . I PSOTPWR3="NON-VA",DUZ("AG")="V" D  ; Skip for VOE sites
  . . 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
  . . Q
 …
  S PSOTPWR1=$P($G(^PS(55,+$P($G(^PS(52.41,PSOTPWRN,0)),"^",2),"PS")),"^")
  S PSOTPWR2=$P($G(^PS(53,+PSOTPWR1,0)),"^") S PSOTPWR3=$$UP^XLFSTR(PSOTPWR2)
  I PSOTPWR3="NON-VA" D
+ I PSOTPWR3="NON-VA",DUZ("AG")="V" D  ; Skip for VOE sites
  .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
+ Q

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOUTLA1.m

-              r628
+              r636
 PSOUTLA1 ;BHAM ISC/RTR-Pharmacy utility program cont. ;5/22/07 10:01am
  ;;7.0;OUTPATIENT PHARMACY;**35,186,218,259,206**;DEC 1997;Build 39
+PSOUTLA1 ;BHAM ISC/RTR-Pharmacy utility program cont. ;10/20/06 3:44pm
+ ;;7.0;OUTPATIENT PHARMACY;**35,186,218,259**;DEC 1997;Build 5
  ;External reference to File ^PS(55 supported by DBIA 2228
  ;External reference to File ^PSDRUG supported by DBIA 221
 …
+ ;
  ;no refills if PSDEA = 'A' & not 'B' or 'F',
  I (PSDEA["A")&(PSDEA'["B")!(PSDEA["F")!(PSDEA[1)!(PSDEA[2) D  Q 1
+ I (PSDEA["A")&(PSDEA'["B")!(PSDEA["F") D  Q 1
  . S PSMAXRF=$$NUMFILLS(PSIRXN)
+ ;

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOVER1.m

-              r628
+              r636
 PSOVER1 ;BHAM ISC/SAB - verify one rx ;3/9/05 12:53pm
  ;;7.0;OUTPATIENT PHARMACY;**32,46,90,131,202,207,148,243,268,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**32,46,90,131,202,207,148,243,268**;DEC 1997;Build 9
  ;External reference ^PSDRUG( supported by DBIA 221
  ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
 …
  . S ACTION="" D ECMESND^PSOBPSU1(PSONV,,,$S($O(^PSRX(PSONV,1,0)):"RF",1:"OF"))
  . I $$FIND^PSOREJUT(PSONV) D
  . . S ACTION=$$HDLG^PSOREJU1(PSONV,0,"79,88","OF","IOQ","Q")
+ . . S ACTION=$$HDLG^PSOREJU1(PSONV,0,"79,88","OF","IOQ","I")
+ ;
 KILL S DA=PSONV,DIK="^PS(52.4," D ^DIK K DA,DIK D DCORD^PSONEW2

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA.m

r628	r636
1		PSOXZA ; DRIVER FOR COMPILED XREFS FOR FILE #52 ; 0~~5/26~~/08
	1	PSOXZA ; DRIVER FOR COMPILED XREFS FOR FILE #52 ; 01/17/08
2	2	;
3	3	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

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA1.m

-              r628
+              r636
 PSOXZA1 ; COMPILED XREF FOR FILE #52 ; 05/26/08
+PSOXZA1 ; COMPILED XREF FOR FILE #52 ; 01/17/08
+ ;
  S DIKZK=2
 …
  . S:$D(DIKIL) (X2,X2(1))=""
  . K ^PSRX("APKI",$E(X,1,30),DA)
 CR3 S DIXR=461
+CR3 S DIXR=476
  K X
  S DIKZ(0)=$G(^PSRX(DA,0))

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA10.m

r628	r636
1		PSOXZA10 ; COMPILED XREF FOR FILE #52.052311 ; 0~~5/26~~/08
	1	PSOXZA10 ; COMPILED XREF FOR FILE #52.052311 ; 01/17/08
2	2	;
3	3	S DA=0

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA11.m

-              r628
+              r636
 PSOXZA11 ; COMPILED XREF FOR FILE #52.1 ; 05/26/08
+PSOXZA11 ; COMPILED XREF FOR FILE #52.1 ; 01/17/08
+ ;
  S DA=0
 …
  S X=$P(DIKZ(0),U,18)
  I X'="" I +$G(^PSRX(DA(1),"IB")) K:$P($G(^PSRX(DA(1),1,DA,0)),"^")&($P($G(^(0)),"^",18)) ^PSRX("ACP",$P(^PSRX(DA(1),0),"^",2),$P(^PSRX(DA(1),1,DA,0),"^"),DA,DA(1))
 CR1 S DIXR=462
+CR1 S DIXR=477
  K X
  S X(1)=$P(DIKZ(0),U,10)

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA12.m

-              r628
+              r636
 PSOXZA12 ; COMPILED XREF FOR FILE #52.2 ; 05/26/08
+PSOXZA12 ; COMPILED XREF FOR FILE #52.2 ; 01/17/08
+ ;
  S DA=0
 …
  S X=$P(DIKZ(0),U,19)
  I X'="" S ^PSRX("AM",$E(X,1,30),DA(1),DA)=""
 CR1 S DIXR=463
+CR1 S DIXR=478
  K X
  S X(1)=$P(DIKZ(0),U,10)

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA13.m

-              r628
+              r636
 PSOXZA13 ; COMPILED XREF FOR FILE #52.25 ; 05/26/08
+PSOXZA13 ; COMPILED XREF FOR FILE #52.25 ; 01/17/08
+ ;
  S DA=0
 …
  S X=$P(DIKZ(0),U,1)
  I X'="" S ^PSRX(DA(1),"REJ","B",$E(X,1,30),DA)=""
 CR1 S DIXR=652
+CR1 S DIXR=224
  K X
  S X(1)=$P(DIKZ(0),U,2)
 …
  . K X1,X2 M X1=X,X2=X
  . S ^PSRX("REJDAT",X,DA(1),DA)=""
 CR2 S DIXR=653
+CR2 S DIXR=225
  K X
  S DIKZ(0)=$G(^PSRX(DA(1),"REJ",DA,0))

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA14.m

r628	r636
1		PSOXZA14 ; COMPILED XREF FOR FILE #52.2551 ; 0~~5/26~~/08
	1	PSOXZA14 ; COMPILED XREF FOR FILE #52.2551 ; 01/17/08
2	2	;
3	3	S DA(2)=DA(1) S DA(1)=0 S DA=0

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA2.m

r628	r636
1		PSOXZA2 ; COMPILED XREF FOR FILE #52.01 ; 0~~5/26~~/08
	1	PSOXZA2 ; COMPILED XREF FOR FILE #52.01 ; 01/17/08
2	2	;
3	3	S DA(1)=DA S DA=0

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA3.m

r628	r636
1		PSOXZA3 ; COMPILED XREF FOR FILE #52.052311 ; 0~~5/26~~/08
	1	PSOXZA3 ; COMPILED XREF FOR FILE #52.052311 ; 01/17/08
2	2	;
3	3	S DA=0

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA4.m

-              r628
+              r636
 PSOXZA4 ; COMPILED XREF FOR FILE #52.1 ; 05/26/08
+PSOXZA4 ; COMPILED XREF FOR FILE #52.1 ; 01/17/08
+ ;
  S DA=0
 …
  S X=$P(DIKZ(0),U,1)
  I X'="" I +$G(^PSRX(DA(1),"IB")) K:$P($G(^PSRX(DA(1),0)),"^",2)&($P($G(^PSRX(DA(1),1,DA,0)),"^",2)="W")&('$P($G(^(0)),"^",16))&('$P($G(^(0)),"^",18))&('$G(^("IB"))) ^PSRX("ACP",$P(^PSRX(DA(1),0),"^",2),X,DA,DA(1))
 CR1 S DIXR=462
+CR1 S DIXR=477
  K X
  S DIKZ(0)=$G(^PSRX(DA(1),1,DA,0))

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA5.m

-              r628
+              r636
 PSOXZA5 ; COMPILED XREF FOR FILE #52.2 ; 05/26/08
+PSOXZA5 ; COMPILED XREF FOR FILE #52.2 ; 01/17/08
+ ;
  S DA=0
 …
  S X=$P(DIKZ(0),U,1)
  I X'="" D:'$G(PSOSUSPA) PARKILL^PSOUTLA
 CR1 S DIXR=463
+CR1 S DIXR=478
  K X
  S X(1)=$P(DIKZ(0),U,10)

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA6.m

-              r628
+              r636
 PSOXZA6 ; COMPILED XREF FOR FILE #52.25 ; 05/26/08
+PSOXZA6 ; COMPILED XREF FOR FILE #52.25 ; 01/17/08
+ ;
  S DA=0
 …
  S X=$P(DIKZ(0),U,1)
  I X'="" K ^PSRX(DA(1),"REJ","B",$E(X,1,30),DA)
 CR1 S DIXR=652
+CR1 S DIXR=224
  K X
  S X(1)=$P(DIKZ(0),U,2)
 …
  . S:$D(DIKIL) (X2,X2(1))=""
  . K ^PSRX("REJDAT",X,DA(1),DA)
 CR2 S DIXR=653
+CR2 S DIXR=225
  K X
  S DIKZ(0)=$G(^PSRX(DA(1),"REJ",DA,0))

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA7.m

r628	r636
1		PSOXZA7 ; COMPILED XREF FOR FILE #52.2551 ; 0~~5/26~~/08
	1	PSOXZA7 ; COMPILED XREF FOR FILE #52.2551 ; 01/17/08
2	2	;
3	3	S DA(2)=DA(1) S DA(1)=0 S DA=0

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA8.m

-              r628
+              r636
 PSOXZA8 ; COMPILED XREF FOR FILE #52 ; 05/26/08
+PSOXZA8 ; COMPILED XREF FOR FILE #52 ; 01/17/08
+ ;
  S DIKZK=1
 …
  . K X1,X2 M X1=X,X2=X
  . I +$P($G(^PSRX(DA,"PKI")),"^")=1 S ^PSRX("APKI",$E(X,1,30),DA)=""
 CR3 S DIXR=461
+CR3 S DIXR=476
  K X
  S DIKZ(0)=$G(^PSRX(DA,0))

FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA9.m

r628	r636
1		PSOXZA9 ; COMPILED XREF FOR FILE #52.01 ; 0~~5/26~~/08
	1	PSOXZA9 ; COMPILED XREF FOR FILE #52.01 ; 01/17/08
2	2	;
3	3	S DA(1)=DA S DA=0

Context Navigation

Legend:

Download in other formats: