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

revised back to 6/30/08 version

Location:
WorldVistAEHR/trunk/r/CMOP-PSX
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/CMOP-PSX/PSXBLD1.m

    r613 r623  
    1 PSXBLD1 ;BIR/BAB,HTW,WPB-Document Data for Transmission ;10/15/98  10:38 AM
    2         ;;2.0;CMOP;**3,18,19,42,41,49,57,64**;11 Apr 97;Build 1
    3         ;Reference to  ^PSRX(     supported by DBIA #1977
    4         ;Reference to  ^PSDRUG(   supported by DBIA #1983
    5         ;Reference to  ^PS(55,    supported by DBIA #2228
    6         ;Reference to  ^PS(59.7,  supported by DBIA #694
    7         ;Reference to  ^PS(59,    supported by DBIA #1976
    8         ;Reference to PROD2^PSNAPIS supported by DBIA #2531
    9 MRX     ;Multi rx
    10         G:'$P(PSOPAR,"^",18) SUS
    11         F ZZ=0:0 S ZZ=$O(^PS(55,DFN,"P",ZZ)) Q:'ZZ  S NBR=0 D RZX
    12 BUILD   ;
    13         F PSA=0:0 S PSA=$O(RX(PSA)) Q:'PSA  D SCRNEW
    14         K NAME,REFILL,PSDT2,NBR,PSRX,PSA,TN,AMC,PSRFL,X1,X2,PSRXX,RXNUM,ZZ
    15         G SUS
    16 SCRNEW  ;
    17         S IEN50=+$P(^PSRX(PSA,0),U,6),NAME=$P(^PSDRUG(IEN50,0),U)
    18         I '$D(^PSDRUG(IEN50,"ND")) G S1
    19         S IENDF=$P($G(^PSDRUG(IEN50,"ND")),U),ZD1=$P($G(^("ND")),U,3)
    20         I $G(IENDF),($G(ZD1)) S ZX=$$PROD2^PSNAPIS(IENDF,ZD1),ZNDF=$P($G(ZX),"^")
    21 S1      S ZPRT=$S($G(ZNDF):ZNDF,1:NAME) K ZNDF,IENDF,NAME,IEN50,ZD1
    22         S ZPRT=$E(ZPRT,1,30)
    23         S REFILL=$P(RX(PSA),"^",2)
    24         S PSDT2=$P(RX(PSA),"^",1),PSDT2=PSDT2+17000000
    25         S RXNUM=$P($G(^PSRX(PSA,0)),"^")
    26         S NBR=NBR+1,PSXORD("M",NBR)="NTE|5||"_RXNUM_"\F\"_ZPRT_"\F\"_REFILL_"\F\"_PSDT2_$S($P(PSOPAR,"^",19):"\F\"_PSOINST_"-"_PSA,1:"")
    27         Q
    28 REFILL  F AMC=0:0 S AMC=$O(^PSRX(PSRXX,1,AMC)) Q:'AMC  S PSRFL=PSRFL-1
    29         I PSRFL>0 S X1=DT,X2=$P(^PSRX(PSRXX,0),"^",8)-10 D C^%DTC I X'<$P(^(2),"^",6) S PSRFL=0
    30         Q
    31 RZX     S PSRXX=+^PS(55,DFN,"P",ZZ,0) I $D(^PSRX(PSRXX,0)) S PSRFL=$P(^(0),"^",9) D:$D(^(1))&PSRFL REFILL I PSRFL>0,$P(^PSRX(PSRXX,"STA"),"^",1)<10,13456'[$E($P(^("STA"),"^",1)),$P(^(2),"^",6)>DT S RX(PSRXX)=$P(^(2),"^",6)_"^"_PSRFL
    32         Q
    33 SUS     ;Susp Notif-(PSXDTRG-last date transmitted)
    34         Q:'$G(DFN)!('$G(PSXDTRG))
    35         S CT=1
    36         F I=PSXDTRG:0 S I=$O(^PS(55,DFN,"P","A",I)) Q:'I  D
    37         .F J=0:0 S J=$O(^PS(55,DFN,"P","A",I,J)) Q:'J  S JJ=J D:$D(JJ)  S CT=CT+1
    38         ..S NODE=$G(^PSRX(JJ,0)) Q:NODE']""
    39         ..S STATUS=+$P(^PSRX(JJ,"STA"),"^",1) Q:STATUS'=5!(STATUS>10)
    40         ..Q:$D(^PSX(550.2,PSXBAT,15,"B",JJ))    ;built in PSXRPPL  PSX*2*42
    41         ..S ERX=$P(NODE,U)
    42         ..S IEN50=$P(NODE,"^",6),NAME=$P(^PSDRUG(IEN50,0),U)
    43         ..I '$D(^PSDRUG(IEN50,"ND")) G S2
    44         ..S IENDF=$P($G(^PSDRUG(IEN50,"ND")),U),ZD1=$P($G(^("ND")),U,3)
    45         ..I $G(IENDF),($G(ZD1)) S ZX=$$PROD2^PSNAPIS(IENDF,ZD1),ZNDF=$P($G(ZX),"^")
    46 S2      ..S ZPRT=$S($G(ZNDF):ZNDF,1:NAME)
    47         ..S ZPRT=$E(ZPRT,1,30)
    48         ..S PSXORD("E",CT)="NTE|6||"_ERX_"\F\"_ZPRT
    49         ..K NODE,STATUS,ERX,IEN50,IENDF,ZD1,ZNDF,ZPRT,NAME,ZX
    50         K I,J,NODE,STATUS,JJ,ZPRT,NAME,IENDF,IEN50,CT,RX
    51         Q
    52 DIV     ;NTE|1||Site #\S\Div Name\S\Facility #\F\Street Add 1\S\Street Add 2\S\City\S\State Abbrev\S\Zip Code\F\Area Code & Phone #
    53         S PSXERFLG=0,PSXER=3
    54         S TNODE=$G(^PS(59,PSOSITE,0))
    55         ;Set site address to refill div if selected in system parameters
    56         I $P($G(^PS(59.7,1,40.1)),"^",4) S REFDIV=$P(^(40.1),"^",4) D
    57         .S TNODE1=$G(^PS(59,REFDIV,0)),TNODE=TNODE1 K TNODE1
    58         S PSXFAC=$P($G(PSXSYS),U,2)
    59         S STATE=$P(TNODE,"^",8),SITE=$P(TNODE,U,6) S (TEMP,Y)=TNODE
    60         S:STATE="" PSXER=PSXER_"^"_1,PSXERFLG=1
    61         S:SITE="" PSXER=PSXER_"^"_2,PSXERFLG=1
    62         S:$P(TNODE,U,1)="" PSXER=PSXER_"^"_3,PSXERFLG=1
    63         S:$P(TNODE,U,2)="" PSXER=PSXER_"^"_4,PSXERFLG=1
    64         S:$P(TNODE,U,7)="" PSXER=PSXER_"^"_5,PSXERFLG=1
    65         S:$P(TNODE,U,5)="" PSXER=PSXER_"^"_6,PSXERFLG=1
    66         S:$P(TNODE,U,3)="" PSXER=PSXER_"^"_7,PSXERFLG=1
    67         S:$P(TNODE,U,4)="" PSXER=PSXER_"^"_8,PSXERFLG=1
    68         ;VMP OIFO BAY PINES;ELR;PSX*2*57  SET PSXERFLG=0 NEXT LINE AND LINE AFTER THAT
    69         I PSXERFLG=1 D ER1^PSXERR S PSXERFLG=0,PSXDIVER=1 Q
    70         Q:$G(PSXPRECK)=1
    71         S SZIP=$P(TNODE,U,5) I $L(SZIP)>5 S SZIP=$E(SZIP,1,5)_"-"_$E(SZIP,6,9)
    72         S PSXORD("A")="NTE|1||"_SITE_"\S\"_$P(TNODE,U,1)_"\S\"_PSXFAC_"\F\"_$P(TNODE,U,2)_"\S\\S\"_$P(TNODE,U,7)_"\S\"_$P(^DIC(5,STATE,0),U,2)_"\S\"_SZIP_"\F\"_"("_$P(TNODE,U,3)_") "_$P(TNODE,U,4)
    73         K SZIP
    74 ORD     ;
    75         S DIWL=1,DIWR=45,DIWF="C45"
    76         F NODE=6,7,4 K ^UTILITY($J,"W") S (RECL,REC)=0 F  S REC=$O(^PS(59,PSOSITE,NODE,REC)) Q:REC'>0  S X=^(REC,0),NODE=NODE D
    77         . I REC'>7 S Y=X D STRIP^PSXBLD S X=Y D ^DIWP,SET I 1
    78         . E  S WARN(NODE)=REC
    79         D:$D(WARN) WARN
    80         K DIWF,DIWL,DIWR,I,NODE,STATE,SITE,TNODE,NUM,REC,Y,Y,X,Z,^UTILITY($J,"W")
    81         Q
    82 WARN    ;send msg
    83         S XMSUB=">>WARNING<< CMOP Pharmacy Site Prescription Instructions"
    84         ;N TXT,XT
    85         S XT(6)="NARRATIVE REFILLABLE RX"
    86         S XT(7)="NARRATIVE NON REFILLABLE RX"
    87         S XT(4)="NARRATIVE FOR COPAY DOCUMENT"
    88         S TXT(1)="The following Pharmacy Site instruction(s) exceed seven lines."
    89         S TXT(2)="This exceeds CMOP limits."
    90         S TXT(3)="Lines beyond seven are not being sent to the CMOP."
    91         S TXT(4)=" ",TXT(5)="Pharmacy Site: "_$$GET1^DIQ(59,PSOSITE,.01),L=5
    92         F NODE=6,7,4 I $DATA(WARN(NODE)) S L=L+1,TXT(L)=XT(NODE)_"     "_WARN(NODE)_" lines"
    93         S XMTEXT="TXT("
    94         D GRP1^PSXNOTE
    95         S XMY(DUZ)=""
    96         D ^XMD
    97         Q
    98 SET     ;
    99         K PSXORDD S NUM=0
    100         F  S NUM=$O(^UTILITY($J,"W",1,NUM)) Q:NUM'>0  S PSXORDD(NUM)=$G(^UTILITY($J,"W",1,NUM,0)) S PSXORDD(NUM)=$S(NODE=4:"NTE|4||"_PSXORDD(NUM),NODE=6:"NTE|2||"_PSXORDD(NUM),NODE=7:"NTE|3||"_PSXORDD(NUM),1:0)
    101         ;F CNT=1:2 S CNT=$O(PSXORDD(CNT)) Q:CNT=""  S XX=$L(PSXORDD(CNT)),PSXORDD(CNT-1)=PSXORDD(CNT-1)_"\R\"_$E(PSXORDD(CNT),8,XX) K PSXORDD(CNT)
    102         S %X="PSXORDD(",%Y=$S(NODE=4:"PSXORD(""D"",",NODE=6:"PSXORD(""B"",",NODE=7:"PSXORD(""C"",",1:0) D %XY^%RCR K %X,%Y,TEMP
    103         Q
     1PSXBLD1 ;BIR/BAB,HTW,WPB-Document Data for Transmission ;10/15/98  10:38 AM
     2 ;;2.0;CMOP;**3,18,19,42,41,49,57**;11 Apr 97
     3 ;Reference to  ^PSRX(     supported by DBIA #1977
     4 ;Reference to  ^PSDRUG(   supported by DBIA #1983
     5 ;Reference to  ^PS(55,    supported by DBIA #2228
     6 ;Reference to  ^PS(59.7,  supported by DBIA #694
     7 ;Reference to  ^PS(59,    supported by DBIA #1976
     8 ;Reference to PROD2^PSNAPIS supported by DBIA #2531
     9MRX ;Multi rx
     10 G:'$P(PSOPAR,"^",18) SUS
     11 F ZZ=0:0 S ZZ=$O(^PS(55,DFN,"P",ZZ)) Q:'ZZ  S NBR=0 D RZX
     12BUILD ;
     13 F PSA=0:0 S PSA=$O(RX(PSA)) Q:'PSA  D SCRNEW
     14 K NAME,REFILL,PSDT2,NBR,PSRX,PSA,TN,AMC,PSRFL,X1,X2,PSRXX,RXNUM,ZZ
     15 G SUS
     16SCRNEW ;
     17 S IEN50=+$P(^PSRX(PSA,0),U,6),NAME=$P(^PSDRUG(IEN50,0),U)
     18 I '$D(^PSDRUG(IEN50,"ND")) G S1
     19 S IENDF=$P($G(^PSDRUG(IEN50,"ND")),U),ZD1=$P($G(^("ND")),U,3)
     20 I $G(IENDF),($G(ZD1)) S ZX=$$PROD2^PSNAPIS(IENDF,ZD1),ZNDF=$P($G(ZX),"^")
     21S1 S ZPRT=$S($G(ZNDF):ZNDF,1:NAME) K ZNDF,IENDF,NAME,IEN50,ZD1
     22 S ZPRT=$E(ZPRT,1,30)
     23 S REFILL=$P(RX(PSA),"^",2)
     24 S PSDT2=$P(RX(PSA),"^",1),PSDT2=PSDT2+17000000
     25 S RXNUM=$P($G(^PSRX(PSA,0)),"^")
     26 S NBR=NBR+1,PSXORD("M",NBR)="NTE|5||"_RXNUM_"\F\"_ZPRT_"\F\"_REFILL_"\F\"_PSDT2_$S($P(PSOPAR,"^",19):"\F\"_PSOINST_"-"_PSA,1:"")
     27 Q
     28REFILL F AMC=0:0 S AMC=$O(^PSRX(PSRXX,1,AMC)) Q:'AMC  S PSRFL=PSRFL-1
     29 I PSRFL>0 S X1=DT,X2=$P(^PSRX(PSRXX,0),"^",8)-10 D C^%DTC I X'<$P(^(2),"^",6) S PSRFL=0
     30 Q
     31RZX S PSRXX=+^PS(55,DFN,"P",ZZ,0) I $D(^PSRX(PSRXX,0)) S PSRFL=$P(^(0),"^",9) D:$D(^(1))&PSRFL REFILL I PSRFL>0,$P(^PSRX(PSRXX,"STA"),"^",1)<10,13456'[$E($P(^("STA"),"^",1)),$P(^(2),"^",6)>DT S RX(PSRXX)=$P(^(2),"^",6)_"^"_PSRFL
     32 Q
     33SUS ;Susp Notif-(PSXDTRG-last date transmitted)
     34 Q:'$G(DFN)!('$G(PSXDTRG))
     35 S CT=1
     36 F I=PSXDTRG:0 S I=$O(^PS(55,DFN,"P","A",I)) Q:'I  D
     37 .F J=0:0 S J=$O(^PS(55,DFN,"P","A",I,J)) Q:'J  S JJ=J D:$D(JJ)  S CT=CT+1
     38 ..S NODE=$G(^PSRX(JJ,0)) Q:NODE']""
     39 ..S STATUS=+$P(^PSRX(JJ,"STA"),"^",1) Q:STATUS'=5!(STATUS>10)
     40 ..Q:$D(^PSX(550.2,PSXBAT,15,"B",JJ))    ;built in PSXRPPL  PSX*2*42
     41 ..S ERX=$P(NODE,U)
     42 ..S IEN50=$P(NODE,"^",6),NAME=$P(^PSDRUG(IEN50,0),U)
     43 ..I '$D(^PSDRUG(IEN50,"ND")) G S2
     44 ..S IENDF=$P($G(^PSDRUG(IEN50,"ND")),U),ZD1=$P($G(^("ND")),U,3)
     45 ..I $G(IENDF),($G(ZD1)) S ZX=$$PROD2^PSNAPIS(IENDF,ZD1),ZNDF=$P($G(ZX),"^")
     46S2 ..S ZPRT=$S($G(ZNDF):ZNDF,1:NAME)
     47 ..S ZPRT=$E(ZPRT,1,30)
     48 ..S PSXORD("E",CT)="NTE|6||"_ERX_"\F\"_ZPRT
     49 ..K NODE,STATUS,ERX,IEN50,IENDF,ZD1,ZNDF,ZPRT,NAME,ZX
     50 K I,J,NODE,STATUS,JJ,ZPRT,NAME,IENDF,IEN50,CT,RX
     51 Q
     52DIV ;NTE|1||Site #\S\Div Name\S\Facility #\F\Street Add 1\S\Street Add 2\S\City\S\State Abbrev\S\Zip Code\F\Area Code & Phone #
     53 S PSXERFLG=0,PSXER=3
     54 S TNODE=$G(^PS(59,PSOSITE,0))
     55 ;Set site address to refill div if selected in system parameters
     56 I $P($G(^PS(59.7,1,40.1)),"^",4) S REFDIV=$P(^(40.1),"^",4) D
     57 .S TNODE1=$G(^PS(59,REFDIV,0)),TNODE=TNODE1 K TNODE1
     58 S PSXFAC=$P($G(PSXSYS),U,2)
     59 S STATE=$P(TNODE,"^",8),SITE=$P(TNODE,U,6) S (TEMP,Y)=TNODE
     60 S:STATE="" PSXER=PSXER_"^"_1,PSXERFLG=1
     61 S:SITE="" PSXER=PSXER_"^"_2,PSXERFLG=1
     62 S:$P(TNODE,U,1)="" PSXER=PSXER_"^"_3,PSXERFLG=1
     63 S:$P(TNODE,U,2)="" PSXER=PSXER_"^"_4,PSXERFLG=1
     64 S:$P(TNODE,U,7)="" PSXER=PSXER_"^"_5,PSXERFLG=1
     65 S:$P(TNODE,U,5)="" PSXER=PSXER_"^"_6,PSXERFLG=1
     66 S:$P(TNODE,U,3)="" PSXER=PSXER_"^"_7,PSXERFLG=1
     67 S:$P(TNODE,U,4)="" PSXER=PSXER_"^"_8,PSXERFLG=1
     68 ;VMP OIFO BAY PINES;ELR;PSX*2*57  SET PSXERFLG=0 NEXT LINE AND LINE AFTER THAT
     69 I PSXERFLG=1 D ER1^PSXERR S PSXERFLG=0,PSXDIVER=1 Q
     70 Q:$G(PSXPRECK)=1
     71 S SZIP=$P(TNODE,U,5) I $L(SZIP)>5 S SZIP=$E(SZIP,1,5)_"-"_$E(SZIP,6,9)
     72 S PSXORD("A")="NTE|1||"_SITE_"\S\"_$P(TNODE,U,1)_"\S\"_PSXFAC_"\F\"_$P(TNODE,U,2)_"\S\\S\"_$P(TNODE,U,7)_"\S\"_$P(^DIC(5,STATE,0),U,2)_"\S\"_SZIP_"\F\"_"("_$P(TNODE,U,3)_") "_$P(TNODE,U,4)
     73 K SZIP
     74ORD ;
     75 S DIWL=1,DIWR=45,DIWF="C45"
     76 F NODE=6,7,4 K ^UTILITY($J,"W") S (RECL,REC)=0 F  S REC=$O(^PS(59,PSOSITE,NODE,REC)) Q:REC'>0  S X=^(REC,0),NODE=NODE D
     77 . I REC'>7 S Y=X D STRIP^PSXBLD S X=Y D ^DIWP,SET I 1
     78 . E  S WARN(NODE)=REC
     79 D:$D(WARN) WARN
     80 K DIWF,DIWL,DIWR,I,NODE,STATE,SITE,TNODE,NUM,REC,Y,Y,X,Z,^UTILITY($J,"W")
     81 Q
     82WARN ;send msg
     83 S XMSUB=">>WARNING<< CMOP Pharmacy Site Prescription Instructions"
     84 ;N TXT,XT
     85 S XT(6)="NARRATIVE REFILLABLE RX"
     86 S XT(7)="NARRATIVE NON REFILLABLE RX"
     87 S XT(4)="NARRATIVE FOR COPAY DOCUMENT"
     88 S TXT(1)="The following Pharmacy Site instruction(s) exceed seven lines."
     89 S TXT(2)="This exceeds CMOP limits."
     90 S TXT(3)="Lines beyound seven are not being sent to the CMOP."
     91 S TXT(4)=" ",TXT(5)="Pharmacy Site: "_$$GET1^DIQ(59,PSOSITE,.01),L=5
     92 F NODE=6,7,4 I $DATA(WARN(NODE)) S L=L+1,TXT(L)=XT(NODE)_"     "_WARN(NODE)_" lines"
     93 S XMTEXT="TXT("
     94 D GRP1^PSXNOTE
     95 S XMY(DUZ)=""
     96 D ^XMD
     97 Q
     98SET ;
     99 K PSXORDD S NUM=0
     100 F  S NUM=$O(^UTILITY($J,"W",1,NUM)) Q:NUM'>0  S PSXORDD(NUM)=$G(^UTILITY($J,"W",1,NUM,0)) S PSXORDD(NUM)=$S(NODE=4:"NTE|4||"_PSXORDD(NUM),NODE=6:"NTE|2||"_PSXORDD(NUM),NODE=7:"NTE|3||"_PSXORDD(NUM),1:0)
     101 ;F CNT=1:2 S CNT=$O(PSXORDD(CNT)) Q:CNT=""  S XX=$L(PSXORDD(CNT)),PSXORDD(CNT-1)=PSXORDD(CNT-1)_"\R\"_$E(PSXORDD(CNT),8,XX) K PSXORDD(CNT)
     102 S %X="PSXORDD(",%Y=$S(NODE=4:"PSXORD(""D"",",NODE=6:"PSXORD(""B"",",NODE=7:"PSXORD(""C"",",1:0) D %XY^%RCR K %X,%Y,TEMP
     103 Q

  • WorldVistAEHR/trunk/r/CMOP-PSX/PSXMISC1.m

    r613 r623  
    1 PSXMISC1        ;BIR/WPB,BAB-Transmission Data Validation ;MAR 1,2002@13:13:34
    2         ;;2.0;CMOP;**3,18,23,28,30,42,41,52,54,58,64**;11 Apr 97;Build 1
    3         ;Reference to ^PSDRUG(  supported by DBIA #1983
    4         ;Reference to ^PS(52.5, supported by DBIA #1978
    5         ;Reference to ^PSRX(    supported by DBIA #1977
    6         ;Reference to ^PS(55,   supported by DBIA #2228
    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
    10 CHKDATA ;checks the data elements in PSRX before putting the rx in 550.2
    11         Q:'$D(^PS(52.5,REC,0))
    12         K DRUGCHK,PSXRXERR,PSXDGST,WARNS
    13         S (RXN,PSXPTR)=$P($G(^PS(52.5,REC,0)),"^",1) I PSXPTR="" S PSXOK=8 Q
    14         D PSOL^PSSLOCK(RXN) S PSOMSG=+PSOMSG ; sets PSOMSG
    15         I ($P(^PS(52.5,REC,0),U,3)'=XDFN)!($P(^PSRX(PSXPTR,0),U,2)'=XDFN) S PSXOK=8 Q
    16         I '$D(^PSRX(PSXPTR,0)) S PSXOK=8 Q
    17         S RXNUM=$P($G(^PSRX(PSXPTR,0)),"^",6),RXEX=$P($G(^PSRX(PSXPTR,0)),"^",1)
    18         I $G(^PSDRUG(RXNUM,"ND"))'="" D
    19         .S PTRA=$P($G(^PSDRUG(RXNUM,"ND")),U,1),PTRB=$P($G(^PSDRUG(RXNUM,"ND")),U,3)
    20         .I $G(PTRA)'="" S ZX=$$PROD2^PSNAPIS(PTRA,PTRB),DRUGCHK=$P($G(ZX),"^",3)
    21         S:$G(DRUGCHK)'="" PSXDGST=$P(ZX,"^",2)_"^"_$P(ZX,"^")
    22         I '$D(DRUGCHK) S DRUGCHK=0
    23         S:'$D(^PSDRUG("AQ",RXNUM)) PSXOK=1
    24         S:$G(DRUGCHK)'=1 PSXOK=1
    25         I $P(^PSDRUG(RXNUM,2),"^",3)'["O" S PSXOK=1,PSXCK=RXNUM D UNMARK^PSXUTL
    26         S:$P($G(^PSRX(PSXPTR,"STA")),U,1)'=5 PSXOK=5
    27         ;gets the fill number by ordering thru the refill node for the last
    28         ;refill number
    29         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
    30         ;I $G(PSXFLAG)=2 S PSXOK=0 Q
    31         S RXF=FILNUM
    32         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
    33         S:((PSXOK=0)&(FILNUM>0)&($P($G(^PSRX(PSXPTR,1,FILNUM,0)),"^",2)'="M")) PSXOK=3
    34         S:((PSXOK=0)&(FILNUM'>0)&($P($G(^PSRX(PSXPTR,0)),"^",11)'="M")) PSXOK=3
    35         I $G(^PS(52.5,REC,"P"))="1" S PSXOK=4
    36         S PSXDIV=$S(FILNUM=0:$P($G(^PSRX(PSXPTR,2)),U,9),FILNUM>0:$P($G(^PSRX(PSXPTR,1,FILNUM,0)),"^",9),1:"")
    37         ;If trans div does not match Rx div eliminate
    38         I PSXDIV'=PSOSITE S PSXOK=7 Q
    39         ; Changes for Controlled subs
    40         N PSXCSC,PSXCSD S PSXCSRX=""
    41         S PSXCSC=$P($G(^PSDRUG(RXNUM,0)),"^",3)
    42         ;Can't trans DEA schedule 1 or 2
    43         I $G(PSXCSC)[1!$G(PSXCSC)[2 S PSXOK=10 Q
    44         ;If CS must be DEA 3-5 to qualify
    45         F PSXCSD=3:1:5 I PSXCSC[PSXCSD S PSXCSRX=1
    46         ;If not CS drug and CS trans eliminate
    47         I ($G(PSXCSRX)<1)&($G(PSXCS)=1) S PSXOK=9 Q
    48         ;If CS drug and not CS trans eliminate
    49         I ($G(PSXCSRX)=1)&($G(PSXCS)<1) S PSXOK=9 Q
    50         ; Checks for do not mail and expiration date thereof
    51         ; moved to under NOGO
    52         ;
    53         G:PSXOK'=0 STOP
    54 NOGO    ;any rx that does not pass the following checks will not be transmitted
    55         ;and an error message will be generated and sent to the user who
    56         ;initiated the transmission.  All that pass the checks will be sent.
    57         S RXERR=0,PSXRXERR=RXEX_"^"_RXF
    58         I RXEX[" " S RXERR=13,PSXRXERR=PSXRXERR_"^"_RXERR
    59         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
    60 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
    61         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
    62         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
    63         S DRUG=$P($G(^PSRX(RXN,0)),U,6),PSTAT=$P($G(^(0)),U,3),FDATE=$P($G(^PSRX(RXN,2)),U,2)
    64         D TSTSIG
    65         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
    66         D DEM^VADPT
    67         I VADM(1)["MERGING" S RXERR=17,PSXRXERR=PSXRXERR_"^"_RXERR
    68         ;MVP OIFO BAY PINES;ELR;PSX*2*52  CHANGED RXERR FROM 10 TO 19. ADDED NEW ERROR IN PSXERR
    69         I $G(VA("PID"))["000-00" S RXERR=19,PSXRXERR=PSXRXERR_"^"_RXERR ; SSN ["000-00" indicates test patient
    70         S (CNTR,XC,DUPFLG)=0,DUPRX="" F  S XC=$O(^PSRX("B",RXEX,XC)) Q:XC'>0  S CNTR=CNTR+1,DUPRX=DUPRX_"^"_XC
    71         I CNTR>1 D
    72         .Q:$P(DUPRX,"^",3)=""
    73         .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
    74         S:$G(DUPFLG)>0 PSXRXERR=PSXRXERR_"^"_"14"
    75         K CNTR,XC,DUPRX,I2,I1,PSREC,DUPFLG
    76         I $D(^PSRX(PSXPTR,4,0)) D
    77         .S RXERR=""
    78         .S ZX=0 F  S ZX=$O(^PSRX(PSXPTR,4,ZX)) Q:ZX'>0  D
    79         ..I $P(^PSRX(PSXPTR,4,ZX,0),"^",3)=RXF&($P(^PSRX(PSXPTR,4,ZX,0),"^",4)'=3) S RXERR=12
    80         ..I $P(^PSRX(PSXPTR,4,ZX,0),"^",3)=RXF&($P(^PSRX(PSXPTR,4,ZX,0),"^",4)=3) S RXERR=""
    81         .I RXERR'="" S PSXRXERR=PSXRXERR_"^"_RXERR
    82         I DRUG="" S RXERR=5,PSXRXERR=PSXRXERR_"^"_RXERR
    83         I DRUG S WARNS=$P(^PSDRUG(DRUG,0),"^",8) D
    84         .;IF USING NEW WARNING SOURCE, LENGTH OF OLD WARNINGS DOESN'T MATTER
    85         .I '$D(PSSWSITE) S PSSWSITE=+$O(^PS(59.7,0))
    86         .I $P($G(^PS(59.7,PSSWSITE,10)),"^",10)="N" Q
    87         .I $G(WARNS) S:$L(WARNS)>11 RXERR=16,PSXRXERR=PSXRXERR_"^"_RXERR
    88         I SIG="" S RXERR=6,PSXRXERR=PSXRXERR_"^"_RXERR
    89         I PSTAT="" S RXERR=7,PSXRXERR=PSXRXERR_"^"_RXERR
    90         I FDATE'?7N S RXERR=8,PSXRXERR=PSXRXERR_"^"_RXERR
    91         I '$$MAILOK(RXN) D
    92         . S COM="Removed from CMOP Suspense - Mail Status Change" D NOW^%DTC S DTTM=% K % D ACTLOG^PSXRPPL
    93         . D DELETE^PSXRPPL S PSXOK=1
    94         . ;MVP OIFO BAY PINES;ELR;PSX*2*5 DELETE MM MSG FOR DO NOT MAIL
    95         . ;S RXERR=15,PSXRXERR=PSXRXERR_"^"_RXERR ;mail message to users
    96         I $D(^TMP($J,"PSXBAI",DFN)),'$G(^TMP($J,"PSXBAI",DFN)) D
    97         . S PSXOK=8
    98         . D CHKACT(PSXPTR)
    99         . I '$G(PSXFIRST) K PSXRXERR Q
    100         . S COM="Bad Address Indicator or Foreign Address. Not removed from CMOP Suspense" D NOW^%DTC S DTTM=% K % D ACTLOG^PSXRPPL
    101         . S RXERR=20,PSXRXERR=PSXRXERR_"^"_RXERR ;mail message to users
    102 PSOMSG  I +PSOMSG=0 S RXERR=18,PSXRXERR=PSXRXERR_"^"_RXERR ; from PSSLOCK
    103         I $P($G(PSXRXERR),"^",3)'="" S PSXOK=8 D ER7^PSXERR
    104 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)
    105         Q
    106         ;
    107 TSTSIG  ; include testing for BAD characters in SIG
    108         I $P(^PSRX(RXN,"SIG"),"^",2)'>0 S SIG=$P(^PSRX(RXN,"SIG"),"^") D TSTCHAR
    109         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=""
    110         Q
    111 TSTCHAR ; test each character of SIG for certain characters
    112         N I,C
    113         I '$D(^TMP($J,"PSXCHAR")) D
    114         . F I=0:1:31 S ^TMP($J,"PSXCHAR",I)=""
    115         . F I=92,94,124,127 S ^TMP($J,"PSXCHAR",I)=""
    116         F I=1:1:$L(SIG) S C=$A($E(SIG,I)) I $D(^TMP($J,"PSXCHAR",C)) S SIG="" Q
    117         Q
    118 MAILOK(TRX)     ; return 1 if patient still in mail status & ok to CMOP
    119         N PSOMDT,PSOMC,DFN
    120         S DFN=$P(^PSRX(TRX,0),"^",2),PSOMDT=$P($G(^PS(55,DFN,0)),"^",5),PSOMC=$P($G(^PS(55,DFN,0)),"^",3)
    121         I (PSOMC>1&(PSOMDT>DT))!(PSOMC>1&(PSOMDT<1)) Q 0
    122         Q 1
    123 ADDROK(TRX)     ; return 1 if not foreign and not bad address indicator
    124         N DFN,PSOFORGN
    125         S DFN=$P($G(^PSRX(TRX,0)),"^",2) I DFN="" Q:0
    126         ;BHW;PSX*2*64;Changed Quit below from Q:+(^TMP... to Q +(^TMP...
    127         I $D(^TMP($J,"PSXBAI",DFN)) Q +(^TMP($J,"PSXBAI",DFN))
    128         D ADD^VADPT
    129         S PSOFORGN=$P($G(VAPA(25)),"^",2) I PSOFORGN'="",PSOFORGN'["UNITED STATES" S PSOFORGN=1
    130         I PSOFORGN S ^TMP($J,"PSXBAI",DFN)=0 Q 0
    131         I $T(CHKRX^PSOBAI)']"" S ^TMP($J,"PSXBAI",DFN)=1 Q 1
    132         N PSORX,PSOBADR
    133         S PSORX=TRX
    134         S PSOBADR=$$CHKRX^PSOBAI(PSORX)
    135         I '$P(PSOBADR,"^") S ^TMP($J,"PSXBAI",DFN)=1 Q 1
    136         I $P(PSOBADR,"^",2)=1 S ^TMP($J,"PSXBAI",DFN)=1 Q 1
    137         S ^TMP($J,"PSXBAI",DFN)=0
    138         Q 0
    139         ;
    140 CHKACT(RXN)     ; SEE IF FILL IS ALREADY ON ACTIVITY LOG FOR FOREIGN OR BAD ADDRESS
    141         N JJ,RFCNT,XX,COM
    142         S PSXFIRST=1
    143         S COM="Bad Address Indicator or Foreign Address."
    144         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)
    145         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
    146         Q
     1PSXMISC1 ;BIR/WPB,BAB-Transmission Data Validation ;MAR 1,2002@13:13:34
     2 ;;2.0;CMOP;**3,18,23,28,30,42,41,52,54,58**;11 Apr 97;Build 2
     3 ;Reference to ^PSDRUG(  supported by DBIA #1983
     4 ;Reference to ^PS(52.5, supported by DBIA #1978
     5 ;Reference to ^PSRX(    supported by DBIA #1977
     6 ;Reference to ^PS(55,   supported by DBIA #2228
     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
     10CHKDATA ;checks the data elements in PSRX before putting the rx in 550.2
     11 Q:'$D(^PS(52.5,REC,0))
     12 K DRUGCHK,PSXRXERR,PSXDGST,WARNS
     13 S (RXN,PSXPTR)=$P($G(^PS(52.5,REC,0)),"^",1) I PSXPTR="" S PSXOK=8 Q
     14 D PSOL^PSSLOCK(RXN) S PSOMSG=+PSOMSG ; sets PSOMSG
     15 I ($P(^PS(52.5,REC,0),U,3)'=XDFN)!($P(^PSRX(PSXPTR,0),U,2)'=XDFN) S PSXOK=8 Q
     16 I '$D(^PSRX(PSXPTR,0)) S PSXOK=8 Q
     17 S RXNUM=$P($G(^PSRX(PSXPTR,0)),"^",6),RXEX=$P($G(^PSRX(PSXPTR,0)),"^",1)
     18 I $G(^PSDRUG(RXNUM,"ND"))'="" D
     19 .S PTRA=$P($G(^PSDRUG(RXNUM,"ND")),U,1),PTRB=$P($G(^PSDRUG(RXNUM,"ND")),U,3)
     20 .I $G(PTRA)'="" S ZX=$$PROD2^PSNAPIS(PTRA,PTRB),DRUGCHK=$P($G(ZX),"^",3)
     21 S:$G(DRUGCHK)'="" PSXDGST=$P(ZX,"^",2)_"^"_$P(ZX,"^")
     22 I '$D(DRUGCHK) S DRUGCHK=0
     23 S:'$D(^PSDRUG("AQ",RXNUM)) PSXOK=1
     24 S:$G(DRUGCHK)'=1 PSXOK=1
     25 I $P(^PSDRUG(RXNUM,2),"^",3)'["O" S PSXOK=1,PSXCK=RXNUM D UNMARK^PSXUTL
     26 S:$P($G(^PSRX(PSXPTR,"STA")),U,1)'=5 PSXOK=5
     27 ;gets the fill number by ordering thru the refill node for the last
     28 ;refill number
     29 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
     30 ;I $G(PSXFLAG)=2 S PSXOK=0 Q
     31 S RXF=FILNUM
     32 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
     33 S:((PSXOK=0)&(FILNUM>0)&($P($G(^PSRX(PSXPTR,1,FILNUM,0)),"^",2)'="M")) PSXOK=3
     34 S:((PSXOK=0)&(FILNUM'>0)&($P($G(^PSRX(PSXPTR,0)),"^",11)'="M")) PSXOK=3
     35 I $G(^PS(52.5,REC,"P"))="1" S PSXOK=4
     36 S PSXDIV=$S(FILNUM=0:$P($G(^PSRX(PSXPTR,2)),U,9),FILNUM>0:$P($G(^PSRX(PSXPTR,1,FILNUM,0)),"^",9),1:"")
     37 ;If trans div does not match Rx div eliminate
     38 I PSXDIV'=PSOSITE S PSXOK=7 Q
     39 ; Changes for Controlled subs
     40 N PSXCSC,PSXCSD S PSXCSRX=""
     41 S PSXCSC=$P($G(^PSDRUG(RXNUM,0)),"^",3)
     42 ;Can't trans DEA schedule 1 or 2
     43 I $G(PSXCSC)[1!$G(PSXCSC)[2 S PSXOK=10 Q
     44 ;If CS must be DEA 3-5 to qualify
     45 F PSXCSD=3:1:5 I PSXCSC[PSXCSD S PSXCSRX=1
     46 ;If not CS drug and CS trans eliminate
     47 I ($G(PSXCSRX)<1)&($G(PSXCS)=1) S PSXOK=9 Q
     48 ;If CS drug and not CS trans eliminate
     49 I ($G(PSXCSRX)=1)&($G(PSXCS)<1) S PSXOK=9 Q
     50 ; Checks for do not mail and expiration date thereof
     51 ; moved to under NOGO
     52 ;
     53 G:PSXOK'=0 STOP
     54NOGO ;any rx that does not pass the following checks will not be transmitted
     55 ;and an error message will be generated and sent to the user who
     56 ;initiated the transmission.  All that pass the checks will be sent.
     57 S RXERR=0,PSXRXERR=RXEX_"^"_RXF
     58 I RXEX[" " S RXERR=13,PSXRXERR=PSXRXERR_"^"_RXERR
     59 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
     60NG1 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
     61 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
     62 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
     63 S DRUG=$P($G(^PSRX(RXN,0)),U,6),PSTAT=$P($G(^(0)),U,3),FDATE=$P($G(^PSRX(RXN,2)),U,2)
     64 D TSTSIG
     65 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
     66 D DEM^VADPT
     67 I VADM(1)["MERGING" S RXERR=17,PSXRXERR=PSXRXERR_"^"_RXERR
     68 ;MVP OIFO BAY PINES;ELR;PSX*2*52  CHANGED RXERR FROM 10 TO 19. ADDED NEW ERROR IN PSXERR
     69 I $G(VA("PID"))["000-00" S RXERR=19,PSXRXERR=PSXRXERR_"^"_RXERR ; SSN ["000-00" indicates test patient
     70 S (CNTR,XC,DUPFLG)=0,DUPRX="" F  S XC=$O(^PSRX("B",RXEX,XC)) Q:XC'>0  S CNTR=CNTR+1,DUPRX=DUPRX_"^"_XC
     71 I CNTR>1 D
     72 .Q:$P(DUPRX,"^",3)=""
     73 .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
     74 S:$G(DUPFLG)>0 PSXRXERR=PSXRXERR_"^"_"14"
     75 K CNTR,XC,DUPRX,I2,I1,PSREC,DUPFLG
     76 I $D(^PSRX(PSXPTR,4,0)) D
     77 .S RXERR=""
     78 .S ZX=0 F  S ZX=$O(^PSRX(PSXPTR,4,ZX)) Q:ZX'>0  D
     79 ..I $P(^PSRX(PSXPTR,4,ZX,0),"^",3)=RXF&($P(^PSRX(PSXPTR,4,ZX,0),"^",4)'=3) S RXERR=12
     80 ..I $P(^PSRX(PSXPTR,4,ZX,0),"^",3)=RXF&($P(^PSRX(PSXPTR,4,ZX,0),"^",4)=3) S RXERR=""
     81 .I RXERR'="" S PSXRXERR=PSXRXERR_"^"_RXERR
     82 I DRUG="" S RXERR=5,PSXRXERR=PSXRXERR_"^"_RXERR
     83 I DRUG S WARNS=$P(^PSDRUG(DRUG,0),"^",8) D
     84 .;IF USING NEW WARNING SOURCE, LENGTH OF OLD WARNINGS DOESN'T MATTER
     85 .I '$D(PSSWSITE) S PSSWSITE=+$O(^PS(59.7,0))
     86 .I $P($G(^PS(59.7,PSSWSITE,10)),"^",10)="N" Q
     87 .I $G(WARNS) S:$L(WARNS)>11 RXERR=16,PSXRXERR=PSXRXERR_"^"_RXERR
     88 I SIG="" S RXERR=6,PSXRXERR=PSXRXERR_"^"_RXERR
     89 I PSTAT="" S RXERR=7,PSXRXERR=PSXRXERR_"^"_RXERR
     90 I FDATE'?7N S RXERR=8,PSXRXERR=PSXRXERR_"^"_RXERR
     91 I '$$MAILOK(RXN) D
     92 . S COM="Removed from CMOP Suspense - Mail Status Change" D NOW^%DTC S DTTM=% K % D ACTLOG^PSXRPPL
     93 . D DELETE^PSXRPPL S PSXOK=1
     94 . ;MVP OIFO BAY PINES;ELR;PSX*2*5 DELETE MM MSG FOR DO NOT MAIL
     95 . ;S RXERR=15,PSXRXERR=PSXRXERR_"^"_RXERR ;mail message to users
     96 I $D(^TMP($J,"PSXBAI",DFN)),'$G(^TMP($J,"PSXBAI",DFN)) D
     97 . S PSXOK=8
     98 . D CHKACT(PSXPTR)
     99 . I '$G(PSXFIRST) K PSXRXERR Q
     100 . S COM="Bad Address Indicator or Foreign Address. Not removed from CMOP Suspense" D NOW^%DTC S DTTM=% K % D ACTLOG^PSXRPPL
     101 . S RXERR=20,PSXRXERR=PSXRXERR_"^"_RXERR ;mail message to users
     102PSOMSG I +PSOMSG=0 S RXERR=18,PSXRXERR=PSXRXERR_"^"_RXERR ; from PSSLOCK
     103 I $P($G(PSXRXERR),"^",3)'="" S PSXOK=8 D ER7^PSXERR
     104STOP 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)
     105 Q
     106 ;
     107TSTSIG ; include testing for BAD characters in SIG
     108 I $P(^PSRX(RXN,"SIG"),"^",2)'>0 S SIG=$P(^PSRX(RXN,"SIG"),"^") D TSTCHAR
     109 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=""
     110 Q
     111TSTCHAR ; test each character of SIG for certain characters
     112 N I,C
     113 I '$D(^TMP($J,"PSXCHAR")) D
     114 . F I=0:1:31 S ^TMP($J,"PSXCHAR",I)=""
     115 . F I=92,94,124,127 S ^TMP($J,"PSXCHAR",I)=""
     116 F I=1:1:$L(SIG) S C=$A($E(SIG,I)) I $D(^TMP($J,"PSXCHAR",C)) S SIG="" Q
     117 Q
     118MAILOK(TRX) ; return 1 if patient still in mail status & ok to CMOP
     119 N PSOMDT,PSOMC,DFN
     120 S DFN=$P(^PSRX(TRX,0),"^",2),PSOMDT=$P($G(^PS(55,DFN,0)),"^",5),PSOMC=$P($G(^PS(55,DFN,0)),"^",3)
     121 I (PSOMC>1&(PSOMDT>DT))!(PSOMC>1&(PSOMDT<1)) Q 0
     122 Q 1
     123ADDROK(TRX) ; return 1 if not foreign and not bad address indicator
     124 N DFN,PSOFORGN
     125 S DFN=$P($G(^PSRX(TRX,0)),"^",2) I DFN="" Q:0
     126 I $D(^TMP($J,"PSXBAI",DFN)) Q:+(^TMP($J,"PSXBAI",DFN))
     127 D ADD^VADPT
     128 S PSOFORGN=$P($G(VAPA(25)),"^",2) I PSOFORGN'="",PSOFORGN'["UNITED STATES" S PSOFORGN=1
     129 I PSOFORGN S ^TMP($J,"PSXBAI",DFN)=0 Q 0
     130 I $T(CHKRX^PSOBAI)']"" S ^TMP($J,"PSXBAI",DFN)=1 Q 1
     131 N PSORX,PSOBADR
     132 S PSORX=TRX
     133 S PSOBADR=$$CHKRX^PSOBAI(PSORX)
     134 I '$P(PSOBADR,"^") S ^TMP($J,"PSXBAI",DFN)=1 Q 1
     135 I $P(PSOBADR,"^",2)=1 S ^TMP($J,"PSXBAI",DFN)=1 Q 1
     136 S ^TMP($J,"PSXBAI",DFN)=0
     137 Q 0
     138 ;
     139CHKACT(RXN) ; SEE IF FILL IS ALREADY ON ACTIVITY LOG FOR FOREIGN OR BAD ADDRESS
     140 N JJ,RFCNT,XX,COM
     141 S PSXFIRST=1
     142 S COM="Bad Address Indicator or Foreign Address."
     143 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)
     144 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
     145 Q
Note: See TracChangeset for help on using the changeset viewer.