PSXMISC1 ;BIR/WPB,BAB-Transmission Data Validation ;MAR 1,2002@13:13:34
;;2.0;CMOP;**3,18,23,28,30,42,41,52,54,58,64,76,78,98**;11 Apr 97;Build 5
;Reference to ^PSDRUG( supported by DBIA #1983
;Reference to ^PS(52.5, supported by DBIA #1978
;Reference to ^PSRX( supported by DBIA #1977
;Reference to ^PS(55, supported by DBIA #2228
;Reference to ^PSRX( supported by DBIA #1977
;Reference to PROD2^PSNAPIS supported by DBIA #2531
;Reference to ^PSSLOCK supported by DBIA #2789
;Reference to CHKRX^PSOBAI supported by DBIA #4910
CHKDATA ;checks the data elements in PSRX before putting the rx in 550.2
Q:'$D(^PS(52.5,REC,0))
K DRUGCHK,PSXRXERR,PSXDGST,WARNS
S (RXN,PSXPTR)=$P($G(^PS(52.5,REC,0)),"^",1) I PSXPTR="" S PSXOK=8 Q
D PSOL^PSSLOCK(RXN) S PSOMSG=+PSOMSG ; sets PSOMSG
I ($P(^PS(52.5,REC,0),U,3)'=XDFN)!($P(^PSRX(PSXPTR,0),U,2)'=XDFN) S PSXOK=8 Q
I '$D(^PSRX(PSXPTR,0)) S PSXOK=8 Q
S RXNUM=$P($G(^PSRX(PSXPTR,0)),"^",6),RXEX=$P($G(^PSRX(PSXPTR,0)),"^",1)
I $G(^PSDRUG(RXNUM,"ND"))'="" D
.S PTRA=$P($G(^PSDRUG(RXNUM,"ND")),U,1),PTRB=$P($G(^PSDRUG(RXNUM,"ND")),U,3)
.I $G(PTRA)'="" S ZX=$$PROD2^PSNAPIS(PTRA,PTRB),DRUGCHK=$P($G(ZX),"^",3)
S:$G(DRUGCHK)'="" PSXDGST=$P(ZX,"^",2)_"^"_$P(ZX,"^")
I '$D(DRUGCHK) S DRUGCHK=0
S:'$D(^PSDRUG("AQ",RXNUM)) PSXOK=1
S:$G(DRUGCHK)'=1 PSXOK=1
I $P(^PSDRUG(RXNUM,2),"^",3)'["O" S PSXOK=1,PSXCK=RXNUM D UNMARK^PSXUTL
S:$P($G(^PSRX(PSXPTR,"STA")),U,1)'=5 PSXOK=5
;gets the fill number by ordering thru the refill node for the last
;refill number
S FILNUM=0 F REF=0:0 S REF=$O(^PSRX(PSXPTR,1,REF)) Q:REF'>0 S:REF>0 FILNUM=REF S:REF="" FILNUM=0
;I $G(PSXFLAG)=2 S PSXOK=0 Q
S RXF=FILNUM
S REL=$S(RXF>0:$P($G(^PSRX(RXN,1,RXF,0)),U,18),RXF=0:$P($G(^PSRX(RXN,2)),U,13),1:"") I $G(REL)'="" S PSXOK=6
S:((PSXOK=0)&(FILNUM>0)&($P($G(^PSRX(PSXPTR,1,FILNUM,0)),"^",2)'="M")) PSXOK=3
S:((PSXOK=0)&(FILNUM'>0)&($P($G(^PSRX(PSXPTR,0)),"^",11)'="M")) PSXOK=3
I $G(^PS(52.5,REC,"P"))="1" S PSXOK=4
S PSXDIV=$S(FILNUM=0:$P($G(^PSRX(PSXPTR,2)),U,9),FILNUM>0:$P($G(^PSRX(PSXPTR,1,FILNUM,0)),"^",9),1:"")
;If trans div does not match Rx div eliminate
I PSXDIV'=PSOSITE S PSXOK=7 Q
; Changes for Controlled subs
N PSXCSC,PSXCSD S PSXCSRX=""
S PSXCSC=$P($G(^PSDRUG(RXNUM,0)),"^",3)
;Can't trans DEA schedule 1 or 2
I $G(PSXCSC)[1!($G(PSXCSC)[2) S PSXOK=10 Q
;If CS must be DEA 3-5 to qualify
F PSXCSD=3:1:5 I PSXCSC[PSXCSD S PSXCSRX=1
;If not CS drug and CS trans eliminate
I ($G(PSXCSRX)<1)&($G(PSXCS)=1) S PSXOK=9 Q
;If CS drug and not CS trans eliminate
I ($G(PSXCSRX)=1)&($G(PSXCS)<1) S PSXOK=9 Q
; Checks for do not mail and expiration date thereof
; moved to under NOGO
;
G:PSXOK'=0 STOP
NOGO ;any rx that does not pass the following checks will not be transmitted
;and an error message will be generated and sent to the user who
;initiated the transmission. All that pass the checks will be sent.
S RXERR=0,PSXRXERR=RXEX_"^"_RXF
I RXEX[" " S RXERR=13,PSXRXERR=PSXRXERR_"^"_RXERR
S QTY=$S(RXF>0:$P($G(^PSRX(RXN,1,RXF,0)),U,4),RXF=0:$P($G(^PSRX(RXN,0)),U,7),1:"") G:$G(QTY)'=""&($G(QTY)>0)&(QTY?.N)!(QTY?.N1".".N) NG1 S RXERR=2,PSXRXERR=PSXRXERR_"^"_RXERR
NG1 S PHY=$S(RXF>0:$P($G(^PSRX(RXN,1,RXF,0)),U,17),RXF=0:$P($G(^PSRX(RXN,0)),U,4),1:"") I PHY="" S RXERR=3,PSXRXERR=PSXRXERR_"^"_RXERR
S DAYS=$S(RXF>0:$P($G(^PSRX(RXN,1,RXF,0)),U,10),RXF=0:$P($G(^PSRX(RXN,0)),U,8),1:"") I (DAYS'>0)!(DAYS="") S RXERR=4,PSXRXERR=PSXRXERR_"^"_RXERR
S PHARCLK=$S(RXF>0:$P($G(^PSRX(RXN,1,RXF,0)),U,7),RXF=0:$P($G(^PSRX(RXN,0)),U,16),1:"") I PHARCLK="" S RXERR=9,PSXRXERR=PSXRXERR_"^"_RXERR
S DRUG=$P($G(^PSRX(RXN,0)),U,6),PSTAT=$P($G(^(0)),U,3),FDATE=$P($G(^PSRX(RXN,2)),U,2)
D TSTSIG
S DFN=$P($G(^PSRX(RXN,0)),U,2) D ADD^VADPT I (($G(VAPA(1))="")!($G(VAPA(4))="")!($P($G(VAPA(5)),"^",2)="")!($G(VAPA(6))'>0)!($P($G(VAPA(11)),"^",2)'>0)),(($$BADADR^DGUTL3(DFN))'>0) S RXERR=10,PSXRXERR=PSXRXERR_"^"_RXERR
D DEM^VADPT
I VADM(1)["MERGING" S RXERR=17,PSXRXERR=PSXRXERR_"^"_RXERR
;MVP OIFO BAY PINES;ELR;PSX*2*52 CHANGED RXERR FROM 10 TO 19. ADDED NEW ERROR IN PSXERR
I $G(VA("PID"))["000-00" S RXERR=19,PSXRXERR=PSXRXERR_"^"_RXERR ; SSN ["000-00" indicates test patient
S (CNTR,XC,DUPFLG)=0,DUPRX="" F S XC=$O(^PSRX("B",RXEX,XC)) Q:XC'>0 S CNTR=CNTR+1,DUPRX=DUPRX_"^"_XC
I CNTR>1 D
.Q:$P(DUPRX,"^",3)=""
.F I2=2:1 S I1=$P(DUPRX,"^",I2) Q:I1="" S PSREC=$O(^PS(52.5,"B",I1,"")) Q:$G(PSREC)'>0 S:($P(^PS(52.5,PSREC,0),"^",2)<PSXDTRG&($P(^PS(52.5,PSREC,0),"^",7)="Q")) DUPFLG=1
S:$G(DUPFLG)>0 PSXRXERR=PSXRXERR_"^"_"14"
K CNTR,XC,DUPRX,I2,I1,PSREC,DUPFLG
I $D(^PSRX(PSXPTR,4,0)) D
.S RXERR=""
.S ZX=0 F S ZX=$O(^PSRX(PSXPTR,4,ZX)) Q:ZX'>0 D
..I $P(^PSRX(PSXPTR,4,ZX,0),"^",3)=RXF&($P(^PSRX(PSXPTR,4,ZX,0),"^",4)'=3) S RXERR=12
..I $P(^PSRX(PSXPTR,4,ZX,0),"^",3)=RXF&($P(^PSRX(PSXPTR,4,ZX,0),"^",4)=3) S RXERR=""
.I RXERR'="" S PSXRXERR=PSXRXERR_"^"_RXERR
I DRUG="" S RXERR=5,PSXRXERR=PSXRXERR_"^"_RXERR
I DRUG S WARNS=$P(^PSDRUG(DRUG,0),"^",8) D
.;IF USING NEW WARNING SOURCE, LENGTH OF OLD WARNINGS DOESN'T MATTER
.I '$D(PSSWSITE) S PSSWSITE=+$O(^PS(59.7,0))
.I $P($G(^PS(59.7,PSSWSITE,10)),"^",10)="N" Q
.I $G(WARNS) S:$L(WARNS)>11 RXERR=16,PSXRXERR=PSXRXERR_"^"_RXERR
I SIG="" S RXERR=6,PSXRXERR=PSXRXERR_"^"_RXERR
I PSTAT="" S RXERR=7,PSXRXERR=PSXRXERR_"^"_RXERR
I FDATE'?7N S RXERR=8,PSXRXERR=PSXRXERR_"^"_RXERR
I '$$MAILOK(RXN) D
. S COM="Removed from CMOP Suspense - Mail Status Change" D NOW^%DTC S DTTM=% K % D ACTLOG^PSXRPPL
. D DELETE^PSXRPPL S PSXOK=1
. ;MVP OIFO BAY PINES;ELR;PSX*2*5 DELETE MM MSG FOR DO NOT MAIL
. ;S RXERR=15,PSXRXERR=PSXRXERR_"^"_RXERR ;mail message to users
I $D(^TMP($J,"PSXBAI",DFN)),'$G(^TMP($J,"PSXBAI",DFN)) D
. S PSXOK=8
. D CHKACT(PSXPTR)
. I '$G(PSXFIRST) K PSXRXERR Q
. S COM="Bad Address Indicator or Foreign Address. Not removed from CMOP Suspense" D NOW^%DTC S DTTM=% K % D ACTLOG^PSXRPPL
. S RXERR=20,PSXRXERR=PSXRXERR_"^"_RXERR ;mail message to users
PSOMSG I +PSOMSG=0 S RXERR=18,PSXRXERR=PSXRXERR_"^"_RXERR ; from PSSLOCK
I $P($G(PSXRXERR),"^",3)'="" S PSXOK=8 D ER7^PSXERR
STOP K DAYS,DRUG,FDATE,PHARCLK,PHY,PSTAT,QTY,RXERR,RXEX,SIG,VAPA(1),DRUGCHK,PTRA,PTRB,REL,RXNUM,PHARCLK1,ZX,VAPA(4),VAPA(5),VAPA(6)
Q
;
TSTSIG ; include testing for BAD characters in SIG
I $P(^PSRX(RXN,"SIG"),"^",2)'>0 S SIG=$P(^PSRX(RXN,"SIG"),"^") D TSTCHAR
I $P(^PSRX(RXN,"SIG"),"^",2)=1 N L S L=0 F S L=$O(^PSRX(RXN,"SIG1",L)) Q:L'>0 S SIG=$G(^PSRX(RXN,"SIG1",L,0)) D TSTCHAR Q:SIG=""
Q
TSTCHAR ; test each character of SIG for certain characters
N I,C
I '$D(^TMP($J,"PSXCHAR")) D
. F I=0:1:31 S ^TMP($J,"PSXCHAR",I)=""
. F I=92,94,124,127 S ^TMP($J,"PSXCHAR",I)=""
F I=1:1:$L(SIG) S C=$A($E(SIG,I)) I $D(^TMP($J,"PSXCHAR",C)) S SIG="" Q
Q
MAILOK(TRX) ; return 1 if patient still in mail status & ok to CMOP
N PSOMDT,PSOMC,DFN
S DFN=$P(^PSRX(TRX,0),"^",2),PSOMDT=$P($G(^PS(55,DFN,0)),"^",5),PSOMC=$P($G(^PS(55,DFN,0)),"^",3)
I $$GET1^DIQ(52,TRX,100.2,"I")]"" S PSOMC=$$GET1^DIQ(52,TRX,100.2,"I"),PSOMDT="" ;p98
I (PSOMC>1&(PSOMDT>DT))!(PSOMC>1&(PSOMDT<1)) Q 0
Q 1
ADDROK(TRX) ; return 1 if not foreign and not bad address indicator
N DFN,PSOFORGN
S DFN=$P($G(^PSRX(TRX,0)),"^",2) I DFN="" Q:0
;BHW;PSX*2*64;Changed Quit below from Q:+(^TMP... to Q +(^TMP...
I $D(^TMP($J,"PSXBAI",DFN)) Q +(^TMP($J,"PSXBAI",DFN))
D ADD^VADPT
S PSOFORGN=$P($G(VAPA(25)),"^",2) I PSOFORGN'="",PSOFORGN'["UNITED STATES" S PSOFORGN=1
I PSOFORGN S ^TMP($J,"PSXBAI",DFN)=0 Q 0
I $T(CHKRX^PSOBAI)']"" S ^TMP($J,"PSXBAI",DFN)=1 Q 1
N PSORX,PSOBADR
S PSORX=TRX
S PSOBADR=$$CHKRX^PSOBAI(PSORX)
I '$P(PSOBADR,"^") S ^TMP($J,"PSXBAI",DFN)=1 Q 1
I $P(PSOBADR,"^",2)=1 S ^TMP($J,"PSXBAI",DFN)=1 Q 1
S ^TMP($J,"PSXBAI",DFN)=0
Q 0
;
CHKACT(RXN) ; SEE IF FILL IS ALREADY ON ACTIVITY LOG FOR FOREIGN OR BAD ADDRESS
N JJ,RFCNT,XX,COM
S PSXFIRST=1
S COM="Bad Address Indicator or Foreign Address."
S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF S RFCNT=$S(RF<6:RF,1:RF+1)
S JJ=0 F S JJ=$O(^PSRX(RXN,"A",JJ)) Q:'JJ S XX=$G(^PSRX(RXN,"A",JJ,0)) I $P(XX,"^",4)=RFCNT,$P(XX,"^",5)[COM S PSXFIRST=0 Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXMISC1 8204 printed Nov 22, 2024@16:54:42 Page 2
PSXMISC1 ;BIR/WPB,BAB-Transmission Data Validation ;MAR 1,2002@13:13:34
+1 ;;2.0;CMOP;**3,18,23,28,30,42,41,52,54,58,64,76,78,98**;11 Apr 97;Build 5
+2 ;Reference to ^PSDRUG( supported by DBIA #1983
+3 ;Reference to ^PS(52.5, supported by DBIA #1978
+4 ;Reference to ^PSRX( supported by DBIA #1977
+5 ;Reference to ^PS(55, supported by DBIA #2228
+6 ;Reference to ^PSRX( supported by DBIA #1977
+7 ;Reference to PROD2^PSNAPIS supported by DBIA #2531
+8 ;Reference to ^PSSLOCK supported by DBIA #2789
+9 ;Reference to CHKRX^PSOBAI supported by DBIA #4910
CHKDATA ;checks the data elements in PSRX before putting the rx in 550.2
+1 if '$DATA(^PS(52.5,REC,0))
QUIT
+2 KILL DRUGCHK,PSXRXERR,PSXDGST,WARNS
+3 SET (RXN,PSXPTR)=$PIECE($GET(^PS(52.5,REC,0)),"^",1)
IF PSXPTR=""
SET PSXOK=8
QUIT
+4 ; sets PSOMSG
DO PSOL^PSSLOCK(RXN)
SET PSOMSG=+PSOMSG
+5 IF ($PIECE(^PS(52.5,REC,0),U,3)'=XDFN)!($PIECE(^PSRX(PSXPTR,0),U,2)'=XDFN)
SET PSXOK=8
QUIT
+6 IF '$DATA(^PSRX(PSXPTR,0))
SET PSXOK=8
QUIT
+7 SET RXNUM=$PIECE($GET(^PSRX(PSXPTR,0)),"^",6)
SET RXEX=$PIECE($GET(^PSRX(PSXPTR,0)),"^",1)
+8 IF $GET(^PSDRUG(RXNUM,"ND"))'=""
Begin DoDot:1
+9 SET PTRA=$PIECE($GET(^PSDRUG(RXNUM,"ND")),U,1)
SET PTRB=$PIECE($GET(^PSDRUG(RXNUM,"ND")),U,3)
+10 IF $GET(PTRA)'=""
SET ZX=$$PROD2^PSNAPIS(PTRA,PTRB)
SET DRUGCHK=$PIECE($GET(ZX),"^",3)
End DoDot:1
+11 if $GET(DRUGCHK)'=""
SET PSXDGST=$PIECE(ZX,"^",2)_"^"_$PIECE(ZX,"^")
+12 IF '$DATA(DRUGCHK)
SET DRUGCHK=0
+13 if '$DATA(^PSDRUG("AQ",RXNUM))
SET PSXOK=1
+14 if $GET(DRUGCHK)'=1
SET PSXOK=1
+15 IF $PIECE(^PSDRUG(RXNUM,2),"^",3)'["O"
SET PSXOK=1
SET PSXCK=RXNUM
DO UNMARK^PSXUTL
+16 if $PIECE($GET(^PSRX(PSXPTR,"STA")),U,1)'=5
SET PSXOK=5
+17 ;gets the fill number by ordering thru the refill node for the last
+18 ;refill number
+19 SET FILNUM=0
FOR REF=0:0
SET REF=$ORDER(^PSRX(PSXPTR,1,REF))
if REF'>0
QUIT
if REF>0
SET FILNUM=REF
if REF=""
SET FILNUM=0
+20 ;I $G(PSXFLAG)=2 S PSXOK=0 Q
+21 SET RXF=FILNUM
+22 SET REL=$SELECT(RXF>0:$PIECE($GET(^PSRX(RXN,1,RXF,0)),U,18),RXF=0:$PIECE($GET(^PSRX(RXN,2)),U,13),1:"")
IF $GET(REL)'=""
SET PSXOK=6
+23 if ((PSXOK=0)&(FILNUM>0)&($PIECE($GET(^PSRX(PSXPTR,1,FILNUM,0)),"^",2)'="M"))
SET PSXOK=3
+24 if ((PSXOK=0)&(FILNUM'>0)&($PIECE($GET(^PSRX(PSXPTR,0)),"^",11)'="M"))
SET PSXOK=3
+25 IF $GET(^PS(52.5,REC,"P"))="1"
SET PSXOK=4
+26 SET PSXDIV=$SELECT(FILNUM=0:$PIECE($GET(^PSRX(PSXPTR,2)),U,9),FILNUM>0:$PIECE($GET(^PSRX(PSXPTR,1,FILNUM,0)),"^",9),1:"")
+27 ;If trans div does not match Rx div eliminate
+28 IF PSXDIV'=PSOSITE
SET PSXOK=7
QUIT
+29 ; Changes for Controlled subs
+30 NEW PSXCSC,PSXCSD
SET PSXCSRX=""
+31 SET PSXCSC=$PIECE($GET(^PSDRUG(RXNUM,0)),"^",3)
+32 ;Can't trans DEA schedule 1 or 2
+33 IF $GET(PSXCSC)[1!($GET(PSXCSC)[2)
SET PSXOK=10
QUIT
+34 ;If CS must be DEA 3-5 to qualify
+35 FOR PSXCSD=3:1:5
IF PSXCSC[PSXCSD
SET PSXCSRX=1
+36 ;If not CS drug and CS trans eliminate
+37 IF ($GET(PSXCSRX)<1)&($GET(PSXCS)=1)
SET PSXOK=9
QUIT
+38 ;If CS drug and not CS trans eliminate
+39 IF ($GET(PSXCSRX)=1)&($GET(PSXCS)<1)
SET PSXOK=9
QUIT
+40 ; Checks for do not mail and expiration date thereof
+41 ; moved to under NOGO
+42 ;
+43 if PSXOK'=0
GOTO STOP
NOGO ;any rx that does not pass the following checks will not be transmitted
+1 ;and an error message will be generated and sent to the user who
+2 ;initiated the transmission. All that pass the checks will be sent.
+3 SET RXERR=0
SET PSXRXERR=RXEX_"^"_RXF
+4 IF RXEX[" "
SET RXERR=13
SET PSXRXERR=PSXRXERR_"^"_RXERR
+5 SET QTY=$SELECT(RXF>0:$PIECE($GET(^PSRX(RXN,1,RXF,0)),U,4),RXF=0:$PIECE($GET(^PSRX(RXN,0)),U,7),1:"")
if $GET(QTY)'=""&($GET(QTY)>0)&(QTY?.N)!(QTY?.N1".".N)
GOTO NG1
SET RXERR=2
SET PSXRXERR=PSXRXERR_"^"_RXERR
NG1 SET PHY=$SELECT(RXF>0:$PIECE($GET(^PSRX(RXN,1,RXF,0)),U,17),RXF=0:$PIECE($GET(^PSRX(RXN,0)),U,4),1:"")
IF PHY=""
SET RXERR=3
SET PSXRXERR=PSXRXERR_"^"_RXERR
+1 SET DAYS=$SELECT(RXF>0:$PIECE($GET(^PSRX(RXN,1,RXF,0)),U,10),RXF=0:$PIECE($GET(^PSRX(RXN,0)),U,8),1:"")
IF (DAYS'>0)!(DAYS="")
SET RXERR=4
SET PSXRXERR=PSXRXERR_"^"_RXERR
+2 SET PHARCLK=$SELECT(RXF>0:$PIECE($GET(^PSRX(RXN,1,RXF,0)),U,7),RXF=0:$PIECE($GET(^PSRX(RXN,0)),U,16),1:"")
IF PHARCLK=""
SET RXERR=9
SET PSXRXERR=PSXRXERR_"^"_RXERR
+3 SET DRUG=$PIECE($GET(^PSRX(RXN,0)),U,6)
SET PSTAT=$PIECE($GET(^(0)),U,3)
SET FDATE=$PIECE($GET(^PSRX(RXN,2)),U,2)
+4 DO TSTSIG
+5 SET DFN=$PIECE($GET(^PSRX(RXN,0)),U,2)
DO ADD^VADPT
IF (($GET(VAPA(1))="")!($GET(VAPA(4))="")!($PIECE($GET(VAPA(5)),"^",2)="")!($GET(VAPA(6))'>0)!($PIECE($GET(VAPA(11)),"^",2)'>0))
IF (($$BADADR^DGUTL3(DFN))'>0)
SET RXERR=10
SET PSXRXERR=PSXRXERR_"^"_RXERR
+6 DO DEM^VADPT
+7 IF VADM(1)["MERGING"
SET RXERR=17
SET PSXRXERR=PSXRXERR_"^"_RXERR
+8 ;MVP OIFO BAY PINES;ELR;PSX*2*52 CHANGED RXERR FROM 10 TO 19. ADDED NEW ERROR IN PSXERR
+9 ; SSN ["000-00" indicates test patient
IF $GET(VA("PID"))["000-00"
SET RXERR=19
SET PSXRXERR=PSXRXERR_"^"_RXERR
+10 SET (CNTR,XC,DUPFLG)=0
SET DUPRX=""
FOR
SET XC=$ORDER(^PSRX("B",RXEX,XC))
if XC'>0
QUIT
SET CNTR=CNTR+1
SET DUPRX=DUPRX_"^"_XC
+11 IF CNTR>1
Begin DoDot:1
+12 if $PIECE(DUPRX,"^",3)=""
QUIT
+13 FOR I2=2:1
SET I1=$PIECE(DUPRX,"^",I2)
if I1=""
QUIT
SET PSREC=$ORDER(^PS(52.5,"B",I1,""))
if $GET(PSREC)'>0
QUIT
if ($PIECE(^PS(52.5,PSREC,0),"^",2)<PSXDTRG&($PIECE(^PS(52.5,PSREC,0),"^",7)="Q"))
SET DUPFLG=1
End DoDot:1
+14 if $GET(DUPFLG)>0
SET PSXRXERR=PSXRXERR_"^"_"14"
+15 KILL CNTR,XC,DUPRX,I2,I1,PSREC,DUPFLG
+16 IF $DATA(^PSRX(PSXPTR,4,0))
Begin DoDot:1
+17 SET RXERR=""
+18 SET ZX=0
FOR
SET ZX=$ORDER(^PSRX(PSXPTR,4,ZX))
if ZX'>0
QUIT
Begin DoDot:2
+19 IF $PIECE(^PSRX(PSXPTR,4,ZX,0),"^",3)=RXF&($PIECE(^PSRX(PSXPTR,4,ZX,0),"^",4)'=3)
SET RXERR=12
+20 IF $PIECE(^PSRX(PSXPTR,4,ZX,0),"^",3)=RXF&($PIECE(^PSRX(PSXPTR,4,ZX,0),"^",4)=3)
SET RXERR=""
End DoDot:2
+21 IF RXERR'=""
SET PSXRXERR=PSXRXERR_"^"_RXERR
End DoDot:1
+22 IF DRUG=""
SET RXERR=5
SET PSXRXERR=PSXRXERR_"^"_RXERR
+23 IF DRUG
SET WARNS=$PIECE(^PSDRUG(DRUG,0),"^",8)
Begin DoDot:1
+24 ;IF USING NEW WARNING SOURCE, LENGTH OF OLD WARNINGS DOESN'T MATTER
+25 IF '$DATA(PSSWSITE)
SET PSSWSITE=+$ORDER(^PS(59.7,0))
+26 IF $PIECE($GET(^PS(59.7,PSSWSITE,10)),"^",10)="N"
QUIT
+27 IF $GET(WARNS)
if $LENGTH(WARNS)>11
SET RXERR=16
SET PSXRXERR=PSXRXERR_"^"_RXERR
End DoDot:1
+28 IF SIG=""
SET RXERR=6
SET PSXRXERR=PSXRXERR_"^"_RXERR
+29 IF PSTAT=""
SET RXERR=7
SET PSXRXERR=PSXRXERR_"^"_RXERR
+30 IF FDATE'?7N
SET RXERR=8
SET PSXRXERR=PSXRXERR_"^"_RXERR
+31 IF '$$MAILOK(RXN)
Begin DoDot:1
+32 SET COM="Removed from CMOP Suspense - Mail Status Change"
DO NOW^%DTC
SET DTTM=%
KILL %
DO ACTLOG^PSXRPPL
+33 DO DELETE^PSXRPPL
SET PSXOK=1
+34 ;MVP OIFO BAY PINES;ELR;PSX*2*5 DELETE MM MSG FOR DO NOT MAIL
+35 ;S RXERR=15,PSXRXERR=PSXRXERR_"^"_RXERR ;mail message to users
End DoDot:1
+36 IF $DATA(^TMP($JOB,"PSXBAI",DFN))
IF '$GET(^TMP($JOB,"PSXBAI",DFN))
Begin DoDot:1
+37 SET PSXOK=8
+38 DO CHKACT(PSXPTR)
+39 IF '$GET(PSXFIRST)
KILL PSXRXERR
QUIT
+40 SET COM="Bad Address Indicator or Foreign Address. Not removed from CMOP Suspense"
DO NOW^%DTC
SET DTTM=%
KILL %
DO ACTLOG^PSXRPPL
+41 ;mail message to users
SET RXERR=20
SET PSXRXERR=PSXRXERR_"^"_RXERR
End DoDot:1
PSOMSG ; from PSSLOCK
IF +PSOMSG=0
SET RXERR=18
SET PSXRXERR=PSXRXERR_"^"_RXERR
+1 IF $PIECE($GET(PSXRXERR),"^",3)'=""
SET PSXOK=8
DO ER7^PSXERR
STOP KILL DAYS,DRUG,FDATE,PHARCLK,PHY,PSTAT,QTY,RXERR,RXEX,SIG,VAPA(1),DRUGCHK,PTRA,PTRB,REL,RXNUM,PHARCLK1,ZX,VAPA(4),VAPA(5),VAPA(6)
+1 QUIT
+2 ;
TSTSIG ; include testing for BAD characters in SIG
+1 IF $PIECE(^PSRX(RXN,"SIG"),"^",2)'>0
SET SIG=$PIECE(^PSRX(RXN,"SIG"),"^")
DO TSTCHAR
+2 IF $PIECE(^PSRX(RXN,"SIG"),"^",2)=1
NEW L
SET L=0
FOR
SET L=$ORDER(^PSRX(RXN,"SIG1",L))
if L'>0
QUIT
SET SIG=$GET(^PSRX(RXN,"SIG1",L,0))
DO TSTCHAR
if SIG=""
QUIT
+3 QUIT
TSTCHAR ; test each character of SIG for certain characters
+1 NEW I,C
+2 IF '$DATA(^TMP($JOB,"PSXCHAR"))
Begin DoDot:1
+3 FOR I=0:1:31
SET ^TMP($JOB,"PSXCHAR",I)=""
+4 FOR I=92,94,124,127
SET ^TMP($JOB,"PSXCHAR",I)=""
End DoDot:1
+5 FOR I=1:1:$LENGTH(SIG)
SET C=$ASCII($EXTRACT(SIG,I))
IF $DATA(^TMP($JOB,"PSXCHAR",C))
SET SIG=""
QUIT
+6 QUIT
MAILOK(TRX) ; return 1 if patient still in mail status & ok to CMOP
+1 NEW PSOMDT,PSOMC,DFN
+2 SET DFN=$PIECE(^PSRX(TRX,0),"^",2)
SET PSOMDT=$PIECE($GET(^PS(55,DFN,0)),"^",5)
SET PSOMC=$PIECE($GET(^PS(55,DFN,0)),"^",3)
+3 ;p98
IF $$GET1^DIQ(52,TRX,100.2,"I")]""
SET PSOMC=$$GET1^DIQ(52,TRX,100.2,"I")
SET PSOMDT=""
+4 IF (PSOMC>1&(PSOMDT>DT))!(PSOMC>1&(PSOMDT<1))
QUIT 0
+5 QUIT 1
ADDROK(TRX) ; return 1 if not foreign and not bad address indicator
+1 NEW DFN,PSOFORGN
+2 SET DFN=$PIECE($GET(^PSRX(TRX,0)),"^",2)
IF DFN=""
if 0
QUIT
+3 ;BHW;PSX*2*64;Changed Quit below from Q:+(^TMP... to Q +(^TMP...
+4 IF $DATA(^TMP($JOB,"PSXBAI",DFN))
QUIT +(^TMP($JOB,"PSXBAI",DFN))
+5 DO ADD^VADPT
+6 SET PSOFORGN=$PIECE($GET(VAPA(25)),"^",2)
IF PSOFORGN'=""
IF PSOFORGN'["UNITED STATES"
SET PSOFORGN=1
+7 IF PSOFORGN
SET ^TMP($JOB,"PSXBAI",DFN)=0
QUIT 0
+8 IF $TEXT(CHKRX^PSOBAI)']""
SET ^TMP($JOB,"PSXBAI",DFN)=1
QUIT 1
+9 NEW PSORX,PSOBADR
+10 SET PSORX=TRX
+11 SET PSOBADR=$$CHKRX^PSOBAI(PSORX)
+12 IF '$PIECE(PSOBADR,"^")
SET ^TMP($JOB,"PSXBAI",DFN)=1
QUIT 1
+13 IF $PIECE(PSOBADR,"^",2)=1
SET ^TMP($JOB,"PSXBAI",DFN)=1
QUIT 1
+14 SET ^TMP($JOB,"PSXBAI",DFN)=0
+15 QUIT 0
+16 ;
CHKACT(RXN) ; SEE IF FILL IS ALREADY ON ACTIVITY LOG FOR FOREIGN OR BAD ADDRESS
+1 NEW JJ,RFCNT,XX,COM
+2 SET PSXFIRST=1
+3 SET COM="Bad Address Indicator or Foreign Address."
+4 SET RFCNT=0
FOR RF=0:0
SET RF=$ORDER(^PSRX(RXN,1,RF))
if 'RF
QUIT
SET RFCNT=$SELECT(RF<6:RF,1:RF+1)
+5 SET JJ=0
FOR
SET JJ=$ORDER(^PSRX(RXN,"A",JJ))
if 'JJ
QUIT
SET XX=$GET(^PSRX(RXN,"A",JJ,0))
IF $PIECE(XX,"^",4)=RFCNT
IF $PIECE(XX,"^",5)[COM
SET PSXFIRST=0
QUIT
+6 QUIT
