Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ECXUPRO1

ECXUPRO1.m

Go to the documentation of this file.
ECXUPRO1 ;ALB/TJL-Prosthetics Pre-Extract Unusual Cost Report; 01/08/08 2:49pm ;6/1/17  15:31
 ;;3.0;DSS EXTRACTS;**49,111,132,137,144,149,154,161,166**;Dec 22, 1997;Build 24
 ;
EN ; entry point
 N COUNT,ECDFN,ECD,PROCOST
 I '$G(ECXPORT) K ^TMP($J) ;144 If exporting, already killed
 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,ECXTYPED,ECXFORM ;154,161
 N DIC,DR,DA,DIQ
 S QFLG=0,ECXLNE=1,ECXED1=ECED ;161
 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 (ECXFORM,PROFORM)=$G(ECXP(660,SUBDA,11,"E"))_U_$G(ECXP(660,SUBDA,11,"I")) ;154
 ..Q:'$$PATDEM^ECXUTL2(ECXDFN,PDA)
 ..Q:'$$NTEG^ECXPRO1(ECXDFN,.ECXLNE,SUBDA,PRO0,PROLB,ECINST,PROFORM)
 ..S ECXTYPED=$S(ECXTYPE="I":"INITIAL ISSUE",ECXTYPE="R":"REPLACE",ECXTYPE="S":"SPARE",ECXTYPE="X":"REPAIR",ECXTYPE=5:"RENTAL",1:"") ;Set tran type description based on tran type
 ..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 ;154 Allow cost for inventory and stock items to come through
 ..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(ECXPHCPC,1,5) ;149 use PSAS HCPCS instead of HCPCS code
 I PROFORM["-3" F ECXLAB="LAB","ORD" D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB,ECXNPPDC)
 I PROFORM'["-3" S ECXLAB="NONL" D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB,ECXNPPDC)
 S PROQTY=$P(PRO0,U,7)
 S:(+PROQTY=0) PROQTY=1
 S PROQTY=$S('$G(ECXPORT):$$RJ^XLFSTR(PROQTY,8),1:PROQTY) ;144,149
 S ^TMP($J,ECXFEKEY,-PROQTY,SUBDA,PROSSN)=PRONAME_U_PROSSN_U_PRODAY_U_$P(ECXFORM,U,2)_$S($G(ECXPORT):(U_$P(ECXFORM,U)),1:"")_U_ECXPHCPC_U_ECXFEKEY_U_PROQTY_U_$S('$G(ECXPORT):"$",1:"")_$FNUMBER(PROCOST,",",2)_U_ECXTYPE_U_ECXTYPED ;144,149,154,161
 S COUNT=COUNT+1
 I COUNT#100=0 I $$S^ZTLOAD S (ZTSTOP,ECXERR)=1
 Q
EXIT S ECXERR=1 Q