Changeset 623 for WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW24.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW24.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW24.m
r613 r623 1 SCRPW24 2 ;;5.3;Scheduling;**144,163,180,254,243,295,329,351,510**;AUG 13, 1993;Build33 4 5 6 7 APAC(SDX) 8 9 10 11 12 APOTR 13 14 15 16 17 APAP(SDX) 18 19 20 21 22 APEM(SDX) 23 24 25 26 27 CLCG(SDX) 28 29 30 31 CLCN(SDX) 32 33 34 35 CLCS(SDX) 36 37 38 39 DXAD(SDX) 40 41 42 43 DXOTR 44 45 46 47 48 49 50 51 52 53 54 DXGS(SDX,SDZ) 55 56 57 58 59 DXGSQ(SDI) 60 61 62 63 64 65 DXPD(SDX) 66 67 68 69 70 71 DXSD(SDX) 72 73 74 75 76 77 ENED(SDX,SDZ) 78 79 80 81 ENEF(SDX,SDZ) 82 83 84 85 ENEP(SDX,SDZ) 86 87 88 89 ENES(SDX,SDZ) 90 91 92 93 ENFR(SDX,SDZ) 94 95 96 97 ENSE(SDX,SDZ) 98 99 100 101 ENQ(SDZ) 102 103 104 105 106 OEAT(SDX) 107 108 109 110 OEDV(SDX) 111 112 113 114 OEEE(SDX) 115 116 117 118 OEOP(SDX) 119 120 121 122 OEPA(SDX) 123 124 125 126 OEES(SDX) 127 128 129 130 OETS(SDX) 131 132 133 TSQ(DIR) 134 135 136 137 138 CLQ(DIR,SDZ) 139 140 141 142 OECL(SDX,SDZ) 143 144 145 146 OEOU(SDX) 147 148 149 150 151 152 SUQ(DIR) 153 154 155 156 OESU(SDX) 157 158 159 160 161 162 163 164 PCPR(SDX,SDZ) 165 166 167 168 169 PCTM(SDX,SDZ) 170 171 172 173 174 PDPA(SDX) 175 176 177 178 PDPS(SDX) 179 180 181 182 PDSC(SDX) 183 184 185 186 PDZC(SDX) 187 188 189 190 ENROL(SDATE) 191 N SDY,SDI,X1,X2,X,%Y S:SDATE#1=0 SDATE=SDATE+.9999 S SDI=0 F S SDI=$O(^DGEN(27.11,"C",+$P(SDOE0,U,2),SDI)) Q:'SDI S SDY=$G(^DGEN(27.11,SDI,0)),SDY($P($P(^DGEN(27.11,SDI,"U"),U,1),".",1))=SDY ;SD/510 changed logic to use date/time entered 192 193 194 NX 195 196 FST(SDX,SDFI,SDFE) 197 198 1 SCRPW24 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ;06/19/99 2 ;;5.3;Scheduling;**144,163,180,254,243,295,329,351**;AUG 13, 1993 3 ;06/19/99 ACS - Added CPT modifier API calls 4 ; 5 ;11/26/03 RLC - 329 fixes primary/secondary dx problem with report 6 ; 7 APAC(SDX) ;Get all procedure codes 8 ;K SDX N SDY,SDI D GETCPT^SDOE(SDOE,"SDY") S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI S SDX=$P(SDY(SDI),U),SDX=SDX_U_$P($G(^ICPT(+SDX,0)),U)_U_$P(SDY(SDI),U,16) I $L($P(SDX,U,2)) D APOTR S SDX(SDI)=SDX 9 D APAC^SCRPW241(.SDX) 10 D NX Q 11 ; 12 APOTR ;Transform procedure external value 13 ;S $P(SDX,U,2)=$P(SDX,U,2)_" "_$P(^ICPT(+SDX,0),U,2) Q 14 D APOTR^SCRPW241(.SDX) 15 Q 16 ; 17 APAP(SDX) ;Get ambulatory procedures (no E&M codes) 18 ;K SDX N SDY,SDI D GETCPT^SDOE(SDOE,"SDY") S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI S SDX=$P(SDY(SDI),U) I '$D(^IBE(357.69,"B",SDX)) S SDX=SDX_U_$P($G(^ICPT(+SDX,0)),U) I $L($P(SDX,U,2)) D APOTR S SDX(SDI)=SDX 19 D APAP^SCRPW241(.SDX) 20 D NX Q 21 ; 22 APEM(SDX) ;Get evaluation and management codes 23 ;K SDX N SDY,SDI D GETCPT^SDOE(SDOE,"SDY") S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI S SDX=$P(SDY(SDI),U) I $D(^IBE(357.69,"B",SDX)) S SDX=SDX_U_$P($G(^ICPT(+SDX,0)),U) I $L($P(SDX,U,2)) D APOTR S SDX(SDI)=SDX 24 D APEM^SCRPW241(.SDX) 25 D NX Q 26 ; 27 CLCG(SDX) ;Get clinic group 28 K SDX S SDX=$P(SDOE0,U,4) I SDX S SDX=$P($G(^SC(SDX,0)),U,31) I SDX,$D(^SD(409.67,SDX)) S SDX=SDX_U_$P(^SD(409.67,SDX,0),U) S:$L($P(SDX,U,2)) SDX(1)=SDX 29 D NX Q 30 ; 31 CLCN(SDX) ;Get clinic name 32 K SDX S SDX=$P(SDOE0,U,4) I SDX S SDX=SDX_U_$P($G(^SC(SDX,0)),U) I $L($P(SDX,U,2)) S SDX(1)=SDX 33 D NX Q 34 ; 35 CLCS(SDX) ;Get clinic service 36 K SDX S SDX=$P(SDOE0,U,4) I SDX S SDX=$P($G(^SC(SDX,0)),U,8) D FST(.SDX,44,9) S:$L($P(SDX,U,2)) SDX(1)=SDX 37 D NX Q 38 ; 39 DXAD(SDX) ;Get all diagnoses 40 K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI S SDX=$P(SDY(SDI),U) I SDX S SDX=SDX_U_$P($$ICDDX^ICDCODE(+SDX,+SDOE0),U,2) I $L($P(SDX,U,2)) D DXOTR S SDX(SDI)=SDX 41 D NX Q 42 ; 43 DXOTR ;Transform diagnosis external value 44 N ENCDT 45 S ENCDT=+$G(SDOE0) 46 I 'ENCDT D 47 .I '$G(SDOE) S ENCDT=$$NOW^XLFDT() Q 48 .N SDY 49 .D GETGEN^SDOE(SDOE,"SDY") 50 .S ENCDT=+$G(SDY(0)) 51 .K SDY 52 S SDX=SDX_" "_$P($$ICDDX^ICDCODE(+SDX,ENCDT),U,4) Q 53 ; 54 DXGS(SDX,SDZ) ;Get GAF score 55 K SDX N SDI,SDY S SDY=$S(SDZ="H":$P($P(SDOE0,U),"."),1:DT)_.9999,SDY=9999999-SDY,SDY=$O(^YSD(627.8,"AX5",$P(SDOE0,U,2),SDY)) 56 I SDY S SDI=$O(^YSD(627.8,"AX5",$P(SDOE0,U,2),SDY,""),-1) I SDI S SDX=+$P($G(^YSD(627.8,SDI,60)),U,3) I SDX S SDX(1)=SDX_U_SDX 57 D NX Q 58 ; 59 DXGSQ(SDI) ;Set up GAF help text 60 S SDIRQ("?",1)="Specify a value representing the Global Assessment of Functioning (GAF) score." 61 I SDI="H" S SDIRQ("?")="Status as of the encounter date/time is used to determine 'historical' values." 62 I SDI="C" S SDIRQ("?")="Status as of the report run date is used to determine 'current' values." 63 Q 64 ; 65 DXPD(SDX) ;Get primary diagnosis 66 ;K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI S SDX=$P(SDY(SDI),U) I SDX,$P(SDY(SDI),U,12)="P" S SDX=SDX_U_$P($$ICDDX^ICDCODE(+SDX),U,2) I $L($P(SDX,U,3)) D DXOTR S SDX(SDI)=SDX Q 67 ;SD*5.3*329 fixes problem of report not working for primary dx 68 K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI S SDX=$P(SDY(SDI),U) I SDX,$P(SDY(SDI),U,12)="P" S SDX=SDX_U_$P($$ICDDX^ICDCODE(+SDX,+SDOE0),U,2) I $L($P(SDX,U,2)) D DXOTR S SDX(SDI)=SDX 69 D NX Q 70 ; 71 DXSD(SDX) ;Get secondary diagnoses 72 ;K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI S SDX=$P(SDY(SDI),U) I SDX,$P(SDY(SDI),U,12)'="P" S SDX=SDX_U_$P($$ICDDX^ICDCODE(+SDX),U,2) I $L($P(SDX,U,3)) D DXOTR S SDX(SDI)=SDX 73 ;SD*5.3*329 fixes problem of report not working for secondary dx 74 K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI S SDX=$P(SDY(SDI),U) I SDX,$P(SDY(SDI),U,12)'="P" S SDX=SDX_U_$P($$ICDDX^ICDCODE(+SDX,+SDOE0),U,2) I $L($P(SDX,U,2)) D DXOTR S SDX(SDI)=SDX 75 D NX Q 76 ; 77 ENED(SDX,SDZ) ;Get enrollment date 78 K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S (SDX,Y)=$P(SDY,U) X ^DD("DD") S SDX(1)=SDX_U_Y 79 D NX Q 80 ; 81 ENEF(SDX,SDZ) ;Get enrollment effective date 82 K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S (SDX,Y)=$P(SDY,U,8) X ^DD("DD") S SDX(1)=SDX_U_Y 83 D NX Q 84 ; 85 ENEP(SDX,SDZ) ;Get enrollment priority 86 K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S SDX=$P(SDY,U,7) D FST(.SDX,27.11,.07) S:$L($P(SDX,U,2)) SDX(1)=SDX 87 D NX Q 88 ; 89 ENES(SDX,SDZ) ;Get enrollment status 90 K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S SDX=$P(SDY,U,4),SDX=SDX_U_$$EXTERNAL^DILFD(27.11,.04,"F",SDX) S:$L($P(SDX,U,2)) SDX(1)=SDX 91 D NX Q 92 ; 93 ENFR(SDX,SDZ) ;Get enrollment facility received 94 K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S SDX=$P(SDY,U,6) I SDX S SDX=SDX_U_$P($G(^DIC(4,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX 95 D NX Q 96 ; 97 ENSE(SDX,SDZ) ;Get enrollment source of enrollment 98 K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S SDX=$P(SDY,U,3) D FST(.SDX,27.11,.03) S:$L($P(SDX,U,2)) SDX(1)=SDX 99 D NX Q 100 ; 101 ENQ(SDZ) ;Set up help text for enrollment 102 I SDZ="H" S SDIRQ("?")="Enrollment status as of the encounter date/time is used for 'historical' values." 103 I SDZ="C" S SDIRQ("?")="Enrollment status as of the report run date is used for 'current' values." 104 Q 105 ; 106 OEAT(SDX) ;Get encounter appointment type 107 K SDX S SDX=$P(SDOE0,U,10) I SDX S SDX=SDX_U_$P($G(^SD(409.1,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX 108 D NX Q 109 ; 110 OEDV(SDX) ;Get encounter division 111 K SDX S SDX=$P(SDOE0,U,11) I SDX S SDX=SDX_U_$P($G(^DG(40.8,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX 112 D NX Q 113 ; 114 OEEE(SDX) ;Get encounter eligibility 115 K SDX S SDX=$P(SDOE0,U,13) I SDX S SDX=SDX_U_$P($G(^DIC(8,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX 116 D NX Q 117 ; 118 OEOP(SDX) ;Get encounter originating process type 119 K SDX S SDX=$P(SDOE0,U,8) D FST(.SDX,409.68,.08) S:$L($P(SDX,U,2)) SDX(1)=SDX 120 D NX Q 121 ; 122 OEPA(SDX) ;Get encounter patient 123 K SDX S DFN=$P(SDOE0,U,2) I DFN D DEM^VADPT I $L(VADM(1)) S SDX(1)=DFN_U_VADM(1) 124 D NX Q 125 ; 126 OEES(SDX) ;Get encounter status 127 K SDX S SDX=$P(SDOE0,U,12) I SDX S SDX=SDX_U_$P($G(^SD(409.63,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX 128 D NX Q 129 ; 130 OETS(SDX) ;Get transmission status 131 K SDX S SDX(1)=$$STX^SCRPW8(SDOE,SDOE0) Q 132 ; 133 TSQ(DIR) ;Set up DIR array for transmission status question 134 K DIR S DIR("A")="Select transmission status",DIR("?")="This value represents the transmission status of the encounter record." 135 S DIR(0)="SO^0:Not checked-out;1:No transmission record;2:Not required, not transmitted;3:Rejected for transmission;4:Awaiting transmission;5:Transmitted, no acknowledgment;6:Transmitted, rejected;7:Transmitted, error;8:Transmitted, accepted" 136 Q 137 ; 138 CLQ(DIR,SDZ) ;Set up DIR array for classification questions 139 K DIR S SDZ=$S(SDZ="A":"Agent Orange exposure",SDZ="I":"ionizing radiation exposure",SDZ="S":"service connected condition",1:"environmental contaminants exposure") 140 S DIR(0)="SO^1:YES;0:NO",DIR("A")="Treatment related to "_SDZ,DIR("?")="Indicates if treatment was related to "_SDZ Q 141 ; 142 OECL(SDX,SDZ) ;Get classification values 143 K SDX N SDY S SDZ=$S(SDZ="A":1,SDZ="I":2,SDZ="S":3,SDZ="E":4,1:"") I SDZ D CLASK^SDCO2(SDOE,.SDY) S SDX=$P($G(SDY(SDZ)),U,2) I $L(SDX) S SDX(1)=$S(SDX=1:"1^YES",1:"0^NO") 144 D NX Q 145 ; 146 OEOU(SDX) ;Get option used to create 147 K SDX S SDX=+$P(SDOE0,U,5),SDX=+$P($G(^AUPNVSIT(SDX,0)),U,24) 148 N SDY D GETS^DIQ(19,SDX,.01,"","SDY") 149 S SDX=SDX_U_SDY(19,SDX_",",.01) S:$L($P(SDX,U,2)) SDX(1)=SDX 150 D NX Q 151 ; 152 SUQ(DIR) ;Set up DIR() array for Scheduled/unscheduled question 153 K DIR S DIR("A")="Select outpatient activity type",DIR("?",1)="Only pre-scheduled appointments will be reflected as SCHEDULED. All other",DIR("?",2)="types of activity (add/edits, registrations, walkins or unscheduled activity)" 154 S DIR("?")="will be reflected as UNSCHEDULED.",DIR(0)="SO^S:SCHEDULED;U:UNSCHEDULED" Q 155 ; 156 OESU(SDX) ;Get scheduled/unscheduled status 157 N SDAP0 K SDX S SDX(1)="" 158 I $P(SDOE0,U,8)=1 D Q:$L(SDX(1)) 159 .S SDAP0=$G(^DPT(+$P(SDOE0,U,2),"S",+SDOE0,0)) 160 .Q:$P(SDAP0,U,20)'=SDOE Q:$P(SDAP0,U,7)=4 161 .S SDX(1)="S^SCHEDULED" Q 162 S SDX(1)="U^UNSCHEDULED" Q 163 ; 164 PCPR(SDX,SDZ) ;Get primary care provider 165 ;Required input: SDZ="C" for current, "H" for historical 166 K SDX S SDX=$S(SDZ="C":$$OUTPTPR^SDUTL3(+$P(SDOE0,U,2)),1:$$OUTPTPR^SDUTL3(+$P(SDOE0,U,2),+$P(SDOE0,U))) S:$L($P(SDX,U,2)) SDX(1)=SDX 167 D NX Q 168 ; 169 PCTM(SDX,SDZ) ;Get priamry care team 170 ;Required input: SDZ="C" for current, "H" for historical 171 K SDX S SDX=$S(SDZ="C":$$OUTPTTM^SDUTL3(+$P(SDOE0,U,2)),1:$$OUTPTTM^SDUTL3(+$P(SDOE0,U,2),+$P(SDOE0,U))) S:$L($P(SDX,U,2)) SDX(1)=SDX 172 D NX Q 173 ; 174 PDPA(SDX) ;Get patient age 175 K SDX S DFN=$P(SDOE0,U,2) I DFN D DEM^VADPT I VADM(4)=+VADM(4) S SDX(1)=VADM(4)_U_VADM(4) 176 D NX Q 177 ; 178 PDPS(SDX) ;Get patient sex 179 K SDX S DFN=$P(SDOE0,U,2) I DFN D DEM^VADPT I $L($P(VADM(5),U,2)) S SDX(1)=VADM(5) 180 D NX Q 181 ; 182 PDSC(SDX) ;Get patient state/county 183 K SDX S DFN=$P(SDOE0,U,2) I DFN D ADD^VADPT I $L($P(VAPA(7),U,2)) S SDX(1)=$P(VAPA(5),U)_";"_$P(VAPA(7),U)_U_$P(VAPA(5),U,2)_" / "_$P(VAPA(7),U,2) 184 D NX Q 185 ; 186 PDZC(SDX) ;Get patient zip code 187 K SDX S DFN=$P(SDOE0,U,2) I DFN D ADD^VADPT I $L(VAPA(6)) S SDX(1)=VAPA(6)_U_VAPA(6) 188 D NX Q 189 ; 190 ENROL(SDATE) ;Get enrollment record (most recent to encounter date) 191 N SDY,SDI,X1,X2,X,%Y S:SDATE#1=0 SDATE=SDATE+.9999 S SDI=0 F S SDI=$O(^DGEN(27.11,"C",+$P(SDOE0,U,2),SDI)) Q:'SDI S SDY=$G(^DGEN(27.11,SDI,0)),SDY(+SDY)=SDY 192 S SDI=$O(SDY(SDATE),-1) Q:'SDI "" S X1=$P($P(SDOE0,U),"."),X2=SDI D ^%DTC Q SDY(SDI) 193 ; 194 NX S:$D(SDX)<10 SDX(1)="~~~NONE~~~^~~~NONE~~~" Q 195 ; 196 FST(SDX,SDFI,SDFE) ;Field set transform 197 Q:'$L(SDX) N SDY,SDI D FIELD^DID(SDFI,SDFE,"","POINTER","SDY") S SDY=SDY("POINTER") F SDI=1:1:$L(SDY,";") I SDX=$P($P(SDY,";",SDI),":") S SDX=SDX_U_$P($P(SDY,";",SDI),":",2) Q 198 Q
Note:
See TracChangeset
for help on using the changeset viewer.
