- 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**;11 Apr 97;Build 1
- ;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 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) 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 (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
- 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**;11 Apr 97;Build 1
- +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 PROD2^PSNAPIS supported by DBIA #2531
- +7 ;Reference to ^PSSLOCK supported by DBIA #2789
- +8 ;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)
- 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 IF (PSOMC>1&(PSOMDT>DT))!(PSOMC>1&(PSOMDT<1))
- QUIT 0
- +4 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
