RGVCCMR2 ;GAI/TMG,ALS-CMOR ACTIVITY SCORE GENERATOR (PART 2) ;10-6-1997
;;1.0;CLINICAL INFO RESOURCE NETWORK;**19,34**;30 Apr 99
;Reference to ^DGPT( and ^DGPT("B" supported by IA #92
;Reference to ^DIC(40.7 supported by IA #2501
;Reference to ^LR( supported by IA #2466
;Reference to ^PS(55 supported by IA #2470
;Reference to ^PSRX( supported by IA #2471
;Reference to ^RARPT( and ^RARPT("C" supported by IA #2442
;Reference to ^SCE( and ^SCE("C" supported by IA #2443
;
EN S U="^"
I '$D(RUNTYPE) I '$D(RGDFN) S RUNTYPE="I",RGDFN=0 K ^XTMP("RGVCCMR")
I RUNTYPE'="I",($G(RGDFN)'=0) D NOW^%DTC S ^XTMP("RGVCCMR","@@@@","RESTARTED")=% G BATCH
I RUNTYPE="I"!($G(RGDFN)=0) K ^XTMP("RGVCCMR")
D NOW^%DTC
;set purge date of XTMP = 30 days
S ^XTMP("RGVCCMR",0)=$$FMADD^XLFDT($$NOW^XLFDT,30)_U_$$NOW^XLFDT_U_"CMOR CALCULATION DATA"
BATCH I '$D(DT) S X="T",%DT="" D ^%DT S DT=Y
D NOW^%DTC
I $G(RGDFN)=0!(RUNTYPE="I") S ^XTMP("RGVCCMR","@@@@","STARTED")=%,$P(^RGSITE(991.8,1,"CMOR"),U,2)=%
S $P(^RGSITE(991.8,1,"CMOR"),U,8)=RUNTYPE
S:'$D(^XTMP("RGVCCMR","@@@@","BIG")) ^XTMP("RGVCCMR","@@@@","BIG")=0
ALLPTS S ^XTMP("RGVCCMR","@@@@","SECTION")="ALL"
S $P(^RGSITE(991.8,1,"CMOR"),U,7)="R"
S:'$D(^XTMP("RGVCCMR","@@@@","DFNCOUNT")) ^XTMP("RGVCCMR","@@@@","DFNCOUNT")=0
F S RGDFN=$O(^DPT(+RGDFN)) Q:+RGDFN'>0 I $D(^DPT(+RGDFN,0)) S DPT0=^(0) G:$P($G(^RGSITE(991.8,1,"CMOR")),U,4)="Y" STOP D
.S QUIT=0 D CKPT I QUIT Q
.S FILEFLG=0
.D CALCI S ^XTMP("RGVCCMR","@@@@","CURR DFN")=RGDFN S $P(^RGSITE(991.8,1,"CMOR"),U)=RGDFN
.I FILEFLG=1 D
..I SCORE>^XTMP("RGVCCMR","@@@@","BIG") S ^XTMP("RGVCCMR","@@@@","BIG")=SCORE
..S RATING=SCORE\100 S:'$D(^XTMP("RGVCCMR","@@@@","RATING",RATING)) ^XTMP("RGVCCMR","@@@@","RATING",RATING)=0
..S ^XTMP("RGVCCMR","@@@@","RATING",RATING)=^XTMP("RGVCCMR","@@@@","RATING",RATING)+1
STOP I $P($G(^RGSITE(991.8,1,"CMOR")),U,4)="Y" S $P(^RGSITE(991.8,1,"CMOR"),U,7)="SM",$P(^RGSITE(991.8,1,"CMOR"),U,4)=""
E S $P(^RGSITE(991.8,1,"CMOR"),U,7)="SN"
D NOW^%DTC
S ^XTMP("RGVCCMR","@@@@","STOPPED")=%
S $P(^RGSITE(991.8,1,"CMOR"),U,3)=%
D COUNT,KILL
Q
CALC ;API ENTRY POINT DBIA #2710
;VARIABLES: Input
; RGDFN - IEN of the patient in the Patient
; file (#2). RGDFN is not passed as a
; formal parameter, but is defined before
; calling CALC.
;
; Output: None (result sets score into PATIENT (#2))
;
N SCORE,X,STDT,%DT,APSTDT,YR,NXPC,PCCODE,XRCODE,LRCODE,NXSCE,SCED,VISIT,NXPTF,PTFD,ADM,NXXR,RARPTD,XRAY,NXRX,PSOVER,RXDT,RXIEN,RX,RGRXST,LRSCORE,LRDFN,LRSTDT,TEST,NXLR,FILEFLG,DIE,DR,DA
CALCI S SCORE=0,X="T-1065",%DT="" D ^%DT S STDT=Y,X="T",%DT="" D ^%DT
S APSTDT=Y,YR=$E(DT,1,3)
; Remove call to RGRSWPT, routine being deleted.
; Remove call to FBUTL for Fee Basis redesign.
;I '+$$ACTIVE^RGRSWPT(RGDFN) D Q
;.I '$$AUTH^FBUTL(RGDFN,"2961001") Q
;.D FILE
I '$D(DT) D NOW^%DTC S DT=%\1
OPT ; outpatient visit section
; each visit valued as follows: current fy = 30 pts.
; fy - 1 = 20 pts
; fy - 2 = 10 pts
; primary care visits (based on the PCCODE array) = 50 pts each in
; addition to the visit value
; XRCODE = ien of xray stop code LRCODE = ien of lab stop code
; encounters with a stop code for lab or xray are not counted to
; avoid duplication since lab & xray are counted separately
; in the XR & LR sections
K PCCODE S NXPC=0 F S NXPC=$O(^RGSITE(991.8,1,"PC",NXPC)) Q:+NXPC'>0 I $D(^DIC(40.7,+$P($G(^RGSITE(991.8,1,"PC",NXPC,0)),U),0)) S PCCODE($P($G(^RGSITE(991.8,1,"PC",NXPC,0)),U))=""
I '$D(PCCODE) S PCCODE=""
S XRCODE=0 I $D(^DIC(40.7,"C",105)) S XRCODE=$O(^DIC(40.7,"C",105,0))
S LRCODE=0 I $D(^DIC(40.7,"C",108)) S LRCODE=$O(^DIC(40.7,"C",108,0))
K VISIT S NXSCE=0 F S NXSCE=$O(^SCE("C",+RGDFN,NXSCE)) Q:+NXSCE'>0 I $D(^SCE(+NXSCE,0)) S SCE0=^(0) D
.I $P(SCE0,U,3)=XRCODE!($P(SCE0,U,3))=LRCODE Q
.I $P(SCE0,U)>STDT I '$D(VISIT(+$P(SCE0,U)\1)) S VISIT(+$P(SCE0,U)\1)=30+(($E($P(SCE0,U),1,3)-YR)*10) S SCORE=SCORE+30+(($E($P(SCE0,U),1,3)-YR)*10)
.I $D(PCCODE(+$P(SCE0,U,3))) I '$D(VISIT($P(SCE0,U)\1)) S VISIT(+$P(SCE0,U)\1)=50 S SCORE=SCORE+50
.I $D(PCCODE(+$P(SCE0,U,3))) I $D(VISIT($P(SCE0,U)\1)) S VISIT(+$P(SCE0,U)\1)=VISIT(+$P(SCE0,U)\1)+50 S SCORE=SCORE+50
ADM ; past admission section
; each admission valued as follows: current fy = 50 pts
; fy - 1 = 40 pts
; fy - 2 = 30 pts
K ADM S NXPTF=0 F S NXPTF=$O(^DGPT("B",+RGDFN,NXPTF)) Q:+NXPTF'>0 I $D(^DGPT(NXPTF,0)) S PTF0=^(0) D
.I $P(PTF0,U,2)>STDT I '$D(ADM($P(PTF0,U,2)\1)) S ADM(+$P(PTF0,U,2)\1)=50+(($E($P(PTF0,U,2),1,3)-YR)*10) S SCORE=SCORE+50+(($E($P(PTF0,U,2),1,3)-YR)*10)
.I $D(ADM(+$P(PTF0,U,2)\1)) I $O(^DGPT(+NXPTF,"S",0)) S ADM($P(PTF0,U,2)\1)=ADM($P(PTF0,U,2)\1)+10 S SCORE=SCORE+10
XRAY ; radiololgy section - each radiology exam valued at 20 pts
;
S X="T-365",%DT="" D ^%DT S XRSTDT=Y
K XRAY S NXXR=0 F S NXXR=$O(^RARPT("C",+RGDFN,NXXR)) Q:+NXXR'>0 I $D(^RARPT(+NXXR,0)),$P(^(0),U,3)>XRSTDT S RARPT0=^(0) D
.I '$D(XRAY($P(RARPT0,U,3)\1)) S XRAY($P(RARPT0,U,3)\1)=20 S SCORE=SCORE+20
RX ; prescription section
;
; currently active prescriptions valued at 20 pts
K RX,^TMP("PSOR",$J) S NXRX=0
;check for version of Outpatient Pharmacy used
;if under 7.0 use direct global access, else use api PSOORDER
S PSOVER=$$VERSION^XPDUTL("PSO")
S RXDT=$$FMADD^XLFDT(DT,-121) F S RXDT=$O(^PS(55,RGDFN,"P","A",RXDT)) Q:RXDT'>0 S RXIEN=0 F S RXIEN=$O(^PS(55,RGDFN,"P","A",RXDT,RXIEN)) Q:RXIEN'>0 D
. I PSOVER<7 DO ;
.. I $D(^PSRX(+RXIEN,0)),$P(^(0),U,15)=0 S RX(NXRX)=20 S SCORE=SCORE+20
. I PSOVER'<7 D EN^PSOORDER(RGDFN,RXIEN) I $D(^TMP("PSOR",$J,RXIEN)) D
.. S RGRXST=$P($P(^TMP("PSOR",$J,RXIEN,0),"^",4),";") I RGRXST="A"!(RGRXST="S")!(RGRXST="H") S RX(NXRX)=20 K RGRXST S SCORE=SCORE+20
K ^TMP("PSOR",$J)
LR ; laboratory section
; "CH" = chemistry; "CY" = cytotology; "EM" = electron microscopy;
; "MI = microbiology; "SP" = surgical pathology
; each lab test done in the past year is valued at 10 points
;
S LRSCORE=0 I $D(^DPT(+RGDFN,"LR")) S LRDFN=^DPT(+RGDFN,"LR") I $D(^LR(+LRDFN)) S X="T-365",%DT="" D ^%DT S LRSTDT=Y-.0001 F TEST="CH","CY","EM","MI","SP" D
.S NXLR=0 F S NXLR=$O(^LR(+LRDFN,TEST,NXLR)) Q:+NXLR'>0 I $D(^(NXLR,0)),$P(^(0),U)>LRSTDT S LRSCORE=LRSCORE+10
S SCORE=SCORE+LRSCORE
FILE ; file score & date calculated in appropriate locations in the
; PATIENT file 'MPI' node
; scores are filed even if zero
; FILEFLG variable used to illiminate unnecessary statistcal processing
S FILEFLG=1
S DIE="^DPT(",DA=RGDFN,DR="991.06///^S X=SCORE;991.07///TODAY" D ^DIE
I $D(^XTMP("RGVCCMR","@@@@","DFNCOUNT")) S ^XTMP("RGVCCMR","@@@@","DFNCOUNT")=^XTMP("RGVCCMR","@@@@","DFNCOUNT")+1
Q
KILL K ADM,APSTDT,DA,DIE,DIC,RGDFN,DGS0,DPT0,DR,LRCODE,LRDFN,LRSCORE,LRSTDT
K NUM,NXLR,NXPTF,NXRX,NXSCE,NXXR,PCCODE,PTF0,PTNAM
K QUIT,RARPT0,RATE,RATING,RX,RXDT,RXIEN,SCE0,SCORE,SSN,STDT,TEST,VISIT,X
K XRAY,XRCODE,XRSTDT,Y,YR,%,%DT,NXPC,PSOVER,RUNTYPE,FILEFLG
S:$D(ZTQUEUED) ZTREQ="@"
Q
CKPT S PTNAM=$P(DPT0,U),SSN=$P(DPT0,U,9)
I PTNAM?1"ZZ".E S QUIT=1
I SSN?1"00000".E S QUIT=1
Q
COUNT S ^XTMP("RGVCCMR","@@@@","RATING","TCOUNT")=0,RATE="" F S RATE=$O(^XTMP("RGVCCMR","@@@@","RATING",RATE)) Q:RATE'?.N D
.;.W !,RATE
.S ^XTMP("RGVCCMR","@@@@","RATING","TCOUNT")=^XTMP("RGVCCMR","@@@@","RATING","TCOUNT")+^XTMP("RGVCCMR","@@@@","RATING",RATE)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGVCCMR2 7682 printed Sep 23, 2025@19:19:06 Page 2
RGVCCMR2 ;GAI/TMG,ALS-CMOR ACTIVITY SCORE GENERATOR (PART 2) ;10-6-1997
+1 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**19,34**;30 Apr 99
+2 ;Reference to ^DGPT( and ^DGPT("B" supported by IA #92
+3 ;Reference to ^DIC(40.7 supported by IA #2501
+4 ;Reference to ^LR( supported by IA #2466
+5 ;Reference to ^PS(55 supported by IA #2470
+6 ;Reference to ^PSRX( supported by IA #2471
+7 ;Reference to ^RARPT( and ^RARPT("C" supported by IA #2442
+8 ;Reference to ^SCE( and ^SCE("C" supported by IA #2443
+9 ;
EN SET U="^"
+1 IF '$DATA(RUNTYPE)
IF '$DATA(RGDFN)
SET RUNTYPE="I"
SET RGDFN=0
KILL ^XTMP("RGVCCMR")
+2 IF RUNTYPE'="I"
IF ($GET(RGDFN)'=0)
DO NOW^%DTC
SET ^XTMP("RGVCCMR","@@@@","RESTARTED")=%
GOTO BATCH
+3 IF RUNTYPE="I"!($GET(RGDFN)=0)
KILL ^XTMP("RGVCCMR")
+4 DO NOW^%DTC
+5 ;set purge date of XTMP = 30 days
+6 SET ^XTMP("RGVCCMR",0)=$$FMADD^XLFDT($$NOW^XLFDT,30)_U_$$NOW^XLFDT_U_"CMOR CALCULATION DATA"
BATCH IF '$DATA(DT)
SET X="T"
SET %DT=""
DO ^%DT
SET DT=Y
+1 DO NOW^%DTC
+2 IF $GET(RGDFN)=0!(RUNTYPE="I")
SET ^XTMP("RGVCCMR","@@@@","STARTED")=%
SET $PIECE(^RGSITE(991.8,1,"CMOR"),U,2)=%
+3 SET $PIECE(^RGSITE(991.8,1,"CMOR"),U,8)=RUNTYPE
+4 if '$DATA(^XTMP("RGVCCMR","@@@@","BIG"))
SET ^XTMP("RGVCCMR","@@@@","BIG")=0
ALLPTS SET ^XTMP("RGVCCMR","@@@@","SECTION")="ALL"
+1 SET $PIECE(^RGSITE(991.8,1,"CMOR"),U,7)="R"
+2 if '$DATA(^XTMP("RGVCCMR","@@@@","DFNCOUNT"))
SET ^XTMP("RGVCCMR","@@@@","DFNCOUNT")=0
+3 FOR
SET RGDFN=$ORDER(^DPT(+RGDFN))
if +RGDFN'>0
QUIT
IF $DATA(^DPT(+RGDFN,0))
SET DPT0=^(0)
if $PIECE($GET(^RGSITE(991.8,1,"CMOR")),U,4)="Y"
GOTO STOP
Begin DoDot:1
+4 SET QUIT=0
DO CKPT
IF QUIT
QUIT
+5 SET FILEFLG=0
+6 DO CALCI
SET ^XTMP("RGVCCMR","@@@@","CURR DFN")=RGDFN
SET $PIECE(^RGSITE(991.8,1,"CMOR"),U)=RGDFN
+7 IF FILEFLG=1
Begin DoDot:2
+8 IF SCORE>^XTMP("RGVCCMR","@@@@","BIG")
SET ^XTMP("RGVCCMR","@@@@","BIG")=SCORE
+9 SET RATING=SCORE\100
if '$DATA(^XTMP("RGVCCMR","@@@@","RATING",RATING))
SET ^XTMP("RGVCCMR","@@@@","RATING",RATING)=0
+10 SET ^XTMP("RGVCCMR","@@@@","RATING",RATING)=^XTMP("RGVCCMR","@@@@","RATING",RATING)+1
End DoDot:2
End DoDot:1
STOP IF $PIECE($GET(^RGSITE(991.8,1,"CMOR")),U,4)="Y"
SET $PIECE(^RGSITE(991.8,1,"CMOR"),U,7)="SM"
SET $PIECE(^RGSITE(991.8,1,"CMOR"),U,4)=""
+1 IF '$TEST
SET $PIECE(^RGSITE(991.8,1,"CMOR"),U,7)="SN"
+2 DO NOW^%DTC
+3 SET ^XTMP("RGVCCMR","@@@@","STOPPED")=%
+4 SET $PIECE(^RGSITE(991.8,1,"CMOR"),U,3)=%
+5 DO COUNT
DO KILL
+6 QUIT
CALC ;API ENTRY POINT DBIA #2710
+1 ;VARIABLES: Input
+2 ; RGDFN - IEN of the patient in the Patient
+3 ; file (#2). RGDFN is not passed as a
+4 ; formal parameter, but is defined before
+5 ; calling CALC.
+6 ;
+7 ; Output: None (result sets score into PATIENT (#2))
+8 ;
+9 NEW SCORE,X,STDT,%DT,APSTDT,YR,NXPC,PCCODE,XRCODE,LRCODE,NXSCE,SCED,VISIT,NXPTF,PTFD,ADM,NXXR,RARPTD,XRAY,NXRX,PSOVER,RXDT,RXIEN,RX,RGRXST,LRSCORE,LRDFN,LRSTDT,TEST,NXLR,FILEFLG,DIE,DR,DA
CALCI SET SCORE=0
SET X="T-1065"
SET %DT=""
DO ^%DT
SET STDT=Y
SET X="T"
SET %DT=""
DO ^%DT
+1 SET APSTDT=Y
SET YR=$EXTRACT(DT,1,3)
+2 ; Remove call to RGRSWPT, routine being deleted.
+3 ; Remove call to FBUTL for Fee Basis redesign.
+4 ;I '+$$ACTIVE^RGRSWPT(RGDFN) D Q
+5 ;.I '$$AUTH^FBUTL(RGDFN,"2961001") Q
+6 ;.D FILE
+7 IF '$DATA(DT)
DO NOW^%DTC
SET DT=%\1
OPT ; outpatient visit section
+1 ; each visit valued as follows: current fy = 30 pts.
+2 ; fy - 1 = 20 pts
+3 ; fy - 2 = 10 pts
+4 ; primary care visits (based on the PCCODE array) = 50 pts each in
+5 ; addition to the visit value
+6 ; XRCODE = ien of xray stop code LRCODE = ien of lab stop code
+7 ; encounters with a stop code for lab or xray are not counted to
+8 ; avoid duplication since lab & xray are counted separately
+9 ; in the XR & LR sections
+10 KILL PCCODE
SET NXPC=0
FOR
SET NXPC=$ORDER(^RGSITE(991.8,1,"PC",NXPC))
if +NXPC'>0
QUIT
IF $DATA(^DIC(40.7,+$PIECE($GET(^RGSITE(991.8,1,"PC",NXPC,0)),U),0))
SET PCCODE($PIECE($GET(^RGSITE(991.8,1,"PC",NXPC,0)),U))=""
+11 IF '$DATA(PCCODE)
SET PCCODE=""
+12 SET XRCODE=0
IF $DATA(^DIC(40.7,"C",105))
SET XRCODE=$ORDER(^DIC(40.7,"C",105,0))
+13 SET LRCODE=0
IF $DATA(^DIC(40.7,"C",108))
SET LRCODE=$ORDER(^DIC(40.7,"C",108,0))
+14 KILL VISIT
SET NXSCE=0
FOR
SET NXSCE=$ORDER(^SCE("C",+RGDFN,NXSCE))
if +NXSCE'>0
QUIT
IF $DATA(^SCE(+NXSCE,0))
SET SCE0=^(0)
Begin DoDot:1
+15 IF $PIECE(SCE0,U,3)=XRCODE!($PIECE(SCE0,U,3))=LRCODE
QUIT
+16 IF $PIECE(SCE0,U)>STDT
IF '$DATA(VISIT(+$PIECE(SCE0,U)\1))
SET VISIT(+$PIECE(SCE0,U)\1)=30+(($EXTRACT($PIECE(SCE0,U),1,3)-YR)*10)
SET SCORE=SCORE+30+(($EXTRACT($PIECE(SCE0,U),1,3)-YR)*10)
+17 IF $DATA(PCCODE(+$PIECE(SCE0,U,3)))
IF '$DATA(VISIT($PIECE(SCE0,U)\1))
SET VISIT(+$PIECE(SCE0,U)\1)=50
SET SCORE=SCORE+50
+18 IF $DATA(PCCODE(+$PIECE(SCE0,U,3)))
IF $DATA(VISIT($PIECE(SCE0,U)\1))
SET VISIT(+$PIECE(SCE0,U)\1)=VISIT(+$PIECE(SCE0,U)\1)+50
SET SCORE=SCORE+50
End DoDot:1
ADM ; past admission section
+1 ; each admission valued as follows: current fy = 50 pts
+2 ; fy - 1 = 40 pts
+3 ; fy - 2 = 30 pts
+4 KILL ADM
SET NXPTF=0
FOR
SET NXPTF=$ORDER(^DGPT("B",+RGDFN,NXPTF))
if +NXPTF'>0
QUIT
IF $DATA(^DGPT(NXPTF,0))
SET PTF0=^(0)
Begin DoDot:1
+5 IF $PIECE(PTF0,U,2)>STDT
IF '$DATA(ADM($PIECE(PTF0,U,2)\1))
SET ADM(+$PIECE(PTF0,U,2)\1)=50+(($EXTRACT($PIECE(PTF0,U,2),1,3)-YR)*10)
SET SCORE=SCORE+50+(($EXTRACT($PIECE(PTF0,U,2),1,3)-YR)*10)
+6 IF $DATA(ADM(+$PIECE(PTF0,U,2)\1))
IF $ORDER(^DGPT(+NXPTF,"S",0))
SET ADM($PIECE(PTF0,U,2)\1)=ADM($PIECE(PTF0,U,2)\1)+10
SET SCORE=SCORE+10
End DoDot:1
XRAY ; radiololgy section - each radiology exam valued at 20 pts
+1 ;
+2 SET X="T-365"
SET %DT=""
DO ^%DT
SET XRSTDT=Y
+3 KILL XRAY
SET NXXR=0
FOR
SET NXXR=$ORDER(^RARPT("C",+RGDFN,NXXR))
if +NXXR'>0
QUIT
IF $DATA(^RARPT(+NXXR,0))
IF $PIECE(^(0),U,3)>XRSTDT
SET RARPT0=^(0)
Begin DoDot:1
+4 IF '$DATA(XRAY($PIECE(RARPT0,U,3)\1))
SET XRAY($PIECE(RARPT0,U,3)\1)=20
SET SCORE=SCORE+20
End DoDot:1
RX ; prescription section
+1 ;
+2 ; currently active prescriptions valued at 20 pts
+3 KILL RX,^TMP("PSOR",$JOB)
SET NXRX=0
+4 ;check for version of Outpatient Pharmacy used
+5 ;if under 7.0 use direct global access, else use api PSOORDER
+6 SET PSOVER=$$VERSION^XPDUTL("PSO")
+7 SET RXDT=$$FMADD^XLFDT(DT,-121)
FOR
SET RXDT=$ORDER(^PS(55,RGDFN,"P","A",RXDT))
if RXDT'>0
QUIT
SET RXIEN=0
FOR
SET RXIEN=$ORDER(^PS(55,RGDFN,"P","A",RXDT,RXIEN))
if RXIEN'>0
QUIT
Begin DoDot:1
+8 ;
IF PSOVER<7
Begin DoDot:2
+9 IF $DATA(^PSRX(+RXIEN,0))
IF $PIECE(^(0),U,15)=0
SET RX(NXRX)=20
SET SCORE=SCORE+20
End DoDot:2
+10 IF PSOVER'<7
DO EN^PSOORDER(RGDFN,RXIEN)
IF $DATA(^TMP("PSOR",$JOB,RXIEN))
Begin DoDot:2
+11 SET RGRXST=$PIECE($PIECE(^TMP("PSOR",$JOB,RXIEN,0),"^",4),";")
IF RGRXST="A"!(RGRXST="S")!(RGRXST="H")
SET RX(NXRX)=20
KILL RGRXST
SET SCORE=SCORE+20
End DoDot:2
End DoDot:1
+12 KILL ^TMP("PSOR",$JOB)
LR ; laboratory section
+1 ; "CH" = chemistry; "CY" = cytotology; "EM" = electron microscopy;
+2 ; "MI = microbiology; "SP" = surgical pathology
+3 ; each lab test done in the past year is valued at 10 points
+4 ;
+5 SET LRSCORE=0
IF $DATA(^DPT(+RGDFN,"LR"))
SET LRDFN=^DPT(+RGDFN,"LR")
IF $DATA(^LR(+LRDFN))
SET X="T-365"
SET %DT=""
DO ^%DT
SET LRSTDT=Y-.0001
FOR TEST="CH","CY","EM","MI","SP"
Begin DoDot:1
+6 SET NXLR=0
FOR
SET NXLR=$ORDER(^LR(+LRDFN,TEST,NXLR))
if +NXLR'>0
QUIT
IF $DATA(^(NXLR,0))
IF $PIECE(^(0),U)>LRSTDT
SET LRSCORE=LRSCORE+10
End DoDot:1
+7 SET SCORE=SCORE+LRSCORE
FILE ; file score & date calculated in appropriate locations in the
+1 ; PATIENT file 'MPI' node
+2 ; scores are filed even if zero
+3 ; FILEFLG variable used to illiminate unnecessary statistcal processing
+4 SET FILEFLG=1
+5 SET DIE="^DPT("
SET DA=RGDFN
SET DR="991.06///^S X=SCORE;991.07///TODAY"
DO ^DIE
+6 IF $DATA(^XTMP("RGVCCMR","@@@@","DFNCOUNT"))
SET ^XTMP("RGVCCMR","@@@@","DFNCOUNT")=^XTMP("RGVCCMR","@@@@","DFNCOUNT")+1
+7 QUIT
KILL KILL ADM,APSTDT,DA,DIE,DIC,RGDFN,DGS0,DPT0,DR,LRCODE,LRDFN,LRSCORE,LRSTDT
+1 KILL NUM,NXLR,NXPTF,NXRX,NXSCE,NXXR,PCCODE,PTF0,PTNAM
+2 KILL QUIT,RARPT0,RATE,RATING,RX,RXDT,RXIEN,SCE0,SCORE,SSN,STDT,TEST,VISIT,X
+3 KILL XRAY,XRCODE,XRSTDT,Y,YR,%,%DT,NXPC,PSOVER,RUNTYPE,FILEFLG
+4 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 QUIT
CKPT SET PTNAM=$PIECE(DPT0,U)
SET SSN=$PIECE(DPT0,U,9)
+1 IF PTNAM?1"ZZ".E
SET QUIT=1
+2 IF SSN?1"00000".E
SET QUIT=1
+3 QUIT
COUNT SET ^XTMP("RGVCCMR","@@@@","RATING","TCOUNT")=0
SET RATE=""
FOR
SET RATE=$ORDER(^XTMP("RGVCCMR","@@@@","RATING",RATE))
if RATE'?.N
QUIT
Begin DoDot:1
+1 ;.W !,RATE
+2 SET ^XTMP("RGVCCMR","@@@@","RATING","TCOUNT")=^XTMP("RGVCCMR","@@@@","RATING","TCOUNT")+^XTMP("RGVCCMR","@@@@","RATING",RATE)
End DoDot:1
+3 QUIT
