Changeset 623 for WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUPRO1.m

Timestamp:

Dec 4, 2009, 12:11:15 AM (14 years ago)

Author:

George Lilly

Message:

revised back to 6/30/08 version

File:

• WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUPRO1.m (modified) (1 diff)

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUPRO1.m

@@ -1 @@
-ECXUPRO1        ;ALB/TJL-Prosthetics Extract Unusual Cost Report; 01/08/08 2:49pm
-        ;;3.0;DSS EXTRACTS;**49,111**;Jul 2, 2003;Build 4
-        ;
-EN      ; entry point
-        N COUNT,ECDFN,ECD,PROCOST
-        K ^TMP($J)
-        S COUNT=0
-        S ECD=ECSD1,ECED=ECED+.3
-        D GETRECS
-        Q
-        ;
-GETRECS ; get records that are over the threshold
-        N PDA,SUBDA,PROLB,PRO0,PROFORM
-        N DIC,DR,DA,DIQ
-        S QFLG=0,ECXLNE=1,ECXED1=ECED+.9999
-        S PDA=ECSD1
-        F  S PDA=$O(^RMPR(660,"CT",PDA)) Q:(PDA>ECXED1)!('PDA)!(QFLG=1)  D
-        .S SUBDA=0
-        .F  S SUBDA=$O(^RMPR(660,"CT",PDA,SUBDA))  Q:('SUBDA)!(QFLG=1)  D
-        ..Q:'$D(^RMPR(660,SUBDA,0))
-        ..S PRO0=^RMPR(660,SUBDA,0)
-        ..S PROLB=$G(^RMPR(660,SUBDA,"LB"))
-        ..K ECXP S DIC="^RMPR(660,",DR=".02;11",DA=SUBDA,DIQ(0)="EI"
-        ..S DIQ="ECXP" D EN^DIQ1
-        ..S ECXDFN=$G(ECXP(660,SUBDA,.02,"I"))
-        ..S PROFORM=$G(ECXP(660,SUBDA,11,"E"))_U_$G(ECXP(660,SUBDA,11,"I"))
-        ..Q:'$$PATDEM^ECXUTL2(ECXDFN,PDA)
-        ..Q:'$$NTEG^ECXPRO1(ECXDFN,.ECXLNE,SUBDA,PRO0,PROLB,ECINST,PROFORM)
-        ..S PROCOST=$P(PRO0,U,16)
-        ..S:PROFORM["-3" PROCOST=$P(PROLB,U,9)
-        ..S:($P(PROFORM,U,2)=11)!($P(PROFORM,U,2)=12) PROCOST=0
-        ..S:PROCOST="" PROCOST=0
-        ..S PROCOST=(PROCOST+.5)\1
-        ..S:PROCOST>999999 PROCOST=999999
-        ..I PROCOST>ECTHLD D FILE
-        Q
-FILE    ; put records in temp file to print later
-        N OK,PROPAT,PRONAME,PROSSN,CPTCODE,ECXFEKEY,PROQTY
-        S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECD,"."),"1;",.PROPAT)
-        I 'OK Q
-        S PRONAME=PROPAT("NAME")
-        S PROSSN=PROPAT("SSN")
-        S PRODAY=$E(PDA,4,5)_"/"_$E(PDA,6,7)_"/"_$E(PDA,2,3)
-        S CPTCODE=$E(ECXHCPCS,1,5)
-        I PROFORM["-3" F ECXLAB="LAB","ORD" D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB)
-        I PROFORM'["-3" S ECXLAB="NONL" D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB)
-        S PROQTY=$P(PRO0,U,7)
-        S:(+PROQTY=0) PROQTY=1
-        S PROQTY=$$RJ^XLFSTR(PROQTY,8,0)
-        S ^TMP($J,ECXFEKEY,-PROQTY,SUBDA,PROSSN)=PRONAME_U_PROSSN_U_PRODAY_U_ECXHCPCS_U_ECXFEKEY_U_PROQTY_U_"$"_$FNUMBER(PROCOST,",",2)
-        S COUNT=COUNT+1
-        I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1
-        Q
-EXIT    S ECXERR=1 Q
+ECXUPRO1 ;ALB/TJL-Prosthetics Extract Unusual Cost Report; 7/2/03 2:49pm
+ ;;3.0;DSS EXTRACTS;**49**;Jul 2, 2003
+ ;
+EN ; entry point
+ N COUNT,ECDFN,ECD,PROCOST
+ K ^TMP($J)
+ S COUNT=0
+ S ECD=ECSD1,ECED=ECED+.3
+ D GETRECS
+ Q
+ ;
+GETRECS ; get records that are over the threshold
+ N PDA,SUBDA,PROLB,PRO0,PROFORM
+ N DIC,DR,DA,DIQ
+ S QFLG=0,ECXLNE=1,ECXED1=ECED+.9999
+ S PDA=ECSD1
+ F  S PDA=$O(^RMPR(660,"CT",PDA)) Q:(PDA>ECXED1)!('PDA)!(QFLG=1)  D
+ .S SUBDA=0
+ .F  S SUBDA=$O(^RMPR(660,"CT",PDA,SUBDA))  Q:('SUBDA)!(QFLG=1)  D
+ ..Q:'$D(^RMPR(660,SUBDA,0))
+ ..S PRO0=^RMPR(660,SUBDA,0)
+ ..S PROLB=$G(^RMPR(660,SUBDA,"LB"))
+ ..K ECXP S DIC="^RMPR(660,",DR=".02;11",DA=SUBDA,DIQ(0)="EI"
+ ..S DIQ="ECXP" D EN^DIQ1
+ ..S ECXDFN=$G(ECXP(660,SUBDA,.02,"I"))
+ ..S PROFORM=$G(ECXP(660,SUBDA,11,"E"))_U_$G(ECXP(660,SUBDA,11,"I"))
+ ..Q:'$$PATDEM^ECXUTL2(ECXDFN,PDA)
+ ..Q:'$$NTEG^ECXPRO1(ECXDFN,.ECXLNE,SUBDA,PRO0,PROLB,ECINST,PROFORM)
+ ..S PROCOST=$P(PRO0,U,16)
+ ..S:PROFORM["-3" PROCOST=$P(PROLB,U,9)
+ ..S:($P(PROFORM,U,2)=11)!($P(PROFORM,U,2)=12) PROCOST=0
+ ..S:PROCOST="" PROCOST=0
+ ..S PROCOST=(PROCOST+.5)\1
+ ..S:PROCOST>999999 PROCOST=999999
+ ..I PROCOST>ECTHLD D FILE
+ Q
+FILE ; put records in temp file to print later
+ N OK,PROPAT,PRONAME,PROSSN,CPTCODE,ECXFEKEY,PROQTY
+ S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECD,"."),"1;",.PROPAT)
+ I 'OK Q
+ S PRONAME=PROPAT("NAME")
+ S PROSSN=PROPAT("SSN")
+ S PRODAY=$E(PDA,4,5)_"/"_$E(PDA,6,7)_"/"_$E(PDA,2,3)
+ S CPTCODE=$E(ECXHCPCS,1,5)
+ I PROFORM["-3" F ECXLAB="LAB","ORD" D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB)
+ I PROFORM'["-3" S ECXLAB="NONL" D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB)
+ S PROQTY=$P(PRO0,U,7)
+ S:(+PROQTY=0) PROQTY=1
+ S PROQTY=$$RJ^XLFSTR(PROQTY,8,0)
+ S ^TMP($J,ECXFEKEY,-PROQTY,PROSSN)=PRONAME_U_PROSSN_U_PRODAY_U_ECXHCPCS_U_ECXFEKEY_U_PROQTY_U_"$"_$FNUMBER(PROCOST,",",2)
+ S COUNT=COUNT+1
+ I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1
+ Q
+EXIT S ECXERR=1 Q