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

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMISE.m

    r613 r623  
    1 PXRMISE ; SLC/PKR - Index size estimating routines. ;03/13/2006
    2         ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
    3         ;
    4         ;========================================================
    5 EST     ;Driver for making index counts.
    6         N BLOCKS,FUNCTION,GBL,GLIST,IND,NE,NL,NUMGBL,RTN
    7         N SF,TASKIT,TBLOCKS,XMSUB
    8         D SETDATA(.GBL,.GLIST,.NUMGBL,.RTN,.SF)
    9         I +SF=-1 D ERRORMSG^PXRMISF(SF)  Q
    10         S (NL,TBLOCKS)=0
    11         S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Start time "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
    12         S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=""
    13         S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Size Estimate for ^PXRMINDX"
    14         F IND=1:1:NUMGBL D
    15         . S FUNCTION="S NE=$$"_RTN(GBL(IND))
    16         . X FUNCTION
    17         . S BLOCKS=NE*SF(GBL(IND))
    18         . S BLOCKS=$FN(BLOCKS,"","")+1
    19         . S TBLOCKS=TBLOCKS+BLOCKS
    20         . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=""
    21         . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Estimates for "_GLIST(IND)
    22         . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" Number of entries: "_NE
    23         . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" Number of blocks: "_BLOCKS
    24         S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=""
    25         S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Total estimated blocks: "_TBLOCKS
    26         S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=""
    27         S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="End time "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
    28         S XMSUB="Size estimate for index global"
    29         D SEND^PXRMMSG(XMSUB)
    30         S ZTREQ="@"
    31         Q
    32         ;
    33         ;===============================================================
    34 ESTTASK ;Task the index size estimation.
    35         N DIR,DTOUT,DUOUT,MINDT,SDTIME,X,Y
    36         S MINDT=$$NOW^XLFDT
    37         W !,"Queue the Clinical Reminders index size estimation."
    38         S DIR("A",1)="Enter the date and time you want the job to start."
    39         S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
    40         S DIR("A")="Start the task at: "
    41         S DIR(0)="DAU"_U_MINDT_"::RSX"
    42         D ^DIR
    43         I $D(DTOUT)!$D(DUOUT) Q
    44         S SDTIME=Y
    45         K DIR
    46         ;Put the task into the queue.
    47         S ZTRTN="EST^PXRMISE"
    48         S ZTDESC="Clinical Reminders index size estimation"
    49         S ZTDTH=SDTIME
    50         S ZTIO=""
    51         D ^%ZTLOAD
    52         W !,"Task number ",ZTSK," queued."
    53         Q
    54         ;
    55         ;===============================================================
    56 NEOR()  ;Return number of entries in OR.
    57         ;DBIA #4180
    58         Q $P(^OR(100,0),U,4)
    59         ;
    60         ;===============================================================
    61 NEPROB()        ;Return number of entries in PROBLEM LIST.
    62         ;DBIA #3837
    63         Q $P(^AUPNPROB(0),U,4)
    64         ;
    65         ;===============================================================
    66 NEPS()  ;Return number of entries in PS(55).
    67         N ADD,DA,DA1,DFN,DRUG,IND,NE,SDATE,SOL,STARTD,TEMP
    68         ;DBIA #4181
    69         S (DFN,IND,NE)=0
    70         F  S DFN=+$O(^PS(55,DFN)) Q:DFN=0  D
    71         .;Process Unit Dose.
    72         . S DA=0
    73         . F  S DA=+$O(^PS(55,DFN,5,DA)) Q:DA=0  D
    74         .. S TEMP=$G(^PS(55,DFN,5,DA,2))
    75         .. S STARTD=$P(TEMP,U,2)
    76         .. I STARTD="" Q
    77         ..;If the order is purged then SDATE is 1.
    78         .. S SDATE=$P(TEMP,U,4)
    79         .. I SDATE=1 Q
    80         .. S DA1=0
    81         .. F  S DA1=+$O(^PS(55,DFN,5,DA,1,DA1)) Q:DA1=0  D
    82         ... S DRUG=$P(^PS(55,DFN,5,DA,1,DA1,0),U,1)
    83         ... I DRUG="" Q
    84         ... S NE=NE+1
    85         .;Process the IV mutiple.
    86         . S DA=0
    87         . F  S DA=+$O(^PS(55,DFN,"IV",DA)) Q:DA=0  D
    88         .. S TEMP=$G(^PS(55,DFN,"IV",DA,0))
    89         .. S STARTD=$P(TEMP,U,2)
    90         .. I STARTD="" Q
    91         .. S SDATE=$P(TEMP,U,3)
    92         .. I SDATE=1 Q
    93         ..;Process Additives
    94         .. S DA1=0
    95         .. F  S DA1=+$O(^PS(55,DFN,"IV",DA,"AD",DA1)) Q:DA1=0  D
    96         ... S ADD=$P(^PS(55,DFN,"IV",DA,"AD",DA1,0),U,1)
    97         ... I ADD="" Q
    98         ... S DRUG=$P($G(^PS(52.6,ADD,0)),U,2)
    99         ... I DRUG="" Q
    100         ... S NE=NE+1
    101         ..;Process Solutions
    102         .. S DA1=0
    103         .. F  S DA1=+$O(^PS(55,DFN,"IV",DA,"SOL",DA1)) Q:DA1=0  D
    104         ... S SOL=$P(^PS(55,DFN,"IV",DA,"SOL",DA1,0),U,1)
    105         ... I SOL="" Q
    106         ... S DRUG=$P($G(^PS(52.7,SOL,0)),U,2)
    107         ... I DRUG="" Q
    108         ... S NE=NE+1
    109         Q NE
    110         ;
    111         ;===============================================================
    112 NEPSRX()        ;Return number of entries in PSRX
    113         N DA,DA1,DATE,DSUP,DFN,DRUG,NE,RDATE,TEMP
    114         ;DBIA #4182
    115         S (DA,NE)=0
    116         F  S DA=+$O(^PSRX(DA)) Q:DA=0  D
    117         . S TEMP=$G(^PSRX(DA,0))
    118         . S DFN=$P(TEMP,U,2)
    119         . I DFN="" Q
    120         . S DRUG=$P(TEMP,U,6)
    121         . I DRUG="" Q
    122         . S DSUP=$P(TEMP,U,8)
    123         . I DSUP="" Q
    124         . S RDATE=+$P($G(^PSRX(DA,2)),U,13)
    125         . I RDATE>0 S NE=NE+1
    126         .;Process the refill mutiple.
    127         . S DA1=0
    128         . F  S DA1=+$O(^PSRX(DA,1,DA1)) Q:DA1=0  D
    129         .. S TEMP=$G(^PSRX(DA,1,DA1,0))
    130         .. S DSUP=+$P(TEMP,U,10)
    131         .. S RDATE=+$P(TEMP,U,18)
    132         .. I RDATE>0 S NE=NE+1
    133         .;Process the partial fill multiple.
    134         . S DA1=0
    135         . F  S DA1=+$O(^PSRX(DA,"P",DA1)) Q:DA1=0  D
    136         .. S TEMP=$G(^PSRX(DA,"P",DA1,0))
    137         .. S DSUP=+$P(TEMP,U,10)
    138         .. S RDATE=+$P(TEMP,U,19)
    139         .. I RDATE>0 S NE=NE+1
    140         Q NE
    141         ;
    142         ;===============================================================
    143 NEPTF() ;Return number of entries in PTF.
    144         N D1,DA,DATE,DFN,ICD0,ICD9,JND,NE0,NE9,TEMP70,TEMP0,TEMPP,TEMPS
    145         ;DBIA #4177
    146         S (DA,NE0,NE9)=0
    147         F  S DA=+$O(^DGPT(DA)) Q:DA=0  D
    148         . S TEMP0=$G(^DGPT(DA,0))
    149         . S DFN=$P(TEMP0,U,1)
    150         . I DFN="" Q
    151         . S D1=0
    152         . F  S D1=+$O(^DGPT(DA,"S",D1)) Q:D1=0  D
    153         .. S TEMPS=$G(^DGPT(DA,"S",D1,0))
    154         .. S DATE=$P(TEMPS,U,1)
    155         .. I DATE="" Q
    156         .. F JND=8,9,10,11,12 D
    157         ... S ICD0=$P(TEMPS,U,JND)
    158         ... I (ICD0'=""),$D(^ICD0(ICD0)) S NE0=NE0+1
    159         .;
    160         . S D1=0
    161         . F  S D1=+$O(^DGPT(DA,"P",D1)) Q:D1=0  D
    162         .. S TEMPP=$G(^DGPT(DA,"P",D1,0))
    163         .. S DATE=$P(TEMPP,U,1)
    164         .. I DATE="" Q
    165         .. F JND=5,6,7,8,9 D
    166         ... S ICD0=$P(TEMPP,U,JND)
    167         ... I (ICD0'=""),$D(^ICD0(ICD0)) S NE0=NE0+1
    168         .;
    169         .;Discharge ICD9 codes
    170         . I $D(^DGPT(DA,70)) D
    171         .. S TEMP70=$G(^DGPT(DA,70))
    172         .. F JND=10,11,16,17,18,19,20,21,22,23,24 D
    173         ... S ICD9=$P(TEMP70,U,JND)
    174         ... I (ICD9'=""),$D(^ICD9(ICD9)) S NE9=NE9+1
    175         .;
    176         .;Movement ICD9 codes
    177         . I '$D(^DGPT(DA,"M")) Q
    178         . S D1=0
    179         . F  S D1=$O(^DGPT(DA,"M",D1)) Q:+D1=0  D
    180         .. S TEMPS=$G(^DGPT(DA,"M",D1,0))
    181         .. S DATE=$P(TEMPS,U,10)
    182         .. I DATE="" Q
    183         .. F JND=5,6,7,8,9,11,12,13,14,15 D
    184         ... S ICD9=$P(TEMPS,U,JND)
    185         ... I (ICD9'=""),$D(^ICD9(ICD9)) S NE9=NE9+1
    186         Q NE0+NE9
    187         ;
    188         ;===============================================================
    189 NERAD() ;Return number of entries in RAD/NUC MED PATIENT.
    190         N IEN,NE
    191         ;DBIA #4183
    192         S (IEN,NE)=0
    193         F  S IEN=$O(^RADPT(IEN)) Q:+IEN=0  S NE=NE+$P($G(^RADPT(IEN,"DT",0)),U,4)
    194         Q NE
    195         ;
    196         ;===============================================================
    197 NEVCPT()        ;Return number of entries in V CPT.
    198         ;DBIA #4176
    199         Q $P(^AUPNVCPT(0),U,4)
    200         ;
    201         ;===============================================================
    202 NEVHF() ;Return number of entries in V HEALTH FACTORS.
    203         ;DBIA #4176
    204         Q $P(^AUPNVHF(0),U,4)
    205         ;
    206         ;===============================================================
    207 NEVIMM()        ;Return number of entries in V IMMUNIZATION
    208         ;DBIA #4176
    209         Q $P(^AUPNVIMM(0),U,4)
    210         ;
    211         ;===============================================================
    212 NEVIT() ;Return number of entries in GMRV VITAL MEASUREMENT
    213         ;DBIA #4178
    214         Q $P(^GMR(120.5,0),U,4)
    215         ;
    216         ;===============================================================
    217 NEVPED()        ;Return number of entries in V PATIENT ED.
    218         ;DBIA #4176
    219         Q $P(^AUPNVPED(0),U,4)
    220         ;
    221         ;===============================================================
    222 NEVPOV()        ;Return number of entries in V POV.
    223         ;DBIA #4176
    224         Q $P(^AUPNVPOV(0),U,4)
    225         ;
    226         ;===============================================================
    227 NEVSK() ;Return number of entries in V SKIN TEST.
    228         ;DBIA #4176
    229         Q $P(^AUPNVSK(0),U,4)
    230         ;
    231         ;===============================================================
    232 NEVXAM()        ;Return number of entries in V EXAM.
    233         ;DBIA #4176
    234         Q $P(^AUPNVXAM(0),U,4)
    235         ;
    236         ;===============================================================
    237 NEYTD() ;Return number of entries in PSYCH INSTRUMENT PATIENT
    238         N DATE,DFN,NE,TEST
    239         ;DBIA #4184
    240         S (DFN,NE)=0
    241         F  S DFN=$O(^YTD(601.2,DFN)) Q:+DFN=0  D
    242         . S TEST=0
    243         . F  S TEST=$O(^YTD(601.2,DFN,1,TEST)) Q:+TEST=0  D
    244         .. S DATE=0
    245         .. F  S DATE=$O(^YTD(601.2,DFN,1,TEST,1,DATE)) Q:+DATE=0  S NE=NE+1
    246         Q NE
    247         ;
    248         ;===============================================================
    249 SETDATA(GBL,GLIST,NUMGBL,RTN,SF)        ;
    250         S NUMGBL=16
    251         S GLIST(1)="LABORATORY TEST (CH, Anatomic Path, Micro)",GBL(1)=63
    252         S GLIST(2)="MENTAL HEALTH",GBL(2)=601.2
    253         S GLIST(3)="ORDER",GBL(3)=100
    254         S GLIST(4)="PTF",GBL(4)=45
    255         S GLIST(5)="PHARMACY PATIENT",GBL(5)=55
    256         S GLIST(6)="PRESCRIPTION",GBL(6)=52
    257         S GLIST(7)="PROBLEM LIST",GBL(7)=9000011
    258         S GLIST(8)="RADIOLOGY",GBL(8)=70
    259         S GLIST(9)="V CPT",GBL(9)=9000010.18
    260         S GLIST(10)="V EXAM",GBL(10)=9000010.13
    261         S GLIST(11)="V HEALTH FACTORS",GBL(11)=9000010.23
    262         S GLIST(12)="V IMMUNIZATION",GBL(12)=9000010.11
    263         S GLIST(13)="V PATIENT ED",GBL(13)=9000010.16
    264         S GLIST(14)="V POV",GBL(14)=9000010.07
    265         S GLIST(15)="V SKIN TEST",GBL(15)=9000010.12
    266         S GLIST(16)="VITAL MEASUREMENT",GBL(16)=120.5
    267         S RTN(45)="NEPTF^PXRMISE"
    268         S RTN(52)="NEPSRX^PXRMISE"
    269         S RTN(55)="NEPS^PXRMISE"
    270         S RTN(63)="NELR^PXRMLABS"
    271         S RTN(70)="NERAD^PXRMISE"
    272         S RTN(100)="NEOR^PXRMISE"
    273         S RTN(120.5)="NEVIT^PXRMISE"
    274         S RTN(601.2)="NEYTD^PXRMISE"
    275         S RTN(9000011)="NEPROB^PXRMISE"
    276         S RTN(9000010.07)="NEVPOV^PXRMISE"
    277         S RTN(9000010.11)="NEVIMM^PXRMISE"
    278         S RTN(9000010.12)="NEVSK^PXRMISE"
    279         S RTN(9000010.13)="NEVXAM^PXRMISE"
    280         S RTN(9000010.16)="NEVPED^PXRMISE"
    281         S RTN(9000010.18)="NEVCPT^PXRMISE"
    282         S RTN(9000010.23)="NEVHF^PXRMISE"
    283         D LSF^PXRMISF(.SF)
    284         Q
    285         ;
     1PXRMISE ; SLC/PKR - Index size estimating routines. ;01/12/2005
     2 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
     3 ;
     4 ;========================================================
     5EST ;Driver for making index counts.
     6 N BLOCKS,FUNCTION,GBL,GLIST,IND,NE,NL,NUMGBL,RTN
     7 N SF,TASKIT,TBLOCKS,XMSUB
     8 D SETDATA(.GBL,.GLIST,.NUMGBL,.RTN,.SF)
     9 I +SF=-1 D ERRORMSG^PXRMISF(SF)  Q
     10 S (NL,TBLOCKS)=0
     11 S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Start time "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
     12 S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=""
     13 S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Size Estimate for ^PXRMINDX"
     14 F IND=1:1:NUMGBL D
     15 . S FUNCTION="S NE=$$"_RTN(GBL(IND))
     16 . X FUNCTION
     17 . S BLOCKS=NE*SF(GBL(IND))
     18 . S BLOCKS=$FN(BLOCKS,"","")+1
     19 . S TBLOCKS=TBLOCKS+BLOCKS
     20 . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=""
     21 . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Estimates for "_GLIST(IND)
     22 . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" Number of entries: "_NE
     23 . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" Number of blocks: "_BLOCKS
     24 S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=""
     25 S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Total estimated blocks: "_TBLOCKS
     26 S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=""
     27 S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="End time "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
     28 S XMSUB="Size estimate for index global"
     29 D SEND^PXRMMSG(XMSUB)
     30 S ZTREQ="@"
     31 Q
     32 ;
     33 ;===============================================================
     34ESTTASK ;Task the index size estimation.
     35 N DIR,DTOUT,DUOUT,MINDT,SDTIME,X,Y
     36 S MINDT=$$NOW^XLFDT
     37 W !,"Queue the Clinical Reminders index size estimation."
     38 S DIR("A",1)="Enter the date and time you want the job to start."
     39 S DIR("A")="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")_" "
     40 S DIR(0)="DAU"_U_MINDT_"::RSX"
     41 D ^DIR
     42 I $D(DTOUT)!$D(DUOUT) Q
     43 S SDTIME=Y
     44 K DIR
     45 ;Put the task into the queue.
     46 S ZTRTN="EST^PXRMISE"
     47 S ZTDESC="Clinical Reminders index size estimation"
     48 S ZTDTH=SDTIME
     49 S ZTIO=""
     50 D ^%ZTLOAD
     51 W !,"Task number ",ZTSK," queued."
     52 Q
     53 ;
     54 ;===============================================================
     55NEOR() ;Return number of entries in OR.
     56 ;DBIA #4180
     57 Q $P(^OR(100,0),U,4)
     58 ;
     59 ;===============================================================
     60NEPROB() ;Return number of entries in PROBLEM LIST.
     61 ;DBIA #3837
     62 Q $P(^AUPNPROB(0),U,4)
     63 ;
     64 ;===============================================================
     65NEPS() ;Return number of entries in PS(55).
     66 N ADD,DA,DA1,DFN,DRUG,IND,NE,SDATE,SOL,STARTD,TEMP
     67 ;DBIA #4181
     68 S (DFN,IND,NE)=0
     69 F  S DFN=+$O(^PS(55,DFN)) Q:DFN=0  D
     70 .;Process Unit Dose.
     71 . S DA=0
     72 . F  S DA=+$O(^PS(55,DFN,5,DA)) Q:DA=0  D
     73 .. S TEMP=$G(^PS(55,DFN,5,DA,2))
     74 .. S STARTD=$P(TEMP,U,2)
     75 .. I STARTD="" Q
     76 ..;If the order is purged then SDATE is 1.
     77 .. S SDATE=$P(TEMP,U,4)
     78 .. I SDATE=1 Q
     79 .. S DA1=0
     80 .. F  S DA1=+$O(^PS(55,DFN,5,DA,1,DA1)) Q:DA1=0  D
     81 ... S DRUG=$P(^PS(55,DFN,5,DA,1,DA1,0),U,1)
     82 ... I DRUG="" Q
     83 ... S NE=NE+1
     84 .;Process the IV mutiple.
     85 . S DA=0
     86 . F  S DA=+$O(^PS(55,DFN,"IV",DA)) Q:DA=0  D
     87 .. S TEMP=$G(^PS(55,DFN,"IV",DA,0))
     88 .. S STARTD=$P(TEMP,U,2)
     89 .. I STARTD="" Q
     90 .. S SDATE=$P(TEMP,U,3)
     91 .. I SDATE=1 Q
     92 ..;Process Additives
     93 .. S DA1=0
     94 .. F  S DA1=+$O(^PS(55,DFN,"IV",DA,"AD",DA1)) Q:DA1=0  D
     95 ... S ADD=$P(^PS(55,DFN,"IV",DA,"AD",DA1,0),U,1)
     96 ... I ADD="" Q
     97 ... S DRUG=$P($G(^PS(52.6,ADD,0)),U,2)
     98 ... I DRUG="" Q
     99 ... S NE=NE+1
     100 ..;Process Solutions
     101 .. S DA1=0
     102 .. F  S DA1=+$O(^PS(55,DFN,"IV",DA,"SOL",DA1)) Q:DA1=0  D
     103 ... S SOL=$P(^PS(55,DFN,"IV",DA,"SOL",DA1,0),U,1)
     104 ... I SOL="" Q
     105 ... S DRUG=$P($G(^PS(52.7,SOL,0)),U,2)
     106 ... I DRUG="" Q
     107 ... S NE=NE+1
     108 Q NE
     109 ;
     110 ;===============================================================
     111NEPSRX() ;Return number of entries in PSRX
     112 N DA,DA1,DATE,DSUP,DFN,DRUG,NE,RDATE,TEMP
     113 ;DBIA #4182
     114 S (DA,NE)=0
     115 F  S DA=+$O(^PSRX(DA)) Q:DA=0  D
     116 . S TEMP=$G(^PSRX(DA,0))
     117 . S DFN=$P(TEMP,U,2)
     118 . I DFN="" Q
     119 . S DRUG=$P(TEMP,U,6)
     120 . I DRUG="" Q
     121 . S DSUP=$P(TEMP,U,8)
     122 . I DSUP="" Q
     123 . S RDATE=+$P($G(^PSRX(DA,2)),U,13)
     124 . I RDATE>0 S NE=NE+1
     125 .;Process the refill mutiple.
     126 . S DA1=0
     127 . F  S DA1=+$O(^PSRX(DA,1,DA1)) Q:DA1=0  D
     128 .. S TEMP=$G(^PSRX(DA,1,DA1,0))
     129 .. S DSUP=+$P(TEMP,U,10)
     130 .. S RDATE=+$P(TEMP,U,18)
     131 .. I RDATE>0 S NE=NE+1
     132 .;Process the partial fill multiple.
     133 . S DA1=0
     134 . F  S DA1=+$O(^PSRX(DA,"P",DA1)) Q:DA1=0  D
     135 .. S TEMP=$G(^PSRX(DA,"P",DA1,0))
     136 .. S DSUP=+$P(TEMP,U,10)
     137 .. S RDATE=+$P(TEMP,U,19)
     138 .. I RDATE>0 S NE=NE+1
     139 Q NE
     140 ;
     141 ;===============================================================
     142NEPTF() ;Return number of entries in PTF.
     143 N D1,DA,DATE,DFN,ICD0,ICD9,JND,NE0,NE9,TEMP70,TEMP0,TEMPP,TEMPS
     144 ;DBIA #4177
     145 S (DA,NE0,NE9)=0
     146 F  S DA=+$O(^DGPT(DA)) Q:DA=0  D
     147 . S TEMP0=$G(^DGPT(DA,0))
     148 . S DFN=$P(TEMP0,U,1)
     149 . I DFN="" Q
     150 . S D1=0
     151 . F  S D1=+$O(^DGPT(DA,"S",D1)) Q:D1=0  D
     152 .. S TEMPS=$G(^DGPT(DA,"S",D1,0))
     153 .. S DATE=$P(TEMPS,U,1)
     154 .. I DATE="" Q
     155 .. F JND=8,9,10,11,12 D
     156 ... S ICD0=$P(TEMPS,U,JND)
     157 ... I (ICD0'=""),$D(^ICD0(ICD0)) S NE0=NE0+1
     158 .;
     159 . S D1=0
     160 . F  S D1=+$O(^DGPT(DA,"P",D1)) Q:D1=0  D
     161 .. S TEMPP=$G(^DGPT(DA,"P",D1,0))
     162 .. S DATE=$P(TEMPP,U,1)
     163 .. I DATE="" Q
     164 .. F JND=5,6,7,8,9 D
     165 ... S ICD0=$P(TEMPP,U,JND)
     166 ... I (ICD0'=""),$D(^ICD0(ICD0)) S NE0=NE0+1
     167 .;
     168 .;Discharge ICD9 codes
     169 . I $D(^DGPT(DA,70)) D
     170 .. S TEMP70=$G(^DGPT(DA,70))
     171 .. F JND=10,11,16,17,18,19,20,21,22,23,24 D
     172 ... S ICD9=$P(TEMP70,U,JND)
     173 ... I (ICD9'=""),$D(^ICD9(ICD9)) S NE9=NE9+1
     174 .;
     175 .;Movement ICD9 codes
     176 . I '$D(^DGPT(DA,"M")) Q
     177 . S D1=0
     178 . F  S D1=$O(^DGPT(DA,"M",D1)) Q:+D1=0  D
     179 .. S TEMPS=$G(^DGPT(DA,"M",D1,0))
     180 .. S DATE=$P(TEMPS,U,10)
     181 .. I DATE="" Q
     182 .. F JND=5,6,7,8,9,11,12,13,14,15 D
     183 ... S ICD9=$P(TEMPS,U,JND)
     184 ... I (ICD9'=""),$D(^ICD9(ICD9)) S NE9=NE9+1
     185 Q NE0+NE9
     186 ;
     187 ;===============================================================
     188NERAD() ;Return number of entries in RAD/NUC MED PATIENT.
     189 N IEN,NE
     190 ;DBIA #4183
     191 S (IEN,NE)=0
     192 F  S IEN=$O(^RADPT(IEN)) Q:+IEN=0  S NE=NE+$P($G(^RADPT(IEN,"DT",0)),U,4)
     193 Q NE
     194 ;
     195 ;===============================================================
     196NEVCPT() ;Return number of entries in V CPT.
     197 ;DBIA #4176
     198 Q $P(^AUPNVCPT(0),U,4)
     199 ;
     200 ;===============================================================
     201NEVHF() ;Return number of entries in V HEALTH FACTORS.
     202 ;DBIA #4176
     203 Q $P(^AUPNVHF(0),U,4)
     204 ;
     205 ;===============================================================
     206NEVIMM() ;Return number of entries in V IMMUNIZATION
     207 ;DBIA #4176
     208 Q $P(^AUPNVIMM(0),U,4)
     209 ;
     210 ;===============================================================
     211NEVIT() ;Return number of entries in GMRV VITAL MEASUREMENT
     212 ;DBIA #4178
     213 Q $P(^GMR(120.5,0),U,4)
     214 ;
     215 ;===============================================================
     216NEVPED() ;Return number of entries in V PATIENT ED.
     217 ;DBIA #4176
     218 Q $P(^AUPNVPED(0),U,4)
     219 ;
     220 ;===============================================================
     221NEVPOV() ;Return number of entries in V POV.
     222 ;DBIA #4176
     223 Q $P(^AUPNVPOV(0),U,4)
     224 ;
     225 ;===============================================================
     226NEVSK() ;Return number of entries in V SKIN TEST.
     227 ;DBIA #4176
     228 Q $P(^AUPNVSK(0),U,4)
     229 ;
     230 ;===============================================================
     231NEVXAM() ;Return number of entries in V EXAM.
     232 ;DBIA #4176
     233 Q $P(^AUPNVXAM(0),U,4)
     234 ;
     235 ;===============================================================
     236NEYTD() ;Return number of entries in PSYCH INSTRUMENT PATIENT
     237 N DATE,DFN,NE,TEST
     238 ;DBIA #4184
     239 S (DFN,NE)=0
     240 F  S DFN=$O(^YTD(601.2,DFN)) Q:+DFN=0  D
     241 . S TEST=0
     242 . F  S TEST=$O(^YTD(601.2,DFN,1,TEST)) Q:+TEST=0  D
     243 .. S DATE=0
     244 .. F  S DATE=$O(^YTD(601.2,DFN,1,TEST,1,DATE)) Q:+DATE=0  S NE=NE+1
     245 Q NE
     246 ;
     247 ;===============================================================
     248SETDATA(GBL,GLIST,NUMGBL,RTN,SF) ;
     249 S NUMGBL=16
     250 S GLIST(1)="LABORATORY TEST (CH, Anatomic Path, Micro)",GBL(1)=63
     251 S GLIST(2)="MENTAL HEALTH",GBL(2)=601.2
     252 S GLIST(3)="ORDER",GBL(3)=100
     253 S GLIST(4)="PTF",GBL(4)=45
     254 S GLIST(5)="PHARMACY PATIENT",GBL(5)=55
     255 S GLIST(6)="PRESCRIPTION",GBL(6)=52
     256 S GLIST(7)="PROBLEM LIST",GBL(7)=9000011
     257 S GLIST(8)="RADIOLOGY",GBL(8)=70
     258 S GLIST(9)="V CPT",GBL(9)=9000010.18
     259 S GLIST(10)="V EXAM",GBL(10)=9000010.13
     260 S GLIST(11)="V HEALTH FACTORS",GBL(11)=9000010.23
     261 S GLIST(12)="V IMMUNIZATION",GBL(12)=9000010.11
     262 S GLIST(13)="V PATIENT ED",GBL(13)=9000010.16
     263 S GLIST(14)="V POV",GBL(14)=9000010.07
     264 S GLIST(15)="V SKIN TEST",GBL(15)=9000010.12
     265 S GLIST(16)="VITAL MEASUREMENT",GBL(16)=120.5
     266 S RTN(45)="NEPTF^PXRMISE"
     267 S RTN(52)="NEPSRX^PXRMISE"
     268 S RTN(55)="NEPS^PXRMISE"
     269 S RTN(63)="NELR^PXRMLABS"
     270 S RTN(70)="NERAD^PXRMISE"
     271 S RTN(100)="NEOR^PXRMISE"
     272 S RTN(120.5)="NEVIT^PXRMISE"
     273 S RTN(601.2)="NEYTD^PXRMISE"
     274 S RTN(9000011)="NEPROB^PXRMISE"
     275 S RTN(9000010.07)="NEVPOV^PXRMISE"
     276 S RTN(9000010.11)="NEVIMM^PXRMISE"
     277 S RTN(9000010.12)="NEVSK^PXRMISE"
     278 S RTN(9000010.13)="NEVXAM^PXRMISE"
     279 S RTN(9000010.16)="NEVPED^PXRMISE"
     280 S RTN(9000010.18)="NEVCPT^PXRMISE"
     281 S RTN(9000010.23)="NEVHF^PXRMISE"
     282 D LSF^PXRMISF(.SF)
     283 Q
     284 ;
Note: See TracChangeset for help on using the changeset viewer.