PXRMISE ; SLC/PKR - Index size estimating routines. ;11/02/2009
;;2.0;CLINICAL REMINDERS;**6,12,17**;Feb 04, 2005;Build 102
;
;========================================================
EST ;Driver for making index counts.
N BLOCKS,FROM,FUNCTION,GBL,GLIST,IND,NE,NL,NUMGBL,RTN
N SF,TASKIT,TBLOCKS,TO,XMSUB
D SETDATA(.GBL,.GLIST,.NUMGBL,.RTN,.SF)
I +SF=-1 D ERRORMSG^PXRMISF(SF) Q
S (NL,TBLOCKS)=0
S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Start time "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=""
S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Size Estimate for ^PXRMINDX"
F IND=1:1:NUMGBL D
. S FUNCTION="S NE=$$"_RTN(GBL(IND))
. X FUNCTION
. S BLOCKS=NE*SF(GBL(IND))
. S BLOCKS=$FN(BLOCKS,"","")+1
. S TBLOCKS=TBLOCKS+BLOCKS
. S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=""
. S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Estimates for "_GLIST(IND)
. S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" Number of entries: "_NE
. S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" Number of blocks: "_BLOCKS
S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=""
S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Total estimated blocks: "_TBLOCKS
S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=""
S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="End time "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
S XMSUB="Size estimate for index global"
S FROM=$$GET1^DIQ(200,DUZ,.01)
S TO(DUZ)=""
D SEND^PXRMMSG("PXRMXMZ",XMSUB,.TO,FROM)
S ZTREQ="@"
Q
;
;===============================================================
ESTTASK ;Task the index size estimation.
N DIR,DTOUT,DUOUT,MINDT,SDTIME,X,Y
S MINDT=$$NOW^XLFDT
W !,"Queue the Clinical Reminders index size estimation."
S DIR("A",1)="Enter the date and time you want the job to start."
S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
S DIR("A")="Start the task at: "
S DIR(0)="DAU"_U_MINDT_"::RSX"
D ^DIR
I $D(DTOUT)!$D(DUOUT) Q
S SDTIME=Y
K DIR
;Put the task into the queue.
S ZTRTN="EST^PXRMISE"
S ZTDESC="Clinical Reminders index size estimation"
S ZTDTH=SDTIME
S ZTIO=""
D ^%ZTLOAD
W !,"Task number ",ZTSK," queued."
Q
;
;===============================================================
NEOR() ;Return number of entries in OR.
;DBIA #4180
Q $P(^OR(100,0),U,4)
;
;===============================================================
NEPROB() ;Return number of entries in PROBLEM LIST.
;DBIA #3837
Q $P(^AUPNPROB(0),U,4)
;
;===============================================================
NEPS() ;Return number of entries in PS(55).
N ADD,DA,DA1,DFN,DRUG,IND,NE,SDATE,SOL,STARTD,TEMP
;DBIA #4181
S (DFN,IND,NE)=0
F S DFN=+$O(^PS(55,DFN)) Q:DFN=0 D
.;Process Unit Dose.
. S DA=0
. F S DA=+$O(^PS(55,DFN,5,DA)) Q:DA=0 D
.. S TEMP=$G(^PS(55,DFN,5,DA,2))
.. S STARTD=$P(TEMP,U,2)
.. I STARTD="" Q
..;If the order is purged then SDATE is 1.
.. S SDATE=$P(TEMP,U,4)
.. I SDATE=1 Q
.. S DA1=0
.. F S DA1=+$O(^PS(55,DFN,5,DA,1,DA1)) Q:DA1=0 D
... S DRUG=$P(^PS(55,DFN,5,DA,1,DA1,0),U,1)
... I DRUG="" Q
... S NE=NE+1
.;Process the IV mutiple.
. S DA=0
. F S DA=+$O(^PS(55,DFN,"IV",DA)) Q:DA=0 D
.. S TEMP=$G(^PS(55,DFN,"IV",DA,0))
.. S STARTD=$P(TEMP,U,2)
.. I STARTD="" Q
.. S SDATE=$P(TEMP,U,3)
.. I SDATE=1 Q
..;Process Additives
.. S DA1=0
.. F S DA1=+$O(^PS(55,DFN,"IV",DA,"AD",DA1)) Q:DA1=0 D
... S ADD=$P(^PS(55,DFN,"IV",DA,"AD",DA1,0),U,1)
... I ADD="" Q
... S DRUG=$P($G(^PS(52.6,ADD,0)),U,2)
... I DRUG="" Q
... S NE=NE+1
..;Process Solutions
.. S DA1=0
.. F S DA1=+$O(^PS(55,DFN,"IV",DA,"SOL",DA1)) Q:DA1=0 D
... S SOL=$P(^PS(55,DFN,"IV",DA,"SOL",DA1,0),U,1)
... I SOL="" Q
... S DRUG=$P($G(^PS(52.7,SOL,0)),U,2)
... I DRUG="" Q
... S NE=NE+1
Q NE
;
;===============================================================
NEPSRX() ;Return number of entries in PSRX
N DA,DA1,DATE,DSUP,DFN,DRUG,NE,RDATE,TEMP
;DBIA #4182
S (DA,NE)=0
F S DA=+$O(^PSRX(DA)) Q:DA=0 D
. S TEMP=$G(^PSRX(DA,0))
. S DFN=$P(TEMP,U,2)
. I DFN="" Q
. S DRUG=$P(TEMP,U,6)
. I DRUG="" Q
. S DSUP=$P(TEMP,U,8)
. I DSUP="" Q
. S RDATE=+$P($G(^PSRX(DA,2)),U,13)
. I RDATE>0 S NE=NE+1
.;Process the refill mutiple.
. S DA1=0
. F S DA1=+$O(^PSRX(DA,1,DA1)) Q:DA1=0 D
.. S TEMP=$G(^PSRX(DA,1,DA1,0))
.. S DSUP=+$P(TEMP,U,10)
.. S RDATE=+$P(TEMP,U,18)
.. I RDATE>0 S NE=NE+1
.;Process the partial fill multiple.
. S DA1=0
. F S DA1=+$O(^PSRX(DA,"P",DA1)) Q:DA1=0 D
.. S TEMP=$G(^PSRX(DA,"P",DA1,0))
.. S DSUP=+$P(TEMP,U,10)
.. S RDATE=+$P(TEMP,U,19)
.. I RDATE>0 S NE=NE+1
Q NE
;
;===============================================================
NEPTF() ;Return number of entries in PTF.
N D1,DA,DATE,DFN,ICD0,ICD9,JND,NE0,NE9,TEMP70,TEMP0,TEMPP,TEMPS
;DBIA #4177
S (DA,NE0,NE9)=0
F S DA=+$O(^DGPT(DA)) Q:DA=0 D
. S TEMP0=$G(^DGPT(DA,0))
. S DFN=$P(TEMP0,U,1)
. I DFN="" Q
. S D1=0
. F S D1=+$O(^DGPT(DA,"S",D1)) Q:D1=0 D
.. S TEMPS=$G(^DGPT(DA,"S",D1,0))
.. S DATE=$P(TEMPS,U,1)
.. I DATE="" Q
.. F JND=8,9,10,11,12 D
... S ICD0=$P(TEMPS,U,JND)
... I (ICD0'=""),$D(^ICD0(ICD0)) S NE0=NE0+1
.;
. S D1=0
. F S D1=+$O(^DGPT(DA,"P",D1)) Q:D1=0 D
.. S TEMPP=$G(^DGPT(DA,"P",D1,0))
.. S DATE=$P(TEMPP,U,1)
.. I DATE="" Q
.. F JND=5,6,7,8,9 D
... S ICD0=$P(TEMPP,U,JND)
... I (ICD0'=""),$D(^ICD0(ICD0)) S NE0=NE0+1
.;
.;Discharge ICD9 codes
. I $D(^DGPT(DA,70)) D
.. S TEMP70=$G(^DGPT(DA,70))
.. F JND=10,11,16,17,18,19,20,21,22,23,24 D
... S ICD9=$P(TEMP70,U,JND)
... I (ICD9'=""),$D(^ICD9(ICD9)) S NE9=NE9+1
.;
.;Movement ICD9 codes
. I '$D(^DGPT(DA,"M")) Q
. S D1=0
. F S D1=$O(^DGPT(DA,"M",D1)) Q:+D1=0 D
.. S TEMPS=$G(^DGPT(DA,"M",D1,0))
.. S DATE=$P(TEMPS,U,10)
.. I DATE="" Q
.. F JND=5,6,7,8,9,11,12,13,14,15 D
... S ICD9=$P(TEMPS,U,JND)
... I (ICD9'=""),$D(^ICD9(ICD9)) S NE9=NE9+1
Q NE0+NE9
;
;===============================================================
NERAD() ;Return number of entries in RAD/NUC MED PATIENT.
N IEN,NE
;DBIA #4183
S (IEN,NE)=0
F S IEN=$O(^RADPT(IEN)) Q:+IEN=0 S NE=NE+$P($G(^RADPT(IEN,"DT",0)),U,4)
Q NE
;
;===============================================================
NEVCPT() ;Return number of entries in V CPT.
;DBIA #4176
Q $P(^AUPNVCPT(0),U,4)
;
;===============================================================
NEVHF() ;Return number of entries in V HEALTH FACTORS.
;DBIA #4176
Q $P(^AUPNVHF(0),U,4)
;
;===============================================================
NEVIMM() ;Return number of entries in V IMMUNIZATION
;DBIA #4176
Q $P(^AUPNVIMM(0),U,4)
;
;===============================================================
NEVIT() ;Return number of entries in GMRV VITAL MEASUREMENT
;DBIA #4178
Q $P(^GMR(120.5,0),U,4)
;
;===============================================================
NEVPED() ;Return number of entries in V PATIENT ED.
;DBIA #4176
Q $P(^AUPNVPED(0),U,4)
;
;===============================================================
NEVPOV() ;Return number of entries in V POV.
;DBIA #4176
Q $P(^AUPNVPOV(0),U,4)
;
;===============================================================
NEVSK() ;Return number of entries in V SKIN TEST.
;DBIA #4176
Q $P(^AUPNVSK(0),U,4)
;
;===============================================================
NEVXAM() ;Return number of entries in V EXAM.
;DBIA #4176
Q $P(^AUPNVXAM(0),U,4)
;
;===============================================================
NEYTD() ;Return number of entries in PSYCH INSTRUMENT PATIENT
N DATE,DFN,NE,TEST
;DBIA #4184
S (DFN,NE)=0
F S DFN=$O(^YTD(601.2,DFN)) Q:+DFN=0 D
. S TEST=0
. F S TEST=$O(^YTD(601.2,DFN,1,TEST)) Q:+TEST=0 D
.. S DATE=0
.. F S DATE=$O(^YTD(601.2,DFN,1,TEST,1,DATE)) Q:+DATE=0 S NE=NE+1
Q NE
;
;===============================================================
SETDATA(GBL,GLIST,NUMGBL,RTN,SF) ;
S NUMGBL=16
S GLIST(1)="LABORATORY TEST (CH, Anatomic Path, Micro)",GBL(1)=63
S GLIST(2)="MENTAL HEALTH",GBL(2)=601.2
S GLIST(3)="ORDER",GBL(3)=100
S GLIST(4)="PTF",GBL(4)=45
S GLIST(5)="PHARMACY PATIENT",GBL(5)=55
S GLIST(6)="PRESCRIPTION",GBL(6)=52
S GLIST(7)="PROBLEM LIST",GBL(7)=9000011
S GLIST(8)="RADIOLOGY",GBL(8)=70
S GLIST(9)="V CPT",GBL(9)=9000010.18
S GLIST(10)="V EXAM",GBL(10)=9000010.13
S GLIST(11)="V HEALTH FACTORS",GBL(11)=9000010.23
S GLIST(12)="V IMMUNIZATION",GBL(12)=9000010.11
S GLIST(13)="V PATIENT ED",GBL(13)=9000010.16
S GLIST(14)="V POV",GBL(14)=9000010.07
S GLIST(15)="V SKIN TEST",GBL(15)=9000010.12
S GLIST(16)="VITAL MEASUREMENT",GBL(16)=120.5
S RTN(45)="NEPTF^PXRMISE"
S RTN(52)="NEPSRX^PSO52CLR"
S RTN(55)="NEPS^PSSCLINR"
S RTN(63)="NELR^PXRMLABS"
S RTN(70)="NERAD^PXRMISE"
S RTN(100)="NEOR^PXRMISE"
S RTN(120.5)="NEVIT^PXRMISE"
S RTN(601.2)="NEYTD^PXRMISE"
S RTN(9000011)="NEPROB^PXRMISE"
S RTN(9000010.07)="NEVPOV^PXRMISE"
S RTN(9000010.11)="NEVIMM^PXRMISE"
S RTN(9000010.12)="NEVSK^PXRMISE"
S RTN(9000010.13)="NEVXAM^PXRMISE"
S RTN(9000010.16)="NEVPED^PXRMISE"
S RTN(9000010.18)="NEVCPT^PXRMISE"
S RTN(9000010.23)="NEVHF^PXRMISE"
D LSF^PXRMISF(.SF)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMISE 9173 printed Sep 23, 2025@19:22:16 Page 2
PXRMISE ; SLC/PKR - Index size estimating routines. ;11/02/2009
+1 ;;2.0;CLINICAL REMINDERS;**6,12,17**;Feb 04, 2005;Build 102
+2 ;
+3 ;========================================================
EST ;Driver for making index counts.
+1 NEW BLOCKS,FROM,FUNCTION,GBL,GLIST,IND,NE,NL,NUMGBL,RTN
+2 NEW SF,TASKIT,TBLOCKS,TO,XMSUB
+3 DO SETDATA(.GBL,.GLIST,.NUMGBL,.RTN,.SF)
+4 IF +SF=-1
DO ERRORMSG^PXRMISF(SF)
QUIT
+5 SET (NL,TBLOCKS)=0
+6 SET NL=NL+1
SET ^TMP("PXRMXMZ",$JOB,NL,0)="Start time "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
+7 SET NL=NL+1
SET ^TMP("PXRMXMZ",$JOB,NL,0)=""
+8 SET NL=NL+1
SET ^TMP("PXRMXMZ",$JOB,NL,0)="Size Estimate for ^PXRMINDX"
+9 FOR IND=1:1:NUMGBL
Begin DoDot:1
+10 SET FUNCTION="S NE=$$"_RTN(GBL(IND))
+11 XECUTE FUNCTION
+12 SET BLOCKS=NE*SF(GBL(IND))
+13 SET BLOCKS=$FNUMBER(BLOCKS,"","")+1
+14 SET TBLOCKS=TBLOCKS+BLOCKS
+15 SET NL=NL+1
SET ^TMP("PXRMXMZ",$JOB,NL,0)=""
+16 SET NL=NL+1
SET ^TMP("PXRMXMZ",$JOB,NL,0)="Estimates for "_GLIST(IND)
+17 SET NL=NL+1
SET ^TMP("PXRMXMZ",$JOB,NL,0)=" Number of entries: "_NE
+18 SET NL=NL+1
SET ^TMP("PXRMXMZ",$JOB,NL,0)=" Number of blocks: "_BLOCKS
End DoDot:1
+19 SET NL=NL+1
SET ^TMP("PXRMXMZ",$JOB,NL,0)=""
+20 SET NL=NL+1
SET ^TMP("PXRMXMZ",$JOB,NL,0)="Total estimated blocks: "_TBLOCKS
+21 SET NL=NL+1
SET ^TMP("PXRMXMZ",$JOB,NL,0)=""
+22 SET NL=NL+1
SET ^TMP("PXRMXMZ",$JOB,NL,0)="End time "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
+23 SET XMSUB="Size estimate for index global"
+24 SET FROM=$$GET1^DIQ(200,DUZ,.01)
+25 SET TO(DUZ)=""
+26 DO SEND^PXRMMSG("PXRMXMZ",XMSUB,.TO,FROM)
+27 SET ZTREQ="@"
+28 QUIT
+29 ;
+30 ;===============================================================
ESTTASK ;Task the index size estimation.
+1 NEW DIR,DTOUT,DUOUT,MINDT,SDTIME,X,Y
+2 SET MINDT=$$NOW^XLFDT
+3 WRITE !,"Queue the Clinical Reminders index size estimation."
+4 SET DIR("A",1)="Enter the date and time you want the job to start."
+5 SET DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
+6 SET DIR("A")="Start the task at: "
+7 SET DIR(0)="DAU"_U_MINDT_"::RSX"
+8 DO ^DIR
+9 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+10 SET SDTIME=Y
+11 KILL DIR
+12 ;Put the task into the queue.
+13 SET ZTRTN="EST^PXRMISE"
+14 SET ZTDESC="Clinical Reminders index size estimation"
+15 SET ZTDTH=SDTIME
+16 SET ZTIO=""
+17 DO ^%ZTLOAD
+18 WRITE !,"Task number ",ZTSK," queued."
+19 QUIT
+20 ;
+21 ;===============================================================
NEOR() ;Return number of entries in OR.
+1 ;DBIA #4180
+2 QUIT $PIECE(^OR(100,0),U,4)
+3 ;
+4 ;===============================================================
NEPROB() ;Return number of entries in PROBLEM LIST.
+1 ;DBIA #3837
+2 QUIT $PIECE(^AUPNPROB(0),U,4)
+3 ;
+4 ;===============================================================
NEPS() ;Return number of entries in PS(55).
+1 NEW ADD,DA,DA1,DFN,DRUG,IND,NE,SDATE,SOL,STARTD,TEMP
+2 ;DBIA #4181
+3 SET (DFN,IND,NE)=0
+4 FOR
SET DFN=+$ORDER(^PS(55,DFN))
if DFN=0
QUIT
Begin DoDot:1
+5 ;Process Unit Dose.
+6 SET DA=0
+7 FOR
SET DA=+$ORDER(^PS(55,DFN,5,DA))
if DA=0
QUIT
Begin DoDot:2
+8 SET TEMP=$GET(^PS(55,DFN,5,DA,2))
+9 SET STARTD=$PIECE(TEMP,U,2)
+10 IF STARTD=""
QUIT
+11 ;If the order is purged then SDATE is 1.
+12 SET SDATE=$PIECE(TEMP,U,4)
+13 IF SDATE=1
QUIT
+14 SET DA1=0
+15 FOR
SET DA1=+$ORDER(^PS(55,DFN,5,DA,1,DA1))
if DA1=0
QUIT
Begin DoDot:3
+16 SET DRUG=$PIECE(^PS(55,DFN,5,DA,1,DA1,0),U,1)
+17 IF DRUG=""
QUIT
+18 SET NE=NE+1
End DoDot:3
End DoDot:2
+19 ;Process the IV mutiple.
+20 SET DA=0
+21 FOR
SET DA=+$ORDER(^PS(55,DFN,"IV",DA))
if DA=0
QUIT
Begin DoDot:2
+22 SET TEMP=$GET(^PS(55,DFN,"IV",DA,0))
+23 SET STARTD=$PIECE(TEMP,U,2)
+24 IF STARTD=""
QUIT
+25 SET SDATE=$PIECE(TEMP,U,3)
+26 IF SDATE=1
QUIT
+27 ;Process Additives
+28 SET DA1=0
+29 FOR
SET DA1=+$ORDER(^PS(55,DFN,"IV",DA,"AD",DA1))
if DA1=0
QUIT
Begin DoDot:3
+30 SET ADD=$PIECE(^PS(55,DFN,"IV",DA,"AD",DA1,0),U,1)
+31 IF ADD=""
QUIT
+32 SET DRUG=$PIECE($GET(^PS(52.6,ADD,0)),U,2)
+33 IF DRUG=""
QUIT
+34 SET NE=NE+1
End DoDot:3
+35 ;Process Solutions
+36 SET DA1=0
+37 FOR
SET DA1=+$ORDER(^PS(55,DFN,"IV",DA,"SOL",DA1))
if DA1=0
QUIT
Begin DoDot:3
+38 SET SOL=$PIECE(^PS(55,DFN,"IV",DA,"SOL",DA1,0),U,1)
+39 IF SOL=""
QUIT
+40 SET DRUG=$PIECE($GET(^PS(52.7,SOL,0)),U,2)
+41 IF DRUG=""
QUIT
+42 SET NE=NE+1
End DoDot:3
End DoDot:2
End DoDot:1
+43 QUIT NE
+44 ;
+45 ;===============================================================
NEPSRX() ;Return number of entries in PSRX
+1 NEW DA,DA1,DATE,DSUP,DFN,DRUG,NE,RDATE,TEMP
+2 ;DBIA #4182
+3 SET (DA,NE)=0
+4 FOR
SET DA=+$ORDER(^PSRX(DA))
if DA=0
QUIT
Begin DoDot:1
+5 SET TEMP=$GET(^PSRX(DA,0))
+6 SET DFN=$PIECE(TEMP,U,2)
+7 IF DFN=""
QUIT
+8 SET DRUG=$PIECE(TEMP,U,6)
+9 IF DRUG=""
QUIT
+10 SET DSUP=$PIECE(TEMP,U,8)
+11 IF DSUP=""
QUIT
+12 SET RDATE=+$PIECE($GET(^PSRX(DA,2)),U,13)
+13 IF RDATE>0
SET NE=NE+1
+14 ;Process the refill mutiple.
+15 SET DA1=0
+16 FOR
SET DA1=+$ORDER(^PSRX(DA,1,DA1))
if DA1=0
QUIT
Begin DoDot:2
+17 SET TEMP=$GET(^PSRX(DA,1,DA1,0))
+18 SET DSUP=+$PIECE(TEMP,U,10)
+19 SET RDATE=+$PIECE(TEMP,U,18)
+20 IF RDATE>0
SET NE=NE+1
End DoDot:2
+21 ;Process the partial fill multiple.
+22 SET DA1=0
+23 FOR
SET DA1=+$ORDER(^PSRX(DA,"P",DA1))
if DA1=0
QUIT
Begin DoDot:2
+24 SET TEMP=$GET(^PSRX(DA,"P",DA1,0))
+25 SET DSUP=+$PIECE(TEMP,U,10)
+26 SET RDATE=+$PIECE(TEMP,U,19)
+27 IF RDATE>0
SET NE=NE+1
End DoDot:2
End DoDot:1
+28 QUIT NE
+29 ;
+30 ;===============================================================
NEPTF() ;Return number of entries in PTF.
+1 NEW D1,DA,DATE,DFN,ICD0,ICD9,JND,NE0,NE9,TEMP70,TEMP0,TEMPP,TEMPS
+2 ;DBIA #4177
+3 SET (DA,NE0,NE9)=0
+4 FOR
SET DA=+$ORDER(^DGPT(DA))
if DA=0
QUIT
Begin DoDot:1
+5 SET TEMP0=$GET(^DGPT(DA,0))
+6 SET DFN=$PIECE(TEMP0,U,1)
+7 IF DFN=""
QUIT
+8 SET D1=0
+9 FOR
SET D1=+$ORDER(^DGPT(DA,"S",D1))
if D1=0
QUIT
Begin DoDot:2
+10 SET TEMPS=$GET(^DGPT(DA,"S",D1,0))
+11 SET DATE=$PIECE(TEMPS,U,1)
+12 IF DATE=""
QUIT
+13 FOR JND=8,9,10,11,12
Begin DoDot:3
+14 SET ICD0=$PIECE(TEMPS,U,JND)
+15 IF (ICD0'="")
IF $DATA(^ICD0(ICD0))
SET NE0=NE0+1
End DoDot:3
End DoDot:2
+16 ;
+17 SET D1=0
+18 FOR
SET D1=+$ORDER(^DGPT(DA,"P",D1))
if D1=0
QUIT
Begin DoDot:2
+19 SET TEMPP=$GET(^DGPT(DA,"P",D1,0))
+20 SET DATE=$PIECE(TEMPP,U,1)
+21 IF DATE=""
QUIT
+22 FOR JND=5,6,7,8,9
Begin DoDot:3
+23 SET ICD0=$PIECE(TEMPP,U,JND)
+24 IF (ICD0'="")
IF $DATA(^ICD0(ICD0))
SET NE0=NE0+1
End DoDot:3
End DoDot:2
+25 ;
+26 ;Discharge ICD9 codes
+27 IF $DATA(^DGPT(DA,70))
Begin DoDot:2
+28 SET TEMP70=$GET(^DGPT(DA,70))
+29 FOR JND=10,11,16,17,18,19,20,21,22,23,24
Begin DoDot:3
+30 SET ICD9=$PIECE(TEMP70,U,JND)
+31 IF (ICD9'="")
IF $DATA(^ICD9(ICD9))
SET NE9=NE9+1
End DoDot:3
End DoDot:2
+32 ;
+33 ;Movement ICD9 codes
+34 IF '$DATA(^DGPT(DA,"M"))
QUIT
+35 SET D1=0
+36 FOR
SET D1=$ORDER(^DGPT(DA,"M",D1))
if +D1=0
QUIT
Begin DoDot:2
+37 SET TEMPS=$GET(^DGPT(DA,"M",D1,0))
+38 SET DATE=$PIECE(TEMPS,U,10)
+39 IF DATE=""
QUIT
+40 FOR JND=5,6,7,8,9,11,12,13,14,15
Begin DoDot:3
+41 SET ICD9=$PIECE(TEMPS,U,JND)
+42 IF (ICD9'="")
IF $DATA(^ICD9(ICD9))
SET NE9=NE9+1
End DoDot:3
End DoDot:2
End DoDot:1
+43 QUIT NE0+NE9
+44 ;
+45 ;===============================================================
NERAD() ;Return number of entries in RAD/NUC MED PATIENT.
+1 NEW IEN,NE
+2 ;DBIA #4183
+3 SET (IEN,NE)=0
+4 FOR
SET IEN=$ORDER(^RADPT(IEN))
if +IEN=0
QUIT
SET NE=NE+$PIECE($GET(^RADPT(IEN,"DT",0)),U,4)
+5 QUIT NE
+6 ;
+7 ;===============================================================
NEVCPT() ;Return number of entries in V CPT.
+1 ;DBIA #4176
+2 QUIT $PIECE(^AUPNVCPT(0),U,4)
+3 ;
+4 ;===============================================================
NEVHF() ;Return number of entries in V HEALTH FACTORS.
+1 ;DBIA #4176
+2 QUIT $PIECE(^AUPNVHF(0),U,4)
+3 ;
+4 ;===============================================================
NEVIMM() ;Return number of entries in V IMMUNIZATION
+1 ;DBIA #4176
+2 QUIT $PIECE(^AUPNVIMM(0),U,4)
+3 ;
+4 ;===============================================================
NEVIT() ;Return number of entries in GMRV VITAL MEASUREMENT
+1 ;DBIA #4178
+2 QUIT $PIECE(^GMR(120.5,0),U,4)
+3 ;
+4 ;===============================================================
NEVPED() ;Return number of entries in V PATIENT ED.
+1 ;DBIA #4176
+2 QUIT $PIECE(^AUPNVPED(0),U,4)
+3 ;
+4 ;===============================================================
NEVPOV() ;Return number of entries in V POV.
+1 ;DBIA #4176
+2 QUIT $PIECE(^AUPNVPOV(0),U,4)
+3 ;
+4 ;===============================================================
NEVSK() ;Return number of entries in V SKIN TEST.
+1 ;DBIA #4176
+2 QUIT $PIECE(^AUPNVSK(0),U,4)
+3 ;
+4 ;===============================================================
NEVXAM() ;Return number of entries in V EXAM.
+1 ;DBIA #4176
+2 QUIT $PIECE(^AUPNVXAM(0),U,4)
+3 ;
+4 ;===============================================================
NEYTD() ;Return number of entries in PSYCH INSTRUMENT PATIENT
+1 NEW DATE,DFN,NE,TEST
+2 ;DBIA #4184
+3 SET (DFN,NE)=0
+4 FOR
SET DFN=$ORDER(^YTD(601.2,DFN))
if +DFN=0
QUIT
Begin DoDot:1
+5 SET TEST=0
+6 FOR
SET TEST=$ORDER(^YTD(601.2,DFN,1,TEST))
if +TEST=0
QUIT
Begin DoDot:2
+7 SET DATE=0
+8 FOR
SET DATE=$ORDER(^YTD(601.2,DFN,1,TEST,1,DATE))
if +DATE=0
QUIT
SET NE=NE+1
End DoDot:2
End DoDot:1
+9 QUIT NE
+10 ;
+11 ;===============================================================
SETDATA(GBL,GLIST,NUMGBL,RTN,SF) ;
+1 SET NUMGBL=16
+2 SET GLIST(1)="LABORATORY TEST (CH, Anatomic Path, Micro)"
SET GBL(1)=63
+3 SET GLIST(2)="MENTAL HEALTH"
SET GBL(2)=601.2
+4 SET GLIST(3)="ORDER"
SET GBL(3)=100
+5 SET GLIST(4)="PTF"
SET GBL(4)=45
+6 SET GLIST(5)="PHARMACY PATIENT"
SET GBL(5)=55
+7 SET GLIST(6)="PRESCRIPTION"
SET GBL(6)=52
+8 SET GLIST(7)="PROBLEM LIST"
SET GBL(7)=9000011
+9 SET GLIST(8)="RADIOLOGY"
SET GBL(8)=70
+10 SET GLIST(9)="V CPT"
SET GBL(9)=9000010.18
+11 SET GLIST(10)="V EXAM"
SET GBL(10)=9000010.13
+12 SET GLIST(11)="V HEALTH FACTORS"
SET GBL(11)=9000010.23
+13 SET GLIST(12)="V IMMUNIZATION"
SET GBL(12)=9000010.11
+14 SET GLIST(13)="V PATIENT ED"
SET GBL(13)=9000010.16
+15 SET GLIST(14)="V POV"
SET GBL(14)=9000010.07
+16 SET GLIST(15)="V SKIN TEST"
SET GBL(15)=9000010.12
+17 SET GLIST(16)="VITAL MEASUREMENT"
SET GBL(16)=120.5
+18 SET RTN(45)="NEPTF^PXRMISE"
+19 SET RTN(52)="NEPSRX^PSO52CLR"
+20 SET RTN(55)="NEPS^PSSCLINR"
+21 SET RTN(63)="NELR^PXRMLABS"
+22 SET RTN(70)="NERAD^PXRMISE"
+23 SET RTN(100)="NEOR^PXRMISE"
+24 SET RTN(120.5)="NEVIT^PXRMISE"
+25 SET RTN(601.2)="NEYTD^PXRMISE"
+26 SET RTN(9000011)="NEPROB^PXRMISE"
+27 SET RTN(9000010.07)="NEVPOV^PXRMISE"
+28 SET RTN(9000010.11)="NEVIMM^PXRMISE"
+29 SET RTN(9000010.12)="NEVSK^PXRMISE"
+30 SET RTN(9000010.13)="NEVXAM^PXRMISE"
+31 SET RTN(9000010.16)="NEVPED^PXRMISE"
+32 SET RTN(9000010.18)="NEVCPT^PXRMISE"
+33 SET RTN(9000010.23)="NEVHF^PXRMISE"
+34 DO LSF^PXRMISF(.SF)
+35 QUIT
+36 ;
