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,187**;Dec 22, 1997;Build 163
;
; Reference to ^RMPR(600, in ICR #2528
; Reference to EN^DIQ1 in ICR #10015
; Reference to ^PRCD(420.1 in ICR #6887
; Reference to ^TMP supported by SACC 2.3.2.5.1
;
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,PROUNT,PROUNTIS,PROUNTFN ;154,161,187 - Added Unit of Issue
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 D FILE ;187 Add Unit Of Issue
...S PROUNT=$P(PRO0,U,8) ;187 Unit IEN
...S PROUNIT=$$GETUNIT(PROUNT) ;187
...S PROUNTIS=$P(PROUNIT,U),PROUNTFN=$P(PROUNIT,U,2) ;187
...I PROUNTIS'="" S ECXPROUN(PROUNTIS)=PROUNTFN ;187
Q
FILE ; put records in temp file to print later
N OK,PROPAT,PRONAME,PROSSN,CPTCODE,ECXFEKEY,PROQTY
N STR ;187
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,4),1:PROQTY) ;144,149,187 Change Quantity width from 8 to 4
;187 Begins : Add Code Description, Unit of Issue and Re-arange the columns
;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:"")_$FN(PROCOST,",",2)_U_ECXTYPE_U_ECXTYPED ;144,149,154,161
S STR=PRONAME_U_PROSSN_U_PRODAY_U_$P(ECXFORM,U,2)_$S($G(ECXPORT):(U_$P(ECXFORM,U)),1:"")_U_ECXFEKEY_U_ECXPHCPC_U_ECXPHCPD_U_ECXTYPE_U_ECXTYPED_U_PROQTY_U_PROUNTIS_$S($G(ECXPORT):(U_PROUNTFN),1:"")_U ;144,149,154,161,187
S STR=STR_$S('$G(ECXPORT):"$",1:"")_$FN(PROCOST,",",2) ;144,149,154,161,187
S ^TMP($J,ECXFEKEY,-PROQTY,SUBDA,PROSSN)=STR
;187 Ends
S COUNT=COUNT+1
I COUNT#100=0 I $$S^ZTLOAD S (ZTSTOP,ECXERR)=1
Q
;
GETUNIT(UNTIEN) ;187 Get Unit of Issue
N UNTNAME,UNTFNAME,UNTARR
N DIC,DA,DR,DIC
I UNTIEN="" Q ""
S DA=UNTIEN,DIC="^PRCD(420.5,",DR=".01;1",DIQ(0)="EI",DIQ="UNTARR" K UNTARR D EN^DIQ1
S UNTNAME=$G(UNTARR(420.5,UNTIEN,.01,"E")) ;187 Unit of Issue
S UNTFNAME=$G(UNTARR(420.5,UNTIEN,1,"E")) ;187 Unit of Issue (full name)
Q UNTNAME_U_UNTFNAME
;
EXIT S ECXERR=1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXUPRO1 3931 printed Nov 22, 2024@17:04:29 Page 2
ECXUPRO1 ;ALB/TJL-Prosthetics Pre-Extract Unusual Cost Report ;01/08/08 2:49pm ;6/1/17 15:31
+1 ;;3.0;DSS EXTRACTS;**49,111,132,137,144,149,154,161,166,187**;Dec 22, 1997;Build 163
+2 ;
+3 ; Reference to ^RMPR(600, in ICR #2528
+4 ; Reference to EN^DIQ1 in ICR #10015
+5 ; Reference to ^PRCD(420.1 in ICR #6887
+6 ; Reference to ^TMP supported by SACC 2.3.2.5.1
+7 ;
EN ; entry point
+1 NEW COUNT,ECDFN,ECD,PROCOST
+2 ;144 If exporting, already killed
IF '$GET(ECXPORT)
KILL ^TMP($JOB)
+3 SET COUNT=0
+4 SET ECD=ECSD1
SET ECED=ECED+.3
+5 DO GETRECS
+6 QUIT
+7 ;
GETRECS ; get records that are over the threshold
+1 ;154,161,187 - Added Unit of Issue
NEW PDA,SUBDA,PROLB,PRO0,PROFORM,ECXTYPED,ECXFORM,PROUNT,PROUNTIS,PROUNTFN
+2 NEW DIC,DR,DA,DIQ
+3 ;161
SET QFLG=0
SET ECXLNE=1
SET ECXED1=ECED
+4 SET PDA=ECSD1
+5 FOR
SET PDA=$ORDER(^RMPR(660,"CT",PDA))
if (PDA>ECXED1)!('PDA)!(QFLG=1)
QUIT
Begin DoDot:1
+6 SET SUBDA=0
+7 FOR
SET SUBDA=$ORDER(^RMPR(660,"CT",PDA,SUBDA))
if ('SUBDA)!(QFLG=1)
QUIT
Begin DoDot:2
+8 if '$DATA(^RMPR(660,SUBDA,0))
QUIT
+9 SET PRO0=^RMPR(660,SUBDA,0)
+10 SET PROLB=$GET(^RMPR(660,SUBDA,"LB"))
+11 KILL ECXP
SET DIC="^RMPR(660,"
SET DR=".02;11"
SET DA=SUBDA
SET DIQ(0)="EI"
+12 SET DIQ="ECXP"
DO EN^DIQ1
+13 SET ECXDFN=$GET(ECXP(660,SUBDA,.02,"I"))
+14 ;154
SET (ECXFORM,PROFORM)=$GET(ECXP(660,SUBDA,11,"E"))_U_$GET(ECXP(660,SUBDA,11,"I"))
+15 if '$$PATDEM^ECXUTL2(ECXDFN,PDA)
QUIT
+16 if '$$NTEG^ECXPRO1(ECXDFN,.ECXLNE,SUBDA,PRO0,PROLB,ECINST,PROFORM)
QUIT
+17 ;Set tran type description based on tran type
SET ECXTYPED=$SELECT(ECXTYPE="I":"INITIAL ISSUE",ECXTYPE="R":"REPLACE",ECXTYPE="S":"SPARE",ECXTYPE="X":"REPAIR",ECXTYPE=5:"RENTAL",1:"")
+18 SET PROCOST=$PIECE(PRO0,U,16)
+19 if PROFORM["-3"
SET PROCOST=$PIECE(PROLB,U,9)
+20 ;S:($P(PROFORM,U,2)=11)!($P(PROFORM,U,2)=12) PROCOST=0 ;154 Allow cost for inventory and stock items to come through
+21 if PROCOST=""
SET PROCOST=0
+22 SET PROCOST=(PROCOST+.5)\1
+23 if PROCOST>999999
SET PROCOST=999999
+24 ;187 Add Unit Of Issue
IF PROCOST>ECTHLD
Begin DoDot:3
+25 ;187 Unit IEN
SET PROUNT=$PIECE(PRO0,U,8)
+26 ;187
SET PROUNIT=$$GETUNIT(PROUNT)
+27 ;187
SET PROUNTIS=$PIECE(PROUNIT,U)
SET PROUNTFN=$PIECE(PROUNIT,U,2)
+28 ;187
IF PROUNTIS'=""
SET ECXPROUN(PROUNTIS)=PROUNTFN
End DoDot:3
DO FILE
End DoDot:2
End DoDot:1
+29 QUIT
FILE ; put records in temp file to print later
+1 NEW OK,PROPAT,PRONAME,PROSSN,CPTCODE,ECXFEKEY,PROQTY
+2 ;187
NEW STR
+3 SET OK=$$PAT^ECXUTL3(ECXDFN,$PIECE(ECD,"."),"1;",.PROPAT)
+4 IF 'OK
QUIT
+5 SET PRONAME=PROPAT("NAME")
+6 SET PROSSN=PROPAT("SSN")
+7 SET PRODAY=$EXTRACT(PDA,4,5)_"/"_$EXTRACT(PDA,6,7)_"/"_$EXTRACT(PDA,2,3)
+8 ;149 use PSAS HCPCS instead of HCPCS code
SET CPTCODE=$EXTRACT(ECXPHCPC,1,5)
+9 IF PROFORM["-3"
FOR ECXLAB="LAB","ORD"
DO FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB,ECXNPPDC)
+10 IF PROFORM'["-3"
SET ECXLAB="NONL"
DO FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB,ECXNPPDC)
+11 SET PROQTY=$PIECE(PRO0,U,7)
+12 if (+PROQTY=0)
SET PROQTY=1
+13 ;144,149,187 Change Quantity width from 8 to 4
SET PROQTY=$SELECT('$GET(ECXPORT):$$RJ^XLFSTR(PROQTY,4),1:PROQTY)
+14 ;187 Begins : Add Code Description, Unit of Issue and Re-arange the columns
+15 ;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:"")_$FN(PROCOST,",",2)_U_ECXTYPE_U_ECXTYPED ;144,149,154,161
+16 ;144,149,154,161,187
SET STR=PRONAME_U_PROSSN_U_PRODAY_U_$PIECE(ECXFORM,U,2)_$SELECT($GET(ECXPORT):(U_$PIECE(ECXFORM,U)),1:"")_U_ECXFEKEY_U_ECXPHCPC_U_ECXPHCPD_U_ECXTYPE_U_ECXTYPED_U_PROQTY_U_PROUNTIS_$SELECT($GET(ECXPORT):(U_PROUNTFN),1:"")_U
+17 ;144,149,154,161,187
SET STR=STR_$SELECT('$GET(ECXPORT):"$",1:"")_$FNUMBER(PROCOST,",",2)
+18 SET ^TMP($JOB,ECXFEKEY,-PROQTY,SUBDA,PROSSN)=STR
+19 ;187 Ends
+20 SET COUNT=COUNT+1
+21 IF COUNT#100=0
IF $$S^ZTLOAD
SET (ZTSTOP,ECXERR)=1
+22 QUIT
+23 ;
GETUNIT(UNTIEN) ;187 Get Unit of Issue
+1 NEW UNTNAME,UNTFNAME,UNTARR
+2 NEW DIC,DA,DR,DIC
+3 IF UNTIEN=""
QUIT ""
+4 SET DA=UNTIEN
SET DIC="^PRCD(420.5,"
SET DR=".01;1"
SET DIQ(0)="EI"
SET DIQ="UNTARR"
KILL UNTARR
DO EN^DIQ1
+5 ;187 Unit of Issue
SET UNTNAME=$GET(UNTARR(420.5,UNTIEN,.01,"E"))
+6 ;187 Unit of Issue (full name)
SET UNTFNAME=$GET(UNTARR(420.5,UNTIEN,1,"E"))
+7 QUIT UNTNAME_U_UNTFNAME
+8 ;
EXIT SET ECXERR=1
QUIT
