source: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGVCCMR2.m@ 628

Last change on this file since 628 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.4 KB
Line 
1RGVCCMR2 ;GAI/TMG,ALS-CMOR ACTIVITY SCORE GENERATOR (PART 2) ;10-6-1997
2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**19,34**;30 Apr 99
3 ;Reference to ^DGPT( and ^DGPT("B" supported by IA #92
4 ;Reference to ^DIC(40.7 supported by IA #2501
5 ;Reference to ^LR( supported by IA #2466
6 ;Reference to ^PS(55 supported by IA #2470
7 ;Reference to ^PSRX( supported by IA #2471
8 ;Reference to ^RARPT( and ^RARPT("C" supported by IA #2442
9 ;Reference to ^SCE( and ^SCE("C" supported by IA #2443
10 ;
11EN S U="^"
12 I '$D(RUNTYPE) I '$D(RGDFN) S RUNTYPE="I",RGDFN=0 K ^XTMP("RGVCCMR")
13 I RUNTYPE'="I",($G(RGDFN)'=0) D NOW^%DTC S ^XTMP("RGVCCMR","@@@@","RESTARTED")=% G BATCH
14 I RUNTYPE="I"!($G(RGDFN)=0) K ^XTMP("RGVCCMR")
15 D NOW^%DTC
16 ;set purge date of XTMP = 30 days
17 S ^XTMP("RGVCCMR",0)=$$FMADD^XLFDT($$NOW^XLFDT,30)_U_$$NOW^XLFDT_U_"CMOR CALCULATION DATA"
18BATCH I '$D(DT) S X="T",%DT="" D ^%DT S DT=Y
19 D NOW^%DTC
20 I $G(RGDFN)=0!(RUNTYPE="I") S ^XTMP("RGVCCMR","@@@@","STARTED")=%,$P(^RGSITE(991.8,1,"CMOR"),U,2)=%
21 S $P(^RGSITE(991.8,1,"CMOR"),U,8)=RUNTYPE
22 S:'$D(^XTMP("RGVCCMR","@@@@","BIG")) ^XTMP("RGVCCMR","@@@@","BIG")=0
23ALLPTS S ^XTMP("RGVCCMR","@@@@","SECTION")="ALL"
24 S $P(^RGSITE(991.8,1,"CMOR"),U,7)="R"
25 S:'$D(^XTMP("RGVCCMR","@@@@","DFNCOUNT")) ^XTMP("RGVCCMR","@@@@","DFNCOUNT")=0
26 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
27 .S QUIT=0 D CKPT I QUIT Q
28 .S FILEFLG=0
29 .D CALCI S ^XTMP("RGVCCMR","@@@@","CURR DFN")=RGDFN S $P(^RGSITE(991.8,1,"CMOR"),U)=RGDFN
30 .I FILEFLG=1 D
31 ..I SCORE>^XTMP("RGVCCMR","@@@@","BIG") S ^XTMP("RGVCCMR","@@@@","BIG")=SCORE
32 ..S RATING=SCORE\100 S:'$D(^XTMP("RGVCCMR","@@@@","RATING",RATING)) ^XTMP("RGVCCMR","@@@@","RATING",RATING)=0
33 ..S ^XTMP("RGVCCMR","@@@@","RATING",RATING)=^XTMP("RGVCCMR","@@@@","RATING",RATING)+1
34STOP 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)=""
35 E S $P(^RGSITE(991.8,1,"CMOR"),U,7)="SN"
36 D NOW^%DTC
37 S ^XTMP("RGVCCMR","@@@@","STOPPED")=%
38 S $P(^RGSITE(991.8,1,"CMOR"),U,3)=%
39 D COUNT,KILL
40 Q
41CALC ;API ENTRY POINT DBIA #2710
42 ;VARIABLES: Input
43 ; RGDFN - IEN of the patient in the Patient
44 ; file (#2). RGDFN is not passed as a
45 ; formal parameter, but is defined before
46 ; calling CALC.
47 ;
48 ; Output: None (result sets score into PATIENT (#2))
49 ;
50 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
51CALCI S SCORE=0,X="T-1065",%DT="" D ^%DT S STDT=Y,X="T",%DT="" D ^%DT
52 S APSTDT=Y,YR=$E(DT,1,3)
53 ; Remove call to RGRSWPT, routine being deleted.
54 ; Remove call to FBUTL for Fee Basis redesign.
55 ;I '+$$ACTIVE^RGRSWPT(RGDFN) D Q
56 ;.I '$$AUTH^FBUTL(RGDFN,"2961001") Q
57 ;.D FILE
58 I '$D(DT) D NOW^%DTC S DT=%\1
59OPT ; outpatient visit section
60 ; each visit valued as follows: current fy = 30 pts.
61 ; fy - 1 = 20 pts
62 ; fy - 2 = 10 pts
63 ; primary care visits (based on the PCCODE array) = 50 pts each in
64 ; addition to the visit value
65 ; XRCODE = ien of xray stop code LRCODE = ien of lab stop code
66 ; encounters with a stop code for lab or xray are not counted to
67 ; avoid duplication since lab & xray are counted separately
68 ; in the XR & LR sections
69 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))=""
70 I '$D(PCCODE) S PCCODE=""
71 S XRCODE=0 I $D(^DIC(40.7,"C",105)) S XRCODE=$O(^DIC(40.7,"C",105,0))
72 S LRCODE=0 I $D(^DIC(40.7,"C",108)) S LRCODE=$O(^DIC(40.7,"C",108,0))
73 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
74 .I $P(SCE0,U,3)=XRCODE!($P(SCE0,U,3))=LRCODE Q
75 .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)
76 .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
77 .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
78ADM ; past admission section
79 ; each admission valued as follows: current fy = 50 pts
80 ; fy - 1 = 40 pts
81 ; fy - 2 = 30 pts
82 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
83 .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)
84 .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
85XRAY ; radiololgy section - each radiology exam valued at 20 pts
86 ;
87 S X="T-365",%DT="" D ^%DT S XRSTDT=Y
88 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
89 .I '$D(XRAY($P(RARPT0,U,3)\1)) S XRAY($P(RARPT0,U,3)\1)=20 S SCORE=SCORE+20
90RX ; prescription section
91 ;
92 ; currently active prescriptions valued at 20 pts
93 K RX,^TMP("PSOR",$J) S NXRX=0
94 ;check for version of Outpatient Pharmacy used
95 ;if under 7.0 use direct global access, else use api PSOORDER
96 S PSOVER=$$VERSION^XPDUTL("PSO")
97 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
98 . I PSOVER<7 DO ;
99 .. I $D(^PSRX(+RXIEN,0)),$P(^(0),U,15)=0 S RX(NXRX)=20 S SCORE=SCORE+20
100 . I PSOVER'<7 D EN^PSOORDER(RGDFN,RXIEN) I $D(^TMP("PSOR",$J,RXIEN)) D
101 .. 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
102 K ^TMP("PSOR",$J)
103LR ; laboratory section
104 ; "CH" = chemistry; "CY" = cytotology; "EM" = electron microscopy;
105 ; "MI = microbiology; "SP" = surgical pathology
106 ; each lab test done in the past year is valued at 10 points
107 ;
108 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
109 .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
110 S SCORE=SCORE+LRSCORE
111FILE ; file score & date calculated in appropriate locations in the
112 ; PATIENT file 'MPI' node
113 ; scores are filed even if zero
114 ; FILEFLG variable used to illiminate unnecessary statistcal processing
115 S FILEFLG=1
116 S DIE="^DPT(",DA=RGDFN,DR="991.06///^S X=SCORE;991.07///TODAY" D ^DIE
117 I $D(^XTMP("RGVCCMR","@@@@","DFNCOUNT")) S ^XTMP("RGVCCMR","@@@@","DFNCOUNT")=^XTMP("RGVCCMR","@@@@","DFNCOUNT")+1
118 Q
119KILL K ADM,APSTDT,DA,DIE,DIC,RGDFN,DGS0,DPT0,DR,LRCODE,LRDFN,LRSCORE,LRSTDT
120 K NUM,NXLR,NXPTF,NXRX,NXSCE,NXXR,PCCODE,PTF0,PTNAM
121 K QUIT,RARPT0,RATE,RATING,RX,RXDT,RXIEN,SCE0,SCORE,SSN,STDT,TEST,VISIT,X
122 K XRAY,XRCODE,XRSTDT,Y,YR,%,%DT,NXPC,PSOVER,RUNTYPE,FILEFLG
123 S:$D(ZTQUEUED) ZTREQ="@"
124 Q
125CKPT S PTNAM=$P(DPT0,U),SSN=$P(DPT0,U,9)
126 I PTNAM?1"ZZ".E S QUIT=1
127 I SSN?1"00000".E S QUIT=1
128 Q
129COUNT S ^XTMP("RGVCCMR","@@@@","RATING","TCOUNT")=0,RATE="" F S RATE=$O(^XTMP("RGVCCMR","@@@@","RATING",RATE)) Q:RATE'?.N D
130 .;.W !,RATE
131 .S ^XTMP("RGVCCMR","@@@@","RATING","TCOUNT")=^XTMP("RGVCCMR","@@@@","RATING","TCOUNT")+^XTMP("RGVCCMR","@@@@","RATING",RATE)
132 Q
Note: See TracBrowser for help on using the repository browser.