Changeset 623 for WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXAPHA2.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXAPHA2.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXAPHA2.m
r613 r623 1 ECXAPHA2 ;ALB/TMD-Pharmacy Extracts Unusual Volumes Report ; 10/18/07 2:10pm 2 ;;3.0;DSS EXTRACTS;**40,49,84,104,105**;Dec 22, 1997;Build 70 3 ; 4 EN ; entry point 5 N COUNT,ECUNIT,LINE,ECDFN,ECD,ECDRG,ECDAY,ECDFN,ECQTY,ECUNIT,ECCOST,ECDS 6 K ^TMP($J) 7 S (COUNT,ECDS)=0,ECUNIT="" 8 S ECD=ECSD1,ECED=ECED+.3 9 S LINE=$S(ECXOPT=1:"PRE",ECXOPT=2:"IVP",ECXOPT=3:"UDP",1:"EXIT") 10 D @LINE 11 Q 12 ; 13 PRE ; entry point for PRE data 14 N ECRFL,ECRX,ECREF,ECDATA,ECDATA1,ECPRC,IEN 15 K ^TMP($J,"ECXDSS") 16 ;call pharmacy api pso52ex 17 D EXTRACT^PSO52EX(ECD,ECED,"ECXDSS") 18 S ECREF="RF" 19 ;order thru fills and refills; refill values 0 thru 11 20 ; Note: refill 0 = original fill 21 F S ECD=$O(^TMP($J,"ECXDSS","AL",ECD)),IEN=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S IEN=$O(^(ECD,IEN)),ECRFL="" Q:'IEN Q:ECXERR F S ECRFL=$O(^(IEN,ECRFL)) Q:'ECRFL Q:ECXERR D PRE2 22 ; 23 ;order thru partial fills 24 S ECD=ECSD1,ECREF="P" 25 F S ECD=$O(^TMP($J,"ECXDSS","AM",ECD)),IEN=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S IEN=$O(^(ECD,IEN)),ECRFL="" Q:'IEN Q:ECXERR F S ECRFL=$O(^(IEN,ECRFL)) Q:'ECRFL Q:ECXERR D PRE2 26 K ^TMP($J,"ECXDSS") 27 Q 28 ; 29 PRE2 ; get Prescription data 30 I (ECREF="RF")&(ECRFL) D 31 .S ECQTY=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1) 32 .S ECDS=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1.1) 33 .S ECPRC=^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1.2) 34 I (ECREF="RF")&('ECRFL) D 35 .S ECQTY=+^TMP($J,"ECXDSS",IEN,7) 36 .S ECDS=+^TMP($J,"ECXDSS",IEN,8) 37 .S ECPRC=+^TMP($J,"ECXDSS",IEN,17) 38 I ECREF="P" D 39 .S ECQTY=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.04) 40 .S ECDS=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.041) 41 .S ECPRC=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.042) 42 ;check to see if quantity>threshold 43 I ECQTY>ECTHLD D 44 .S ECDAY=ECD 45 .S ECDFN=$P(^TMP($J,"ECXDSS",IEN,2),U) 46 .S ECDRG=+$P(^TMP($J,"ECXDSS",IEN,6),U) 47 .S ECCOST=ECQTY*ECPRC 48 .D FILE Q:ECXERR 49 Q 50 ; 51 IVP ; entry point for IVP Data 52 N DFN,ON,DA,SA,ECCOUNT 53 F S ECD=$O(^ECX(728.113,"A",ECD)),DFN=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S DFN=$O(^ECX(728.113,"A",ECD,DFN)),ON=0 Q:'DFN F S ON=$O(^ECX(728.113,"A",ECD,DFN,ON)),DA=0 Q:'ON K ^TMP($J,"A"),^("S") D Q:ECXERR 54 .F S DA=$O(^ECX(728.113,"A",ECD,DFN,ON,DA)) Q:'DA Q:ECXERR I $D(^ECX(728.113,DA,0)) S EC=^(0) Q:ECXERR D 55 ..S ECDRG=$P(EC,U,4) 56 ..S SA=$S($P(EC,U,8)]"":"A",$P(EC,U,9):"S",1:"") 57 ..; set up new record for first DA for this drug 58 ..I '$D(^TMP($J,SA,ECDRG)) D 59 ...S ECQTY=+$S(SA="A":+$P(EC,U,7),SA="S":+$P(EC,U,9),1:0) 60 ...S ECUNIT=$S(SA="A":$P(EC,U,8),SA="S":"ML",1:"") 61 ...S ECCOST=$P(EC,U,12),ECDFN=DFN 62 ...S ^TMP($J,SA,ECDRG)=ECUNIT_U_ECD_U_ECDFN_U_ECCOST_U_ECQTY 63 ...S ^(ECDRG,1)=0 64 ..; add to qty (0,1, or -1) to total 65 ..S ^TMP($J,SA,ECDRG,1)=^TMP($J,SA,ECDRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1) 66 .; looped thru all DAs for this order - now check for unusual volumes 67 .F SA="S","A" S ECDRG="" F S ECDRG=$O(^TMP($J,SA,ECDRG)) Q:ECDRG="" Q:ECXERR D 68 ..S ECQTY=$P(^TMP($J,SA,ECDRG),U,5),ECCOUNT=^(ECDRG,1) 69 ..S ECQTY=ECQTY*ECCOUNT 70 ..; check to see if quantity is outside of threshold range 71 ..I (ECQTY>ECTHLD)!(ECQTY<-ECTHLD) D 72 ...S ECUNIT=$P(^TMP($J,SA,ECDRG),U) 73 ...S ECDAY=$P(^(ECDRG),U,2) 74 ...S ECDFN=$P(^(ECDRG),U,3) 75 ...S ECCOST=$P(^(ECDRG),U,4)*ECCOUNT 76 ...D FILE Q:ECXERR 77 K ^TMP($J,"A"),^("S") 78 Q 79 ; 80 UDP ; entry point for UDP data 81 N ECXJ,ECDATA 82 F S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD Q:ECD>ECED Q:ECXERR D 83 .S ECXJ=0 F S ECXJ=$O(^ECX(728.904,"A",ECD,ECXJ)) Q:'ECXJ Q:ECXERR I $D(^ECX(728.904,ECXJ,0)) D 84 ..S DATA=^ECX(728.904,ECXJ,0),ECQTY=$P(DATA,U,5) 85 ..;check to see if quantity>threshold 86 ..I ECQTY>ECTHLD D 87 ...S ECDFN=$P(DATA,U,2),ECDRG=$P(DATA,U,4),ECCOST=$P(DATA,U,8),ECDAY=ECD 88 ...D FILE Q:ECXERR 89 Q 90 ; 91 FILE ; put records in temp file to print later 92 N OK,ECXPAT,ECNAME,ECSSN,ECGNAME,ECNDC,ECPROD,ECFKEY,ECXPHA 93 ; get demographics 94 S OK=$$PAT^ECXUTL3(ECDFN,$P(ECD,"."),"1;",.ECXPAT) 95 I 'OK Q 96 S ECNAME=ECXPAT("NAME") 97 S ECSSN=ECXPAT("SSN") 98 S ECDAY=$E(ECDAY,4,5)_"/"_$E(ECDAY,6,7) 99 ; get drug file data 100 S ECXPHA="",ECXPHA=$$PHAAPI^ECXUTL5(ECDRG) 101 S ECGNAME=$P(ECXPHA,U) 102 S ECNDC=$P(ECXPHA,U,3) 103 S ECNDC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0) 104 S ECNDC=$TR(ECNDC,"*",0) 105 S ECPROD=$P(ECXPHA,U,6) 106 S ECPROD=$$RJ^XLFSTR(ECPROD,5,0) 107 S ECFKEY=ECPROD_ECNDC 108 I ECXOPT'=2 S ECUNIT=$P(ECXPHA,U,8) 109 ; file 110 S ^TMP($J,ECFKEY,-ECQTY,ECDAY,ECSSN)=ECNAME_U_ECSSN_U_ECDAY_U_ECGNAME_U_ECFKEY_U_ECQTY_U_ECUNIT_U_"$"_$FNUMBER(ECCOST,",",2)_U_ECDS 111 S COUNT=COUNT+1 112 I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1 113 Q 114 ; 115 EXIT S ECXERR=1 Q 1 ECXAPHA2 ;ALB/TMD-Pharmacy Extracts Unusual Volumes Report ; 2/06/07 10:36am 2 ;;3.0;DSS EXTRACTS;**40,49,84,104**;Dec 22, 1997;Build 8 3 ; 4 EN ; entry point 5 N COUNT,ECUNIT,LINE,ECDFN,ECD,ECDRG,ECDAY,ECDFN,ECQTY,ECUNIT,ECCOST,ECDS 6 K ^TMP($J) 7 S (COUNT,ECDS)=0,ECUNIT="" 8 S ECD=ECSD1,ECED=ECED+.3 9 S LINE=$S(ECXOPT=1:"PRE",ECXOPT=2:"IVP",ECXOPT=3:"UDP",1:"EXIT") 10 D @LINE 11 Q 12 ; 13 PRE ; entry point for PRE data 14 ; order through fills, refills and partial refills 15 N ECRFL,ECRX,ECREF,ECDATA,ECDATA1,ECPRC 16 S ECREF=1 17 F S ECD=$O(^PSRX("AL",ECD)),ECRX=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S ECRX=$O(^PSRX("AL",ECD,ECRX)),ECRFL="" Q:'ECRX Q:ECXERR F S ECRFL=$O(^PSRX("AL",ECD,ECRX,ECRFL)) Q:ECRFL="" Q:ECXERR D PRE2 18 S ECD=ECSD1,ECREF="P" 19 F S ECD=$O(^PSRX("AM",ECD)),ECRX=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S ECRX=$O(^PSRX("AM",ECD,ECRX)),ECRFL="" Q:'ECRX F S ECRFL=$O(^PSRX("AM",ECD,ECRX,ECRFL)) Q:ECRFL="" Q:ECXERR D PRE2 20 Q 21 ; 22 PRE2 ; get Prescription data 23 S ECDATA=$G(^PSRX(ECRX,0)) 24 I ECRFL D 25 .S ECDATA1=$G(^PSRX(ECRX,ECREF,ECRFL,0)) 26 .S ECQTY=+$P(ECDATA1,U,4) 27 .S ECDS=+$P(ECDATA1,U,10) 28 .S ECPRC=+$P(ECDATA1,U,11) 29 I 'ECRFL D 30 .S ECQTY=+$P(ECDATA,U,7) 31 .S ECDS=+$P(ECDATA,U,8) 32 .S ECPRC=+$P(ECDATA,U,17) 33 ;check to see if quantity>threshold 34 I ECQTY>ECTHLD D 35 .S ECDAY=ECD 36 .S ECDFN=$P(ECDATA,U,2) 37 .S ECDRG=+$P(ECDATA,U,6) 38 .S ECCOST=ECQTY*ECPRC 39 .D FILE Q:ECXERR 40 Q 41 ; 42 IVP ; entry point for IVP Data 43 N DFN,ON,DA,SA,ECCOUNT 44 F S ECD=$O(^ECX(728.113,"A",ECD)),DFN=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S DFN=$O(^ECX(728.113,"A",ECD,DFN)),ON=0 Q:'DFN F S ON=$O(^ECX(728.113,"A",ECD,DFN,ON)),DA=0 Q:'ON K ^TMP($J,"A"),^("S") D Q:ECXERR 45 .F S DA=$O(^ECX(728.113,"A",ECD,DFN,ON,DA)) Q:'DA Q:ECXERR I $D(^ECX(728.113,DA,0)) S EC=^(0) Q:ECXERR D 46 ..S ECDRG=$P(EC,U,4) 47 ..S SA=$S($P(EC,U,8)]"":"A",$P(EC,U,9):"S",1:"") 48 ..; set up new record for first DA for this drug 49 ..I '$D(^TMP($J,SA,ECDRG)) D 50 ...S ECQTY=+$S(SA="A":+$P(EC,U,7),SA="S":+$P(EC,U,9),1:0) 51 ...S ECUNIT=$S(SA="A":$P(EC,U,8),SA="S":"ML",1:"") 52 ...S ECCOST=$P(EC,U,12),ECDFN=DFN 53 ...S ^TMP($J,SA,ECDRG)=ECUNIT_U_ECD_U_ECDFN_U_ECCOST_U_ECQTY 54 ...S ^(ECDRG,1)=0 55 ..; add to qty (0,1, or -1) to total 56 ..S ^TMP($J,SA,ECDRG,1)=^TMP($J,SA,ECDRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1) 57 .; looped thru all DAs for this order - now check for unusual volumes 58 .F SA="S","A" S ECDRG="" F S ECDRG=$O(^TMP($J,SA,ECDRG)) Q:ECDRG="" Q:ECXERR D 59 ..S ECQTY=$P(^TMP($J,SA,ECDRG),U,5),ECCOUNT=^(ECDRG,1) 60 ..S ECQTY=ECQTY*ECCOUNT 61 ..; check to see if quantity is outside of threshold range 62 ..I (ECQTY>ECTHLD)!(ECQTY<-ECTHLD) D 63 ...S ECUNIT=$P(^TMP($J,SA,ECDRG),U) 64 ...S ECDAY=$P(^(ECDRG),U,2) 65 ...S ECDFN=$P(^(ECDRG),U,3) 66 ...S ECCOST=$P(^(ECDRG),U,4)*ECCOUNT 67 ...D FILE Q:ECXERR 68 K ^TMP($J,"A"),^("S") 69 Q 70 ; 71 UDP ; entry point for UDP data 72 N ECXJ,ECDATA 73 F S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD Q:ECD>ECED Q:ECXERR D 74 .S ECXJ=0 F S ECXJ=$O(^ECX(728.904,"A",ECD,ECXJ)) Q:'ECXJ Q:ECXERR I $D(^ECX(728.904,ECXJ,0)) D 75 ..S DATA=^ECX(728.904,ECXJ,0),ECQTY=$P(DATA,U,5) 76 ..;check to see if quantity>threshold 77 ..I ECQTY>ECTHLD D 78 ...S ECDFN=$P(DATA,U,2),ECDRG=$P(DATA,U,4),ECCOST=$P(DATA,U,8),ECDAY=ECD 79 ...D FILE Q:ECXERR 80 Q 81 ; 82 FILE ; put records in temp file to print later 83 N OK,ECXPAT,ECNAME,ECSSN,ECGNAME,ECNDC,ECPROD,ECFKEY,ECXPHA 84 ; get demographics 85 S OK=$$PAT^ECXUTL3(ECDFN,$P(ECD,"."),"1;",.ECXPAT) 86 I 'OK Q 87 S ECNAME=ECXPAT("NAME") 88 S ECSSN=ECXPAT("SSN") 89 S ECDAY=$E(ECDAY,4,5)_"/"_$E(ECDAY,6,7) 90 ; get drug file data 91 S ECXPHA="",ECXPHA=$$PHAAPI^ECXUTL5(ECDRG) 92 S ECGNAME=$P(ECXPHA,U) 93 S ECNDC=$P(ECXPHA,U,3) 94 S ECNDC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0) 95 S ECNDC=$TR(ECNDC,"*",0) 96 S ECPROD=$P(ECXPHA,U,6) 97 S ECPROD=$$RJ^XLFSTR(ECPROD,5,0) 98 S ECFKEY=ECPROD_ECNDC 99 I ECXOPT'=2 S ECUNIT=$P(ECXPHA,U,8) 100 ; file 101 S ^TMP($J,ECFKEY,-ECQTY,ECDAY,ECSSN)=ECNAME_U_ECSSN_U_ECDAY_U_ECGNAME_U_ECFKEY_U_ECQTY_U_ECUNIT_U_"$"_$FNUMBER(ECCOST,",",2)_U_ECDS 102 S COUNT=COUNT+1 103 I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1 104 Q 105 ; 106 EXIT S ECXERR=1 Q
Note:
See TracChangeset
for help on using the changeset viewer.
