- 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 Mar 13, 2025@20:47:46 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
