VEXRX ;MUSKOGEE VAMC/GLD - AUDIOFAX SUBROUTINE - 6-21-94
;;7.0;OUTPATIENT PHARMACY;**197,328**;JUN 1994
;
;Reference to ^ORAREN supported by IA #5498
;;PERFORM MUMPS AUDIOFAX REFILLS BY CALLING ^PSOBBC
;
; THIS IS COPY OF HOP'S VEXRX PLUS MY TWO SETS
;
;This routine is for Outpatient version 7 only
; Modify History:
; 06Jan2004; IHS; @1; Add Renewal Processing
; 30Apr2004; IHS; @2; Add N flag for not renewable
; Feb 2004; BFD/PVAMC ; Add RENFLG (used in later chk of global)
; 25Jun2004; BFD/PVAMC ; Add 'pass' of provider parameter & generic user DUZ
; 09July2004; BFD/PVAMC; Add call to send mail message to renewal mail group
; 03Aug2004; BFD/PVAMC ; Add RENFLG=0 to START because no data in global cause crash
; 10Aug 2004; BFD/PVAMC; Add CN1T=0 to START & put in END+1 because mail message not being sent
; 26Aug2004; BFD/PVAMC; Add ktrs for msg to 'mgr' mail group
; 29Aug2004; BFD/PVAMC; Add order prob kt
; 27Jan2006; @3; IHS; Merge Bay Pines changes with Portland Renewal code
; Feb-May 2006 ; BFD/PVAMC; New checks in VEX3 and VEX4 causes to skip renewal. Had to add new code to have recognized
; Apr-May 2006; BFD/PVAMC; New code in VEX3 to have program recognize renewal request and not skip
; 24-July 2006; BFD/PVAMC; Replace APUVEX call with APUVEX1 or APUVEX2, as appropirate. Had to split APUVEX due to size problem for SACC
; 05Dec 2006; BFD/PVAMC; Replace APUVEX1 call with APUVEX because reports that random requests not being handled correctly
; HAD TO REPLACE APUVEX1 AND APUVEX2 CALLS BECAUSE OF AN ERROR
; March, 2009; JLC/VM replace APU calls with call to CPRS API
; --------------------------------------------------------------------------------------
START S PSOVEX=1
; BFD/PVMAC 2-8-06 Add renewal variable Set (2 lines)
N PATIEN,PROVP,RENFLG,RESULT,USR,TOTREN,RXNUM,TOTF,EMCNT,INCNT
S RENFLG=0,CNT1=0,FBKTRDN=0,FBKTR=0,PTERMDN=0,PTERM=0,NPCPDN=0,NPCP=0,UNSKTR=0,INFPKTR=0,INFPDNKTR=0,NRF=0,RFY=0,MMCONT=0,PCONT=0,NRFLG=0,ORDP=0,ORDPDN=0
S HACT=0,HACTDN=0,NPCPADN=0,NPCPA=0,NDINACT=0,DINACT=0,MMDAT=0,DISDT=0,NDISDT=0
K ^TMP($J,"ORAREN E"),^TMP($J,"ORAREN OC") S (EMCNT,INCNT)=5,(TOTF,TOTREN)=0
;
K PSOVEXI,PSOISITE,PSOVEXFL
F PSOVX=0:0 S PSOVX=$O(^PS(59,PSOVX)) Q:'PSOVX I $P($G(^PS(59,PSOVX,"I")),"^"),DT>$P($G(^("I")),"^") S PSOVEXI(PSOVX)=""
I $O(PSOVEXI(0)) W !,"Looking for refill requests for inactive Outpatient divisions..." F PSOVIN=0:0 S PSOVIN=$O(^VEXHRX(19080,PSOVIN)) Q:'PSOVIN S PSOVXLP="" F S PSOVXLP=$O(^VEXHRX(19080,PSOVIN,PSOVXLP)) Q:PSOVXLP="" D
.S PSOISITE=$P($G(^PSRX(+$P(PSOVXLP,"-",2),2)),"^",9) Q:$G(PSOVEXI(+$G(PSOISITE)))
.I PSOISITE,$D(PSOVEXI(PSOISITE)),$G(^VEXHRX(19080,PSOVIN,PSOVXLP))="" S PSOVEXI(PSOISITE)=1,PSOVEXFL=1
I '$G(PSOVEXFL),$O(PSOVEXI(0)) W ".none found.",!
I $G(PSOVEXFL) W !!,"The following Inactive Outpatient sites have refill requests:",! F PSOVX=0:0 S PSOVX=$O(PSOVEXI(PSOVX)) Q:'PSOVX I $G(PSOVEXI(PSOVX)) W !?5,$P($G(^PS(59,+$G(PSOVX),0)),"^")
I $G(PSOVEXFL) K DIR W ! S DIR(0)="E",DIR("A")="Press Return to Continue, '^' to exit" D ^DIR W ! I Y'=1 G END
D:'$D(PSOPAR) ^PSOLSET G:'$D(PSOPAR) END
W !!!?20,"Division: "_$P(^PS(59,PSOSITE,0),"^"),!!
S PSOBBC1("FROM")="REFILL",PSOBBC("QFLG")=0,PSOBBC("DFLG")=0
I '$D(^VEXHRX(19080,PSOINST)) S VEXANS="N" W !!?7,$C(7),"There are no telephone refills to process." G END
D ASK^PSOBBC W:PSOBBC("QFLG")=1 !?7,$C(7),"No telephone refills were processed." G:PSOBBC("QFLG")=1 END
VEX W ! S DIR("B")="YES",DIR("A")="Process telephone refill requests at this time",DIR(0)="Y" D ^DIR K DIR S VEXANS="N" I $G(DIRUT) S VEXPTRX="" G END
G:Y=0 END S VEXPTRX="" I Y=1 S VEXANS="Y"
I VEXANS["Y" S DIR("B")="YES",DIR("A")="Process telephone refills for all divisions",DIR(0)="Y" D ^DIR K DIR S VEXANS2="S" S:Y=1 VEXANS2="M" I $G(DIRUT) S VEXANS="N" G END
; @3; Added Portland code to Bay Pines
S CNT1=10 ; BFD/PVMAC 7-9-04 use to indicate first time through for mail msg build
VEX6 I VEXANS["Y",$G(VEXPTRX) D VEX5 ;MARK PROCESSED NODES
D VEX3 I $G(VEXANS)="N" D ULK G END
I $P(X,"-")'=PSOINST W !?7,$C(7),$C(7),$C(7),"Not from this institution.",! D ULK G VEX6
; @3; Add Portland code to Bay Pines
I $L(RENEW) S RENEW="" G VEX6
S (PSOBBC("IRXN"),PSOBBC("OIRXN"))=$P(X,"-",2)
I $D(^PSRX(PSOBBC("IRXN"),0))']"" W !,$C(7),"Rx data is not on file!",! D ULK G VEX6
I $P($G(^PSRX(PSOBBC("IRXN"),"STA")),"^")=13 W !,$C(7),"Rx has already been deleted." D ULK G VEX6
I $G(PSOBBC("DONE"))[PSOBBC("IRXN")_"," W !,$C(7),"Rx has already been entered." D ULK G VEX6
K X,Y D:PSOBBC("QFLG") PROCESSX^PSOBBC
S PSOSELSE=0 I $G(PSODFN)'=$P(^PSRX(PSOBBC("IRXN"),0),"^",2) S PSOSELSE=1 D PT^PSOBBC I $G(PSOBBC("DFLG")) K PSOSELSE D ULK G VEX6
I '$G(PSOSELSE) D PTC^PSOBBC I $G(PSOBBC("DFLG")) K PSOSELSE D ULK G VEX6
K PSOSELSE D PROFILE^PSORX1 S X="PPPPDA1" X ^%ZOSF("TEST") I S X=$$PDA^PPPPDA1(PSODFN) W !!
S PSOBBC("DONE")=PSOBBC("IRXN")_"," D REFILL^PSOBBC D ULK G VEX6
Q
; BFD/648 4-27-06 Add VEX3+3 and chk of vex648, VEX4+0 so not skip renewal requests
VEX3 K PSOBBC("IRXN"),VEXXFLAG F S VEXPTRX=$O(^VEXHRX(19080,PSOINST,VEXPTRX)) D Q:VEXANS="N"!($G(VEXXFLAG))
. I VEXPTRX="" S VEXANS="N" Q
. S VEXREN=0,VEX648=0,VEXREN=$G(^VEXHRX(19080,PSOINST,VEXPTRX)) I VEXREN]"" D BFDRNCHK
. I '$D(^PSRX(+$P(VEXPTRX,"-",2),0)),VEX648=1 D VEX5 Q ;SKIPS ERRONEOUS ENTRIES
. ;I '$D(^PSRX(+$P(VEXPTRX,"-",2),0)),^VEXHRX(19080,PSOINST,VEXPTRX)="" D VEX5,VEX12 Q ;SKIPS ERRONEOUS ENTRIES
VEX4 .I VEXANS["Y" Q:VEX648=1 S X=PSOINST_"-"_$P(VEXPTRX,"-",2) ;SKIPS ENTRIES ALREADY PROCESSED AND FORMATS VARIABLE X (BFD/648 LINE)
.;I VEXANS["Y" Q:^VEXHRX(19080,PSOINST,VEXPTRX)'="" S X=PSOINST_"-"_$P(VEXPTRX,"-",2) ;SKIPS ENTRIES ALREADY PROCESSED AND FORMATS VARIABLE X (ORIG LINE)
VEX10 .I VEXANS2["S",$D(^PSRX(+$P(VEXPTRX,"-",2),0)),PSOSITE'=$P($G(^PSRX(+$P(VEXPTRX,"-",2),2)),"^",9) Q
. ;@3; Check at this point if this is a renewal request
. D RENEWCHK I RENEW]"" S VEXXFLAG=1 Q
. S VEXPSORX=+$P($G(VEXPTRX),"-",2) I VEXPSORX D PSOL^PSSLOCK(VEXPSORX) I '$G(PSOMSG) K VEXPSORX,PSOMSG Q
. K PSOMSG S VEXXFLAG=1
Q
; -----------------------------------------------------------------------------------
; @3; Added Portland code to Bay Pines
;LINES CALLED TO MARK PROCESSED NODES
;LINES CALLED TO MARK PROCESSED NODES
;PVMAC/BFD 2/04 Add RENFLG chk, If 1 then renewal & global already set so skip
;PVMAC/BFD 8-26-04 Add RFY and NRF ktrs to VEX5 and VEX12
;PVMAC/BFD 8-26-04 Add NRFLG
VEX5 ;
; Next statement is used by BFD/648 CHK PROGRESS THRU PROGRAM
;W !,"AT VEX5 and VEXXFLAG is "_VEXXFLAG
I RENFLG=0 S ^VEXHRX(19080,PSOINST,VEXPTRX)=DT D ;MARKS NODE AS PROCESSED
. I $G(PSOBBC("DFLG")) D VEX12 ;FLAGS UNSUCCESSFUL ATTEMPTS TO REFILL.
; @3
I NRFLG=0,(RENFLG=0) S RFY=RFY+1
S NRFLG=0
Q
VEX12 ;
; @3
S NRF=NRF+1,NRFLG=1
S $P(^VEXHRX(19080,PSOINST,VEXPTRX),U,2)="NOT FILLED"
W !!,$C(7),"REFILL WAS NOT PROCESSED! PLEASE TAKE APPROPRIATE ACTION."
W ! S DIR("A")="Do you wish to continue processing",DIR(0)="Y" D ^DIR K DIR I Y'=1 S VEXANS="N" Q
Q
END D PROCESSX^PSOBBC
; bfd/648 12-5-06 ; out all APUVEX1 and APUVEX2 calls & un ; out all APUVEX calls
; @3
; SMT If VEXANS2="S" then we are only looking at a single division and we add the division to the mail subject.
K XMY N XMDUZ,XMSUB,XMTEXT,XMT
S XMDUZ="AUTO,RENEWAL",XMY(DUZ)="",XMY("G.AUTORENEWAL")="",XMSUB=$S($G(VEXANS2)["S":$$GET1^DIQ(59,PSOSITE,.06)_" ",1:"")_"REFILL TOTALS",XMTEXT="XMT("
S XMT(1,0)="Refills Processed: "_RFY,XMT(2,0)="Refills 'Not Processed': "_NRF
S XMT(3,0)=" ",XMT(4,0)="Renewals sent to provider: "_TOTREN
S XMT(5,0)="Renewals not sent to provider: "_TOTF
D ^XMD
I $D(^TMP($J)) K XMY N XMDUZ,XMSUB,XMTEXT D
. S XMY(DUZ)=""
. I $D(^TMP($J,"ORAREN E")) S XMDUZ="AUTO,RENEWAL",XMY("G.AUTORENEWAL")="",XMSUB=$S($G(VEXANS2)["S":$$GET1^DIQ(59,PSOSITE,.06)_" ",1:"")_"RENEWAL REQUESTS NOT SENT TO PROVIDERS",XMTEXT="^TMP("_$J_",""ORAREN E""," D ^XMD
. I $D(^TMP($J,"ORAREN OC")) S XMDUZ="AUTO,RENEWAL",XMY("G.AUTORENEWAL")="",XMSUB=$S($G(VEXANS2)["S":$$GET1^DIQ(59,PSOSITE,.06)_" ",1:"")_"RENEWAL REQUESTS WITH ORDER CHECKS",XMTEXT="^TMP("_$J_",""ORAREN OC""," D ^XMD
K CNT1,GCNT,MAFBFD,ORDP,ORDPDN,HACT,NDINACT,DINACT,MMDAT,NDISDT,DISDT ; PVMAC/BFD 7-9-04 kill variables used for mail message AUDIORENEWAL, 8-29-04 Add order ktr
K MAFBKT,FBKTRDN,FBKTR,PTERMDN,PTERM,NPCPDN,NPCP,UNSKTR,INFPKTR,INFPDNKTR,NRF,RFY,MMCONT,PCONT,NRFLG ; PVMAC/BFD 8-26-04 variables used for mail message AUDIOCRMGR
K HACTDN,NPCPADN,NPCPA,VEX648,VEXREN
I $P($G(^PS(59,+$G(PSOSITE),"I")),"^"),DT>$P($G(^("I")),"^") D FINAL^PSOLSET W !!,"Your Outpatient Site parameters have been deleted because you selected an",!,"inactive Outpatient Site!",!
;VMP OIFO BAY PINES;PSO*7*197
K DIR,PSOBBC,PSOBBC1,PSOVIN,PSOISITE,PSOVEXFL,PSOVXLP,PSOVEX,PSOVX,PSOVEXI,VEXANS,VEXANS2,VEXPTRX,VEXXFLAG,VEXPSORX,X,Y,PSORX
Q
VEXALT ;Menu action entry point to alert user
S VEXCNT=0,VEXPTRN=""
I '$G(PSOINST) S PSOINST="000" I $D(^DD("SITE",1)) S PSOINST=^(1)
G:'$D(^VEXHRX(19080,PSOINST)) VEXEND
F S VEXPTRN=$O(^VEXHRX(19080,PSOINST,VEXPTRN)) Q:VEXPTRN="" D
.I ^VEXHRX(19080,PSOINST,VEXPTRN)="" S VEXCNT=VEXCNT+1
W:VEXCNT !!,$C(7),VEXCNT_" Telephone Refills To Process"
VEXEND K VEXCNT,VEXPTRN
Q
ULK ;
I '$G(VEXPSORX) Q
D PSOUL^PSSLOCK(VEXPSORX)
K VEXPSORX
Q
; -----------------------------------------------------------------------------------
RENEWCHK ; Checks ^VEXHRX node for renewal information
; Renewal check
; @1
;PVMAC/BFD 2/04 Add RENFLG (used in later chk of global)
;PVMAC/BFD 6-25-04 Add 'pass' of provider parameter & generic user DUZ
;PVMAC/BFD 7-9-04 Add changes so can send mail message to renewal mail group
;PVMAC/BFD 8-10-04 Remove REN set because changing to 0 every time through
;PVMAC/BFD 8-27-04 Set REN because that determines if set DT (now use CNT1 for mm)
;PVMAC/BFD 9-10-04 Adjust CNT1 ktr for either 0 or 1 result so can send mm from APUVEX
S RENFLG=0
S RENEW=$P(^VEXHRX(19080,PSOINST,VEXPTRX),"^",5),PROVP=$P(^VEXHRX(19080,PSOINST,VEXPTRX),"^",8),USR=$P(^VEXHRX(19080,PSOINST,VEXPTRX),"^",7)
; @2
I RENEW="U"!(RENEW="I")!(RENEW="N") D
. N RESULT
. S RXNUM=+$P(VEXPTRX,"-",2),PATIEN=+$P(VEXPTRX,"-")
. D RENEW^ORAREN(.RESULT,PATIEN,RXNUM,PROVP,RENEW)
. S RENFLG=1
. S $P(^VEXHRX(19080,PSOINST,VEXPTRX),"^")=DT
. S $P(^VEXHRX(19080,PSOINST,VEXPTRX),"^",6)=RESULT
. I RESULT=0 S CNT1=CNT1+1
. I RESULT=1 S CNT1=CNT1+1,TOTREN=TOTREN+1
. I RESULT'=1 S TOTF=TOTF+1
. Q
Q
BFDRNCHK ; 648/BFD 4-27-06 There is data in global - is it date or renewal request
; Troubleshooting - put this on next line after =1
; W !,"there is no ^ in VEXREN "_VEXREN_" so must just be a date. Set Vex648 to 0"
I VEXREN'["^" S VEX648=1
; Troubleshooting - put on next line after =1
; W !,"VEXREN is "_VEXREN_" this check is for something in piece 1 of ] and sets VEX648=1"
I VEXREN["^" I $P(VEXREN,"^",1)]"" S VEX648=1
; Troubleshooting - put on next line after =0
; W !,"VEXREN is "_VEXREN_" this check is for nothing in piece 1 of '] and set VEX648 to 0"
I VEXREN["^" I $P(VEXREN,"^",1)']"" S VEX648=0
;W !,"in BFDRNCHK and set VEX648 = "_VEX648
;W !,"if vex648 is 0 then no date but renewal"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVEXRX 11654 printed Nov 22, 2024@17:53:56 Page 2
VEXRX ;MUSKOGEE VAMC/GLD - AUDIOFAX SUBROUTINE - 6-21-94
+1 ;;7.0;OUTPATIENT PHARMACY;**197,328**;JUN 1994
+2 ;
+3 ;Reference to ^ORAREN supported by IA #5498
+4 ;;PERFORM MUMPS AUDIOFAX REFILLS BY CALLING ^PSOBBC
+5 ;
+6 ; THIS IS COPY OF HOP'S VEXRX PLUS MY TWO SETS
+7 ;
+8 ;This routine is for Outpatient version 7 only
+9 ; Modify History:
+10 ; 06Jan2004; IHS; @1; Add Renewal Processing
+11 ; 30Apr2004; IHS; @2; Add N flag for not renewable
+12 ; Feb 2004; BFD/PVAMC ; Add RENFLG (used in later chk of global)
+13 ; 25Jun2004; BFD/PVAMC ; Add 'pass' of provider parameter & generic user DUZ
+14 ; 09July2004; BFD/PVAMC; Add call to send mail message to renewal mail group
+15 ; 03Aug2004; BFD/PVAMC ; Add RENFLG=0 to START because no data in global cause crash
+16 ; 10Aug 2004; BFD/PVAMC; Add CN1T=0 to START & put in END+1 because mail message not being sent
+17 ; 26Aug2004; BFD/PVAMC; Add ktrs for msg to 'mgr' mail group
+18 ; 29Aug2004; BFD/PVAMC; Add order prob kt
+19 ; 27Jan2006; @3; IHS; Merge Bay Pines changes with Portland Renewal code
+20 ; Feb-May 2006 ; BFD/PVAMC; New checks in VEX3 and VEX4 causes to skip renewal. Had to add new code to have recognized
+21 ; Apr-May 2006; BFD/PVAMC; New code in VEX3 to have program recognize renewal request and not skip
+22 ; 24-July 2006; BFD/PVAMC; Replace APUVEX call with APUVEX1 or APUVEX2, as appropirate. Had to split APUVEX due to size problem for SACC
+23 ; 05Dec 2006; BFD/PVAMC; Replace APUVEX1 call with APUVEX because reports that random requests not being handled correctly
+24 ; HAD TO REPLACE APUVEX1 AND APUVEX2 CALLS BECAUSE OF AN ERROR
+25 ; March, 2009; JLC/VM replace APU calls with call to CPRS API
+26 ; --------------------------------------------------------------------------------------
START SET PSOVEX=1
+1 ; BFD/PVMAC 2-8-06 Add renewal variable Set (2 lines)
+2 NEW PATIEN,PROVP,RENFLG,RESULT,USR,TOTREN,RXNUM,TOTF,EMCNT,INCNT
+3 SET RENFLG=0
SET CNT1=0
SET FBKTRDN=0
SET FBKTR=0
SET PTERMDN=0
SET PTERM=0
SET NPCPDN=0
SET NPCP=0
SET UNSKTR=0
SET INFPKTR=0
SET INFPDNKTR=0
SET NRF=0
SET RFY=0
SET MMCONT=0
SET PCONT=0
SET NRFLG=0
SET ORDP=0
SET ORDPDN=0
+4 SET HACT=0
SET HACTDN=0
SET NPCPADN=0
SET NPCPA=0
SET NDINACT=0
SET DINACT=0
SET MMDAT=0
SET DISDT=0
SET NDISDT=0
+5 KILL ^TMP($JOB,"ORAREN E"),^TMP($JOB,"ORAREN OC")
SET (EMCNT,INCNT)=5
SET (TOTF,TOTREN)=0
+6 ;
+7 KILL PSOVEXI,PSOISITE,PSOVEXFL
+8 FOR PSOVX=0:0
SET PSOVX=$ORDER(^PS(59,PSOVX))
if 'PSOVX
QUIT
IF $PIECE($GET(^PS(59,PSOVX,"I")),"^")
IF DT>$PIECE($GET(^("I")),"^")
SET PSOVEXI(PSOVX)=""
+9 IF $ORDER(PSOVEXI(0))
WRITE !,"Looking for refill requests for inactive Outpatient divisions..."
FOR PSOVIN=0:0
SET PSOVIN=$ORDER(^VEXHRX(19080,PSOVIN))
if 'PSOVIN
QUIT
SET PSOVXLP=""
FOR
SET PSOVXLP=$ORDER(^VEXHRX(19080,PSOVIN,PSOVXLP))
if PSOVXLP=""
QUIT
Begin DoDot:1
+10 SET PSOISITE=$PIECE($GET(^PSRX(+$PIECE(PSOVXLP,"-",2),2)),"^",9)
if $GET(PSOVEXI(+$GET(PSOISITE)))
QUIT
+11 IF PSOISITE
IF $DATA(PSOVEXI(PSOISITE))
IF $GET(^VEXHRX(19080,PSOVIN,PSOVXLP))=""
SET PSOVEXI(PSOISITE)=1
SET PSOVEXFL=1
End DoDot:1
+12 IF '$GET(PSOVEXFL)
IF $ORDER(PSOVEXI(0))
WRITE ".none found.",!
+13 IF $GET(PSOVEXFL)
WRITE !!,"The following Inactive Outpatient sites have refill requests:",!
FOR PSOVX=0:0
SET PSOVX=$ORDER(PSOVEXI(PSOVX))
if 'PSOVX
QUIT
IF $GET(PSOVEXI(PSOVX))
WRITE !?5,$PIECE($GET(^PS(59,+$GET(PSOVX),0)),"^")
+14 IF $GET(PSOVEXFL)
KILL DIR
WRITE !
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue, '^' to exit"
DO ^DIR
WRITE !
IF Y'=1
GOTO END
+15 if '$DATA(PSOPAR)
DO ^PSOLSET
if '$DATA(PSOPAR)
GOTO END
+16 WRITE !!!?20,"Division: "_$PIECE(^PS(59,PSOSITE,0),"^"),!!
+17 SET PSOBBC1("FROM")="REFILL"
SET PSOBBC("QFLG")=0
SET PSOBBC("DFLG")=0
+18 IF '$DATA(^VEXHRX(19080,PSOINST))
SET VEXANS="N"
WRITE !!?7,$CHAR(7),"There are no telephone refills to process."
GOTO END
+19 DO ASK^PSOBBC
if PSOBBC("QFLG")=1
WRITE !?7,$CHAR(7),"No telephone refills were processed."
if PSOBBC("QFLG")=1
GOTO END
VEX WRITE !
SET DIR("B")="YES"
SET DIR("A")="Process telephone refill requests at this time"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
SET VEXANS="N"
IF $GET(DIRUT)
SET VEXPTRX=""
GOTO END
+1 if Y=0
GOTO END
SET VEXPTRX=""
IF Y=1
SET VEXANS="Y"
+2 IF VEXANS["Y"
SET DIR("B")="YES"
SET DIR("A")="Process telephone refills for all divisions"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
SET VEXANS2="S"
if Y=1
SET VEXANS2="M"
IF $GET(DIRUT)
SET VEXANS="N"
GOTO END
+3 ; @3; Added Portland code to Bay Pines
+4 ; BFD/PVMAC 7-9-04 use to indicate first time through for mail msg build
SET CNT1=10
VEX6 ;MARK PROCESSED NODES
IF VEXANS["Y"
IF $GET(VEXPTRX)
DO VEX5
+1 DO VEX3
IF $GET(VEXANS)="N"
DO ULK
GOTO END
+2 IF $PIECE(X,"-")'=PSOINST
WRITE !?7,$CHAR(7),$CHAR(7),$CHAR(7),"Not from this institution.",!
DO ULK
GOTO VEX6
+3 ; @3; Add Portland code to Bay Pines
+4 IF $LENGTH(RENEW)
SET RENEW=""
GOTO VEX6
+5 SET (PSOBBC("IRXN"),PSOBBC("OIRXN"))=$PIECE(X,"-",2)
+6 IF $DATA(^PSRX(PSOBBC("IRXN"),0))']""
WRITE !,$CHAR(7),"Rx data is not on file!",!
DO ULK
GOTO VEX6
+7 IF $PIECE($GET(^PSRX(PSOBBC("IRXN"),"STA")),"^")=13
WRITE !,$CHAR(7),"Rx has already been deleted."
DO ULK
GOTO VEX6
+8 IF $GET(PSOBBC("DONE"))[PSOBBC("IRXN")_","
WRITE !,$CHAR(7),"Rx has already been entered."
DO ULK
GOTO VEX6
+9 KILL X,Y
if PSOBBC("QFLG")
DO PROCESSX^PSOBBC
+10 SET PSOSELSE=0
IF $GET(PSODFN)'=$PIECE(^PSRX(PSOBBC("IRXN"),0),"^",2)
SET PSOSELSE=1
DO PT^PSOBBC
IF $GET(PSOBBC("DFLG"))
KILL PSOSELSE
DO ULK
GOTO VEX6
+11 IF '$GET(PSOSELSE)
DO PTC^PSOBBC
IF $GET(PSOBBC("DFLG"))
KILL PSOSELSE
DO ULK
GOTO VEX6
+12 KILL PSOSELSE
DO PROFILE^PSORX1
SET X="PPPPDA1"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET X=$$PDA^PPPPDA1(PSODFN)
WRITE !!
+13 SET PSOBBC("DONE")=PSOBBC("IRXN")_","
DO REFILL^PSOBBC
DO ULK
GOTO VEX6
+14 QUIT
+15 ; BFD/648 4-27-06 Add VEX3+3 and chk of vex648, VEX4+0 so not skip renewal requests
VEX3 KILL PSOBBC("IRXN"),VEXXFLAG
FOR
SET VEXPTRX=$ORDER(^VEXHRX(19080,PSOINST,VEXPTRX))
Begin DoDot:1
+1 IF VEXPTRX=""
SET VEXANS="N"
QUIT
+2 SET VEXREN=0
SET VEX648=0
SET VEXREN=$GET(^VEXHRX(19080,PSOINST,VEXPTRX))
IF VEXREN]""
DO BFDRNCHK
+3 ;SKIPS ERRONEOUS ENTRIES
IF '$DATA(^PSRX(+$PIECE(VEXPTRX,"-",2),0))
IF VEX648=1
DO VEX5
QUIT
+4 ;I '$D(^PSRX(+$P(VEXPTRX,"-",2),0)),^VEXHRX(19080,PSOINST,VEXPTRX)="" D VEX5,VEX12 Q ;SKIPS ERRONEOUS ENTRIES
VEX4 ;SKIPS ENTRIES ALREADY PROCESSED AND FORMATS VARIABLE X (BFD/648 LINE)
IF VEXANS["Y"
if VEX648=1
QUIT
SET X=PSOINST_"-"_$PIECE(VEXPTRX,"-",2)
+1 ;I VEXANS["Y" Q:^VEXHRX(19080,PSOINST,VEXPTRX)'="" S X=PSOINST_"-"_$P(VEXPTRX,"-",2) ;SKIPS ENTRIES ALREADY PROCESSED AND FORMATS VARIABLE X (ORIG LINE)
VEX10 IF VEXANS2["S"
IF $DATA(^PSRX(+$PIECE(VEXPTRX,"-",2),0))
IF PSOSITE'=$PIECE($GET(^PSRX(+$PIECE(VEXPTRX,"-",2),2)),"^",9)
QUIT
+1 ;@3; Check at this point if this is a renewal request
+2 DO RENEWCHK
IF RENEW]""
SET VEXXFLAG=1
QUIT
+3 SET VEXPSORX=+$PIECE($GET(VEXPTRX),"-",2)
IF VEXPSORX
DO PSOL^PSSLOCK(VEXPSORX)
IF '$GET(PSOMSG)
KILL VEXPSORX,PSOMSG
QUIT
+4 KILL PSOMSG
SET VEXXFLAG=1
End DoDot:1
if VEXANS="N"!($GET(VEXXFLAG))
QUIT
+5 QUIT
+6 ; -----------------------------------------------------------------------------------
+7 ; @3; Added Portland code to Bay Pines
+8 ;LINES CALLED TO MARK PROCESSED NODES
+9 ;LINES CALLED TO MARK PROCESSED NODES
+10 ;PVMAC/BFD 2/04 Add RENFLG chk, If 1 then renewal & global already set so skip
+11 ;PVMAC/BFD 8-26-04 Add RFY and NRF ktrs to VEX5 and VEX12
+12 ;PVMAC/BFD 8-26-04 Add NRFLG
VEX5 ;
+1 ; Next statement is used by BFD/648 CHK PROGRESS THRU PROGRAM
+2 ;W !,"AT VEX5 and VEXXFLAG is "_VEXXFLAG
+3 ;MARKS NODE AS PROCESSED
IF RENFLG=0
SET ^VEXHRX(19080,PSOINST,VEXPTRX)=DT
Begin DoDot:1
+4 ;FLAGS UNSUCCESSFUL ATTEMPTS TO REFILL.
IF $GET(PSOBBC("DFLG"))
DO VEX12
End DoDot:1
+5 ; @3
+6 IF NRFLG=0
IF (RENFLG=0)
SET RFY=RFY+1
+7 SET NRFLG=0
+8 QUIT
VEX12 ;
+1 ; @3
+2 SET NRF=NRF+1
SET NRFLG=1
+3 SET $PIECE(^VEXHRX(19080,PSOINST,VEXPTRX),U,2)="NOT FILLED"
+4 WRITE !!,$CHAR(7),"REFILL WAS NOT PROCESSED! PLEASE TAKE APPROPRIATE ACTION."
+5 WRITE !
SET DIR("A")="Do you wish to continue processing"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
IF Y'=1
SET VEXANS="N"
QUIT
+6 QUIT
END DO PROCESSX^PSOBBC
+1 ; bfd/648 12-5-06 ; out all APUVEX1 and APUVEX2 calls & un ; out all APUVEX calls
+2 ; @3
+3 ; SMT If VEXANS2="S" then we are only looking at a single division and we add the division to the mail subject.
+4 KILL XMY
NEW XMDUZ,XMSUB,XMTEXT,XMT
+5 SET XMDUZ="AUTO,RENEWAL"
SET XMY(DUZ)=""
SET XMY("G.AUTORENEWAL")=""
SET XMSUB=$SELECT($GET(VEXANS2)["S":$$GET1^DIQ(59,PSOSITE,.06)_" ",1:"")_"REFILL TOTALS"
SET XMTEXT="XMT("
+6 SET XMT(1,0)="Refills Processed: "_RFY
SET XMT(2,0)="Refills 'Not Processed': "_NRF
+7 SET XMT(3,0)=" "
SET XMT(4,0)="Renewals sent to provider: "_TOTREN
+8 SET XMT(5,0)="Renewals not sent to provider: "_TOTF
+9 DO ^XMD
+10 IF $DATA(^TMP($JOB))
KILL XMY
NEW XMDUZ,XMSUB,XMTEXT
Begin DoDot:1
+11 SET XMY(DUZ)=""
+12 IF $DATA(^TMP($JOB,"ORAREN E"))
SET XMDUZ="AUTO,RENEWAL"
SET XMY("G.AUTORENEWAL")=""
SET XMSUB=$SELECT($GET(VEXANS2)["S":$$GET1^DIQ(59,PSOSITE,.06)_" ",1:"")_"RENEWAL REQUESTS NOT SENT TO PROVIDERS"
SET XMTEXT="^TMP("_$JOB_",""ORAREN E"","
DO ^XMD
+13 IF $DATA(^TMP($JOB,"ORAREN OC"))
SET XMDUZ="AUTO,RENEWAL"
SET XMY("G.AUTORENEWAL")=""
SET XMSUB=$SELECT($GET(VEXANS2)["S":$$GET1^DIQ(59,PSOSITE,.06)_" ",1:"")_"RENEWAL REQUESTS WITH ORDER CHECKS"
SET XMTEXT="^TMP("_$JOB_",""ORAREN OC"","
DO ^XMD
End DoDot:1
+14 ; PVMAC/BFD 7-9-04 kill variables used for mail message AUDIORENEWAL, 8-29-04 Add order ktr
KILL CNT1,GCNT,MAFBFD,ORDP,ORDPDN,HACT,NDINACT,DINACT,MMDAT,NDISDT,DISDT
+15 ; PVMAC/BFD 8-26-04 variables used for mail message AUDIOCRMGR
KILL MAFBKT,FBKTRDN,FBKTR,PTERMDN,PTERM,NPCPDN,NPCP,UNSKTR,INFPKTR,INFPDNKTR,NRF,RFY,MMCONT,PCONT,NRFLG
+16 KILL HACTDN,NPCPADN,NPCPA,VEX648,VEXREN
+17 IF $PIECE($GET(^PS(59,+$GET(PSOSITE),"I")),"^")
IF DT>$PIECE($GET(^("I")),"^")
DO FINAL^PSOLSET
WRITE !!,"Your Outpatient Site parameters have been deleted because you selected an",!,"inactive Outpatient Site!",!
+18 ;VMP OIFO BAY PINES;PSO*7*197
+19 KILL DIR,PSOBBC,PSOBBC1,PSOVIN,PSOISITE,PSOVEXFL,PSOVXLP,PSOVEX,PSOVX,PSOVEXI,VEXANS,VEXANS2,VEXPTRX,VEXXFLAG,VEXPSORX,X,Y,PSORX
+20 QUIT
VEXALT ;Menu action entry point to alert user
+1 SET VEXCNT=0
SET VEXPTRN=""
+2 IF '$GET(PSOINST)
SET PSOINST="000"
IF $DATA(^DD("SITE",1))
SET PSOINST=^(1)
+3 if '$DATA(^VEXHRX(19080,PSOINST))
GOTO VEXEND
+4 FOR
SET VEXPTRN=$ORDER(^VEXHRX(19080,PSOINST,VEXPTRN))
if VEXPTRN=""
QUIT
Begin DoDot:1
+5 IF ^VEXHRX(19080,PSOINST,VEXPTRN)=""
SET VEXCNT=VEXCNT+1
End DoDot:1
+6 if VEXCNT
WRITE !!,$CHAR(7),VEXCNT_" Telephone Refills To Process"
VEXEND KILL VEXCNT,VEXPTRN
+1 QUIT
ULK ;
+1 IF '$GET(VEXPSORX)
QUIT
+2 DO PSOUL^PSSLOCK(VEXPSORX)
+3 KILL VEXPSORX
+4 QUIT
+5 ; -----------------------------------------------------------------------------------
RENEWCHK ; Checks ^VEXHRX node for renewal information
+1 ; Renewal check
+2 ; @1
+3 ;PVMAC/BFD 2/04 Add RENFLG (used in later chk of global)
+4 ;PVMAC/BFD 6-25-04 Add 'pass' of provider parameter & generic user DUZ
+5 ;PVMAC/BFD 7-9-04 Add changes so can send mail message to renewal mail group
+6 ;PVMAC/BFD 8-10-04 Remove REN set because changing to 0 every time through
+7 ;PVMAC/BFD 8-27-04 Set REN because that determines if set DT (now use CNT1 for mm)
+8 ;PVMAC/BFD 9-10-04 Adjust CNT1 ktr for either 0 or 1 result so can send mm from APUVEX
+9 SET RENFLG=0
+10 SET RENEW=$PIECE(^VEXHRX(19080,PSOINST,VEXPTRX),"^",5)
SET PROVP=$PIECE(^VEXHRX(19080,PSOINST,VEXPTRX),"^",8)
SET USR=$PIECE(^VEXHRX(19080,PSOINST,VEXPTRX),"^",7)
+11 ; @2
+12 IF RENEW="U"!(RENEW="I")!(RENEW="N")
Begin DoDot:1
+13 NEW RESULT
+14 SET RXNUM=+$PIECE(VEXPTRX,"-",2)
SET PATIEN=+$PIECE(VEXPTRX,"-")
+15 DO RENEW^ORAREN(.RESULT,PATIEN,RXNUM,PROVP,RENEW)
+16 SET RENFLG=1
+17 SET $PIECE(^VEXHRX(19080,PSOINST,VEXPTRX),"^")=DT
+18 SET $PIECE(^VEXHRX(19080,PSOINST,VEXPTRX),"^",6)=RESULT
+19 IF RESULT=0
SET CNT1=CNT1+1
+20 IF RESULT=1
SET CNT1=CNT1+1
SET TOTREN=TOTREN+1
+21 IF RESULT'=1
SET TOTF=TOTF+1
+22 QUIT
End DoDot:1
+23 QUIT
BFDRNCHK ; 648/BFD 4-27-06 There is data in global - is it date or renewal request
+1 ; Troubleshooting - put this on next line after =1
+2 ; W !,"there is no ^ in VEXREN "_VEXREN_" so must just be a date. Set Vex648 to 0"
+3 IF VEXREN'["^"
SET VEX648=1
+4 ; Troubleshooting - put on next line after =1
+5 ; W !,"VEXREN is "_VEXREN_" this check is for something in piece 1 of ] and sets VEX648=1"
+6 IF VEXREN["^"
IF $PIECE(VEXREN,"^",1)]""
SET VEX648=1
+7 ; Troubleshooting - put on next line after =0
+8 ; W !,"VEXREN is "_VEXREN_" this check is for nothing in piece 1 of '] and set VEX648 to 0"
+9 IF VEXREN["^"
IF $PIECE(VEXREN,"^",1)']""
SET VEX648=0
+10 ;W !,"in BFDRNCHK and set VEX648 = "_VEX648
+11 ;W !,"if vex648 is 0 then no date but renewal"
+12 QUIT
