Changeset 623 for WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXPRO1.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXPRO1.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXPRO1.m
r613 r623 1 ECXPRO1 ;ALB/GTS - Prosthetics Extract for DSS (Continued) ; 11/8/07 8:02am 2 ;;3.0;DSS EXTRACTS;**9,11,13,15,21,24,33,37,39,100,105**;Dec 22, 1997;Build 70 3 ; 4 NTEG(ECXDFN,ECXLNE,ECXPIEN,ECXN0,ECXNLB,ECINST,ECXFORM) ;** Check for required fields 5 ; Input 6 ; ECXDFN - ien in file #2 7 ; ECXLNE - line number variable (passed by reference) 8 ; ECXPIEN - IEN for the Prosthetics record 9 ; ECXN0 - zero node of the Prosthetics record 10 ; ECXNLB - LB node of the Prosthetics record 11 ; ECINST - station number being extracted 12 ; ECXFORM - Form Requested On 13 ; Output (to be KILLed by calling routine) 14 ; ^TMP("ECX-PRO EXC",$J) - Array for the exception message 15 ; ECXLNE - The number of the next line in the msg 16 ; ECXSTAT2 - Patient Station Number 17 ; ECXDATE - Delivery Date of Prosthesis 18 ; ECXTYPE - Type of Transaction work performed 19 ; ECXSRCE - Source of prosthesis 20 ; ECXHCPCS - CPT/HCPCS code for prosthesis 21 ; ECXRQST - Requesting Station 22 ; ECXRCST - Receiving Station 23 ; ECXPHCPC - PSAS HCPCS code; if 'unknown', then use CPT/HCPCS code 24 ; ECXNPPDC - NPPD code for repairs or new issues 25 ; Output (KILLed by NTEG) 26 ; ECXMISS - 1 indicates missing information 27 ; ECXGOOD - 0 indicates record should not be extracted 28 ; 29 N ECXGOOD,ECXMISS 30 S (ECXRCST,ECXRQST,ECXNPPDC)="",ECXGOOD=1,ECXSTAT2=$P(ECXN0,U,10) 31 I ECXSTAT2]"" D 32 .K ECXDIC 33 .S DA=ECXSTAT2,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 34 .D EN^DIQ1 S ECXSTAT2=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 35 .S:(ECINST'=$E(ECXSTAT2,1,3)) ECXGOOD=0 ;*Screen for incorrect Station 36 ; 37 ;** Screen out records 38 S:($P(ECXN0,U,17)'="") ECXGOOD=0 ;*SHIP/DEL is not NULL 39 S:($P(ECXN0,U,26)'="") ECXGOOD=0 ;*PICKUP/DEL is not NULL 40 S:(+($P($G(^RMPR(660,ECXPIEN,"AM")),U,2))=1) ECXGOOD=0 ;*NO ADMIN CT=1 41 S:(($P(ECXN0,U,15))'="") ECXGOOD=0 ;*HISTORICAL DATA is not NULL 42 ; 43 S ECXDATE=$P(ECXN0,U,12),ECXTYPE=$P(ECXN0,U,4),ECXSRCE=$P(ECXN0,U,14) 44 S ECXHCPCS=$P($G(^ICPT(+$P(ECXN0,U,22),0)),U,1),ECXCMOD="" 45 S ECXHCPCS=$$CPT^ECXUTL3(ECXHCPCS,ECXCMOD) 46 ;get psas hcpcs code from file #661.1 47 S ECXPHCPC=$P($G(^RMPR(660,ECXPIEN,1)),U,4) D 48 .;get nppd code for repairs and new issues 10 characters in length. 49 .I "X5"[ECXTYPE S ECXNPPDC=$TR($$GET1^DIQ(661.1,ECXPHCPC_",",5)," ","_") 50 .I "IR"[ECXTYPE S ECXNPPDC=$TR($$GET1^DIQ(661.1,ECXPHCPC_",",6)," ","_") 51 .I +ECXPHCPC S ECXPHCPC=$E($P($G(^RMPR(661.1,ECXPHCPC,0)),U,1),1,5) 52 .I ECXPHCPC="UNKNOWN" S ECXPHCPC=$E(ECXHCPCS,1,5) 53 ; 54 ;* Get Requesting Station Number 55 I ECXFORM["-3" D 56 .S ECXRQST=$P(ECXNLB,U,1) 57 .I ECXRQST]"" D 58 ..S DA=ECXRQST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 59 ..D EN^DIQ1 S ECXRQST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 60 S:(ECXFORM'["-3") ECXRQST="" 61 ; 62 ;* Screen out records 63 S:(+$P(ECXFORM,U,2)=13) ECXGOOD=0 ;*FORM REQUESTED ON = 13 64 ; 65 ;* Get Receiving Station Number 66 I ECXFORM["-3" D 67 .S ECXRCST=$P(ECXNLB,U,4) 68 .I ECXRCST]"" D 69 ..S DA=ECXRCST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 70 ..D EN^DIQ1 S ECXRCST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 71 S:(ECXFORM'["-3") ECXRCST="" 72 ; 73 ;** Check for integrity and set up the problem variable if right DIV 74 I ECXGOOD D CHK 75 Q ECXGOOD 76 ; 77 CHK ;*Check variables 78 ; Input 79 ; Variables set in and Output from NTEG^ECXPRO1 80 ; Output 81 ; ^TMP("ECX-PRO EXC",$J, - Global of records with integrity problems 82 ; 83 S ECXMISS="" 84 I ECXSTAT2']"" S ECXMISS=ECXMISS_"1" 85 S ECXMISS=ECXMISS_U 86 I ECXDFN=0 S ECXMISS=ECXMISS_"1" 87 S ECXMISS=ECXMISS_U 88 ;I ECXSSN']"" S ECXMISS=ECXMISS_"1" 89 S ECXMISS=ECXMISS_U 90 ;I ECXNA=" " S ECXMISS=ECXMISS_"1" 91 S ECXMISS=ECXMISS_U 92 I ECXDATE']"" S ECXMISS=ECXMISS_"1" 93 S ECXMISS=ECXMISS_U 94 I ECXTYPE']"" S ECXMISS=ECXMISS_"1" 95 S ECXMISS=ECXMISS_U 96 I ECXSRCE']"" S ECXMISS=ECXMISS_"1" 97 S ECXMISS=ECXMISS_U 98 I ECXHCPCS']"" S ECXMISS=ECXMISS_"1" 99 S ECXMISS=ECXMISS_U 100 I ECXFORM["-3" D 101 .I ECXRQST']"" S ECXMISS=ECXMISS_"1" 102 S ECXMISS=ECXMISS_U 103 I ECXFORM']"" S ECXMISS=ECXMISS_"1" 104 S ECXMISS=ECXMISS_U 105 I ECXFORM["-3" D 106 .I ECXRCST']"" S ECXMISS=ECXMISS_"1" 107 I ECXMISS'="^^^^^^^^^^" D 108 .S ECXGOOD=0 109 .D ECXMISLN^ECXPRO2(ECXMISS,.ECXLNE,ECXPIEN) 110 Q 111 ; 112 PROSINFO(ECXDA,ECXLB,ECX0,ECXFORM) ;*Get Prosthetics Information 113 ; 114 ; Input 115 ; ECDA - The IEN for the Prosthetics record 116 ; ECX0 - The zero node of the Prosthetics record 117 ; ECXLB - The LB node of the Prosthetics record 118 ; ECXFORM - The Form Requested On (to determine Lab transactions) 119 ; 120 ; Output (to be KILLed by calling routine) 121 ; ECXCTAMT - The Cost of Transaction 122 ; ECXLLC - The Lab Labor Cost 123 ; ECXLMC - The Lab Material Cost 124 ; ECXGRPR - The AMIS Grouper number 125 ; ECXBILST - The Billing Status 126 ; ECXQTY - The Quantity 127 ; 128 S (ECXLLC,ECXLMC,ECXCTAMT)="",ECXBILST=$P($G(^RMPR(660,ECXDA,"AM")),U,3) 129 S ECXQTY=$P(ECX0,U,7) 130 S:(+ECXQTY=0) ECXQTY=1 131 ; 132 ;- Set Quantity field to 8 chars (right-justified & padded w/zeros) 133 S ECXQTY=$$RJ^XLFSTR(ECXQTY,8,0) 134 S ECXGRPR=$P($G(^RMPR(660,ECXDA,"AMS")),U,1),ECXCTAMT=$P(ECX0,U,16) 135 I ECXFORM["-3" D 136 .S ECXCTAMT=$P(ECXLB,U,9),ECXLLC=$P(ECXLB,U,7),ECXLMC=$P(ECXLB,U,8) 137 ; 138 ;- If Stock Issue or Inventory Issue, Cost of Transaction=0 139 I $P(ECXFORM,U,2)=11!($P(ECXFORM,U,2)=12) S ECXCTAMT=0 140 S:ECXCTAMT="" ECXCTAMT=0 S:ECXCTAMT>999999 ECXCTAMT=999999 141 S:ECXLLC="" ECXLLC=0 S:ECXLLC>999999 ECXLLC=999999 142 S:ECXLMC="" ECXLMC=0 S:ECXLMC>999999 ECXLMC=999999 143 ; 144 ;- Round to next dollar amount 145 I (ECXCTAMT#1)>.50 S ECXCTAMT=(ECXCTAMT+1)\1 146 I (ECXLLC#1)>.50 S ECXLLC=(ECXLLC+1)\1 147 I (ECXLMC#1)>.50 S ECXLMC=(ECXLMC+1)\1 148 Q 1 ECXPRO1 ;ALB/GTS - Prosthetics Extract for DSS (Continued) ; DEC 15, 2006 2 ;;3.0;DSS EXTRACTS;**9,11,13,15,21,24,33,37,39,100**;Dec 22, 1997;Build 2 3 ; 4 NTEG(ECXDFN,ECXLNE,ECXPIEN,ECXN0,ECXNLB,ECINST,ECXFORM) ;** Check for required fields 5 ; Input 6 ; ECXDFN - ien in file #2 7 ; ECXLNE - line number variable (passed by reference) 8 ; ECXPIEN - IEN for the Prosthetics record 9 ; ECXN0 - zero node of the Prosthetics record 10 ; ECXNLB - LB node of the Prosthetics record 11 ; ECINST - station number being extracted 12 ; ECXFORM - Form Requested On 13 ; Output (to be KILLed by calling routine) 14 ; ^TMP("ECX-PRO EXC",$J) - Array for the exception message 15 ; ECXLNE - The number of the next line in the msg 16 ; ECXSTAT2 - Patient Station Number 17 ; ECXDATE - Delivery Date of Prosthesis 18 ; ECXTYPE - Type of Transaction work performed 19 ; ECXSRCE - Source of prosthesis 20 ; ECXHCPCS - CPT/HCPCS code for prosthesis 21 ; ECXRQST - Requesting Station 22 ; ECXRCST - Receiving Station 23 ; ECXPHCPC - PSAS HCPCS code; if 'unknown', then use CPT/HCPCS code 24 ; Output (KILLed by NTEG) 25 ; ECXMISS - 1 indicates missing information 26 ; ECXGOOD - 0 indicates record should not be extracted 27 ; 28 N ECXGOOD,ECXMISS 29 S (ECXRCST,ECXRQST)="",ECXGOOD=1,ECXSTAT2=$P(ECXN0,U,10) 30 I ECXSTAT2]"" D 31 .K ECXDIC 32 .S DA=ECXSTAT2,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 33 .D EN^DIQ1 S ECXSTAT2=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 34 .S:(ECINST'=$E(ECXSTAT2,1,3)) ECXGOOD=0 ;*Screen for incorrect Station 35 ; 36 ;** Screen out records 37 S:($P(ECXN0,U,17)'="") ECXGOOD=0 ;*SHIP/DEL is not NULL 38 S:($P(ECXN0,U,26)'="") ECXGOOD=0 ;*PICKUP/DEL is not NULL 39 S:(+($P($G(^RMPR(660,ECXPIEN,"AM")),U,2))=1) ECXGOOD=0 ;*NO ADMIN CT=1 40 S:(($P(ECXN0,U,15))'="") ECXGOOD=0 ;*HISTORICAL DATA is not NULL 41 ; 42 S ECXDATE=$P(ECXN0,U,12),ECXTYPE=$P(ECXN0,U,4),ECXSRCE=$P(ECXN0,U,14) 43 S ECXHCPCS=$P($G(^ICPT(+$P(ECXN0,U,22),0)),U,1),ECXCMOD="" 44 S ECXHCPCS=$$CPT^ECXUTL3(ECXHCPCS,ECXCMOD) 45 ;get psas hcpcs code from file #661.1 46 S ECXPHCPC=$P($G(^RMPR(660,ECXPIEN,1)),U,4) D 47 .;I +ECXPHCPC S ECXPHCPC=$P($G(^RMPR(661.1,ECXPHCPC,0)),U,1) 48 .I +ECXPHCPC S ECXPHCPC=$E($P($G(^RMPR(661.1,ECXPHCPC,0)),U,1),1,5) 49 .I ECXPHCPC="UNKNOWN" S ECXPHCPC=$E(ECXHCPCS,1,5) 50 ; 51 ;* Get Requesting Station Number 52 I ECXFORM["-3" D 53 .S ECXRQST=$P(ECXNLB,U,1) 54 .I ECXRQST]"" D 55 ..S DA=ECXRQST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 56 ..D EN^DIQ1 S ECXRQST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 57 S:(ECXFORM'["-3") ECXRQST="" 58 ; 59 ;* Screen out records 60 S:(+$P(ECXFORM,U,2)=13) ECXGOOD=0 ;*FORM REQUESTED ON = 13 61 ; 62 ;* Get Receiving Station Number 63 I ECXFORM["-3" D 64 .S ECXRCST=$P(ECXNLB,U,4) 65 .I ECXRCST]"" D 66 ..S DA=ECXRCST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 67 ..D EN^DIQ1 S ECXRCST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 68 S:(ECXFORM'["-3") ECXRCST="" 69 ; 70 ;** Check for integrity and set up the problem variable if right DIV 71 I ECXGOOD D CHK 72 Q ECXGOOD 73 ; 74 CHK ;*Check variables 75 ; Input 76 ; Variables set in and Output from NTEG^ECXPRO1 77 ; Output 78 ; ^TMP("ECX-PRO EXC",$J, - Global of records with integrity problems 79 ; 80 S ECXMISS="" 81 I ECXSTAT2']"" S ECXMISS=ECXMISS_"1" 82 S ECXMISS=ECXMISS_U 83 I ECXDFN=0 S ECXMISS=ECXMISS_"1" 84 S ECXMISS=ECXMISS_U 85 ;I ECXSSN']"" S ECXMISS=ECXMISS_"1" 86 S ECXMISS=ECXMISS_U 87 ;I ECXNA=" " S ECXMISS=ECXMISS_"1" 88 S ECXMISS=ECXMISS_U 89 I ECXDATE']"" S ECXMISS=ECXMISS_"1" 90 S ECXMISS=ECXMISS_U 91 I ECXTYPE']"" S ECXMISS=ECXMISS_"1" 92 S ECXMISS=ECXMISS_U 93 I ECXSRCE']"" S ECXMISS=ECXMISS_"1" 94 S ECXMISS=ECXMISS_U 95 I ECXHCPCS']"" S ECXMISS=ECXMISS_"1" 96 S ECXMISS=ECXMISS_U 97 I ECXFORM["-3" D 98 .I ECXRQST']"" S ECXMISS=ECXMISS_"1" 99 S ECXMISS=ECXMISS_U 100 I ECXFORM']"" S ECXMISS=ECXMISS_"1" 101 S ECXMISS=ECXMISS_U 102 I ECXFORM["-3" D 103 .I ECXRCST']"" S ECXMISS=ECXMISS_"1" 104 I ECXMISS'="^^^^^^^^^^" D 105 .S ECXGOOD=0 106 .D ECXMISLN^ECXPRO2(ECXMISS,.ECXLNE,ECXPIEN) 107 Q 108 ; 109 PROSINFO(ECXDA,ECXLB,ECX0,ECXFORM) ;*Get Prosthetics Information 110 ; 111 ; Input 112 ; ECDA - The IEN for the Prosthetics record 113 ; ECX0 - The zero node of the Prosthetics record 114 ; ECXLB - The LB node of the Prosthetics record 115 ; ECXFORM - The Form Requested On (to determine Lab transactions) 116 ; 117 ; Output (to be KILLed by calling routine) 118 ; ECXCTAMT - The Cost of Transaction 119 ; ECXLLC - The Lab Labor Cost 120 ; ECXLMC - The Lab Material Cost 121 ; ECXGRPR - The AMIS Grouper number 122 ; ECXBILST - The Billing Status 123 ; ECXQTY - The Quantity 124 ; 125 S (ECXLLC,ECXLMC,ECXCTAMT)="",ECXBILST=$P($G(^RMPR(660,ECXDA,"AM")),U,3) 126 S ECXQTY=$P(ECX0,U,7) 127 S:(+ECXQTY=0) ECXQTY=1 128 ; 129 ;- Set Quantity field to 8 chars (right-justified & padded w/zeros) 130 S ECXQTY=$$RJ^XLFSTR(ECXQTY,8,0) 131 S ECXGRPR=$P($G(^RMPR(660,ECXDA,"AMS")),U,1),ECXCTAMT=$P(ECX0,U,16) 132 I ECXFORM["-3" D 133 .S ECXCTAMT=$P(ECXLB,U,9),ECXLLC=$P(ECXLB,U,7),ECXLMC=$P(ECXLB,U,8) 134 ; 135 ;- If Stock Issue or Inventory Issue, Cost of Transaction=0 136 I $P(ECXFORM,U,2)=11!($P(ECXFORM,U,2)=12) S ECXCTAMT=0 137 S:ECXCTAMT="" ECXCTAMT=0 S:ECXCTAMT>999999 ECXCTAMT=999999 138 S:ECXLLC="" ECXLLC=0 S:ECXLLC>999999 ECXLLC=999999 139 S:ECXLMC="" ECXLMC=0 S:ECXLMC>999999 ECXLMC=999999 140 ; 141 ;- Round to next dollar amount 142 I (ECXCTAMT#1)>.50 S ECXCTAMT=(ECXCTAMT+1)\1 143 I (ECXLLC#1)>.50 S ECXLLC=(ECXLLC+1)\1 144 I (ECXLMC#1)>.50 S ECXLMC=(ECXLMC+1)\1 145 Q
Note:
See TracChangeset
for help on using the changeset viewer.
