ECXPRO1 ;ALB/GTS - Prosthetics Extract for DSS (Continued) ;2/27/19 15:47
;;3.0;DSS EXTRACTS;**9,11,13,15,21,24,33,37,39,100,105,112,132,154,174,187**;Dec 22, 1997;Build 163
;
; Reference to ^RMPR(600, in ICR #2528
; Reference to EN^DIQ1 in ICR #10015
; Reference to GET1^DIQ in ICD #2056
; Reference to ^DIC(4 in ICR #10090
; Reference to ^RMPR(661.1 in ICR #5754
; Reference to ^TMP supported by SACC 2.3.2.5.1
; Reference to $$CPT^ICPTCOD in ICR # 1995
; Reference to ^ICPT( in ICR #5408
;
NTEG(ECXDFN,ECXLNE,ECXPIEN,ECXN0,ECXNLB,ECINST,ECXFORM) ;** Check for required fields
; Input
; ECXDFN - ien in file #2
; ECXLNE - line number variable (passed by reference)
; ECXPIEN - IEN for the Prosthetics record
; ECXN0 - zero node of the Prosthetics record
; ECXNLB - LB node of the Prosthetics record
; ECINST - station number being extracted
; ECXFORM - Form Requested On
; Output (to be KILLed by calling routine)
; ^TMP("ECX-PRO EXC",$J) - Array for the exception message
; ECXLNE - The number of the next line in the msg
; ECXSTAT2 - Patient Station Number
; ECXDATE - Delivery Date of Prosthesis
; ECXTYPE - Type of Transaction work performed
; ECXSRCE - Source of prosthesis
; ECXHCPCS - CPT/HCPCS code for prosthesis
; ECXRQST - Requesting Station
; ECXRCST - Receiving Station
; ECXPHCPC - PSAS HCPCS code; if 'unknown', then use CPT/HCPCS code
; ECXPHPCD - PSAS HCPCS Code Description ;187
; ECXNPPDC - NPPD code for repairs or new issues
; ECXHCPCD - PSAS HCPCS/CPT HCPCS Description
; Output (KILLed by NTEG)
; ECXMISS - 1 indicates missing information
; ECXGOOD - 0 indicates record should not be extracted
;
N ECXGOOD,ECXMISS
N CPTSTR ;187
S (ECXRCST,ECXRQST,ECXNPPDC)="",ECXGOOD=1,ECXSTAT2=$P(ECXN0,U,10)
I ECXSTAT2]"" D
.K ECXDIC
.S DA=ECXSTAT2,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
.D EN^DIQ1 S ECXSTAT2=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
.S:(ECINST'=$E(ECXSTAT2,1,3)) ECXGOOD=0 ;*Screen for incorrect Station
;
;** Screen out records
S:($P(ECXN0,U,17)'="") ECXGOOD=0 ;*SHIP/DEL is not NULL
S:($P(ECXN0,U,26)'="") ECXGOOD=0 ;*PICKUP/DEL is not NULL
S:(+($P($G(^RMPR(660,ECXPIEN,"AM")),U,2))=1) ECXGOOD=0 ;*NO ADMIN CT=1
S:(($P(ECXN0,U,15))'="") ECXGOOD=0 ;*HISTORICAL DATA is not NULL
;
S ECXDATE=$P(ECXN0,U,12),ECXTYPE=$P(ECXN0,U,4),ECXSRCE=$P(ECXN0,U,14)
S ECXHCPCS=$P($G(^ICPT(+$P(ECXN0,U,22),0)),U,1),ECXCMOD=""
S ECXHCPCS=$$CPT^ECXUTL3(ECXHCPCS,ECXCMOD)
;get psas hcpcs code from file #661.1
S ECXPHCPC=$P($G(^RMPR(660,ECXPIEN,1)),U,4) D
.;get nppd code for repairs and new issues 10 characters in length.
.I "X5"[ECXTYPE S ECXNPPDC=$TR($$GET1^DIQ(661.1,ECXPHCPC_",",5)," ","_")
.I "ISR"[ECXTYPE S ECXNPPDC=$TR($$GET1^DIQ(661.1,ECXPHCPC_",",6)," ","_")
.I +ECXPHCPC D ;187 Get PSAS HCPC Code and Code Description
..S DA=ECXPHCPC,DIC="^RMPR(661.1,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;.02"
..D EN^DIQ1
..S ECXPHCPC=ECXDIC(661.1,DA,.01,"I") ;Code
..S ECXPHCPD=ECXDIC(661.1,DA,.02,"I") ;Description
..K DIC,DIQ,DA,DR,ECXDIC
.I ECXPHCPC="UNKNOWN" S ECXPHCPC=$E(ECXHCPCS,1,5) D
.. S ECXPHPCD=$P($$CPT^ICPTCOD(ECXPHCPC,""),U,3) ; 187 Get the versioned shortname
;
;* Get Requesting Station Number
I ECXFORM["-3" D
.S ECXRQST=$P(ECXNLB,U,1)
.I ECXRQST]"" D
..S DA=ECXRQST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
..D EN^DIQ1 S ECXRQST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
S:(ECXFORM'["-3") ECXRQST=""
;
;* Screen out records
S:(+$P(ECXFORM,U,2)=13) ECXGOOD=0 ;*FORM REQUESTED ON = 13
;
;* Get Receiving Station Number
I ECXFORM["-3" D
.S ECXRCST=$P(ECXNLB,U,4)
.I ECXRCST]"" D
..S DA=ECXRCST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
..D EN^DIQ1 S ECXRCST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
S:(ECXFORM'["-3") ECXRCST=""
;
;** Check for integrity and set up the problem variable if right DIV
I ECXGOOD D CHK
Q ECXGOOD
;
CHK ;*Check variables
; Input
; Variables set in and Output from NTEG^ECXPRO1
; Output
; ^TMP("ECX-PRO EXC",$J, - Global of records with integrity problems
;
S ECXMISS=""
I ECXSTAT2']"" S ECXMISS=ECXMISS_"1"
S ECXMISS=ECXMISS_U
I ECXDFN=0 S ECXMISS=ECXMISS_"1"
S ECXMISS=ECXMISS_U
;I ECXSSN']"" S ECXMISS=ECXMISS_"1"
S ECXMISS=ECXMISS_U
;I ECXNA=" " S ECXMISS=ECXMISS_"1"
S ECXMISS=ECXMISS_U
I ECXDATE']"" S ECXMISS=ECXMISS_"1"
S ECXMISS=ECXMISS_U
I ECXTYPE']"" S ECXMISS=ECXMISS_"1"
S ECXMISS=ECXMISS_U
I ECXSRCE']"" S ECXMISS=ECXMISS_"1"
S ECXMISS=ECXMISS_U
I ECXHCPCS']"" S ECXGOOD=0 ;S ECXMISS=ECXMISS_"1" ;*HCPCS code check disabled
S ECXMISS=ECXMISS_U
I ECXFORM["-3" D
.I ECXRQST']"" S ECXMISS=ECXMISS_"1"
S ECXMISS=ECXMISS_U
I ECXFORM']"" S ECXMISS=ECXMISS_"1"
S ECXMISS=ECXMISS_U
I ECXFORM["-3" D
.I ECXRCST']"" S ECXMISS=ECXMISS_"1"
I ECXMISS'="^^^^^^^^^^" D
.S ECXGOOD=0
.D ECXMISLN^ECXPRO2(ECXMISS,.ECXLNE,ECXPIEN)
Q
;
PROSINFO(ECXDA,ECXLB,ECX0,ECXFORM) ;*Get Prosthetics Information
;
; Input
; ECDA - The IEN for the Prosthetics record
; ECX0 - The zero node of the Prosthetics record
; ECXLB - The LB node of the Prosthetics record
; ECXFORM - The Form Requested On (to determine Lab transactions)
;
; Output (to be KILLed by calling routine)
; ECXCTAMT - The Cost of Transaction
; ECXLLC - The Lab Labor Cost
; ECXLMC - The Lab Material Cost
; ECXGRPR - The AMIS Grouper number
; ECXBILST - The Billing Status
; ECXQTY - The Quantity
; ECXNCOST - The New Cost of Transaction, implemented in Patch 174
; ECXNLLC - The New Lab Labor Cost, implemented in Patch 174
; ECXNLMC - The New Lab Material Cost, implemented in Patch 174
;
N MAXAMT ;174
S MAXAMT=$S(ECXLOGIC>2019:999999999,1:999999) ;174
S (ECXLLC,ECXLMC,ECXCTAMT)="",ECXBILST=$P($G(^RMPR(660,ECXDA,"AM")),U,3)
S ECXQTY=$P(ECX0,U,7)
S:(+ECXQTY=0) ECXQTY=1
;
;- Set Quantity field to 8 chars (right-justified & padded w/zeros)
S ECXQTY=$$RJ^XLFSTR(ECXQTY,8,0)
S ECXGRPR=$P($G(^RMPR(660,ECXDA,"AMS")),U,1),ECXCTAMT=$P(ECX0,U,16)
I ECXFORM["-3" D
.S ECXCTAMT=$P(ECXLB,U,9),ECXLLC=$P(ECXLB,U,7),ECXLMC=$P(ECXLB,U,8)
;
;- If Stock Issue or Inventory Issue, Cost of Transaction=0
;I $P(ECXFORM,U,2)=11!($P(ECXFORM,U,2)=12) S ECXCTAMT=0 ;154 Commented out line to allow costs to come through for inventory or stock issue
S:ECXCTAMT="" ECXCTAMT=0 S:ECXCTAMT>MAXAMT ECXCTAMT=MAXAMT
S:ECXLLC="" ECXLLC=0 S:ECXLLC>MAXAMT ECXLLC=MAXAMT
S:ECXLMC="" ECXLMC=0 S:ECXLMC>MAXAMT ECXLMC=MAXAMT
;
;- Round to next dollar amount
I (ECXCTAMT#1)>.50 S ECXCTAMT=(ECXCTAMT+1)\1
I (ECXLLC#1)>.50 S ECXLLC=(ECXLLC+1)\1
I (ECXLMC#1)>.50 S ECXLMC=(ECXLMC+1)\1
;
I ECXLOGIC>2019 S ECXNCOST=ECXCTAMT S ECXNLLC=ECXLLC S ECXNLMC=ECXLMC ;174
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXPRO1 7200 printed Dec 13, 2024@01:53:31 Page 2
ECXPRO1 ;ALB/GTS - Prosthetics Extract for DSS (Continued) ;2/27/19 15:47
+1 ;;3.0;DSS EXTRACTS;**9,11,13,15,21,24,33,37,39,100,105,112,132,154,174,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 GET1^DIQ in ICD #2056
+6 ; Reference to ^DIC(4 in ICR #10090
+7 ; Reference to ^RMPR(661.1 in ICR #5754
+8 ; Reference to ^TMP supported by SACC 2.3.2.5.1
+9 ; Reference to $$CPT^ICPTCOD in ICR # 1995
+10 ; Reference to ^ICPT( in ICR #5408
+11 ;
NTEG(ECXDFN,ECXLNE,ECXPIEN,ECXN0,ECXNLB,ECINST,ECXFORM) ;** Check for required fields
+1 ; Input
+2 ; ECXDFN - ien in file #2
+3 ; ECXLNE - line number variable (passed by reference)
+4 ; ECXPIEN - IEN for the Prosthetics record
+5 ; ECXN0 - zero node of the Prosthetics record
+6 ; ECXNLB - LB node of the Prosthetics record
+7 ; ECINST - station number being extracted
+8 ; ECXFORM - Form Requested On
+9 ; Output (to be KILLed by calling routine)
+10 ; ^TMP("ECX-PRO EXC",$J) - Array for the exception message
+11 ; ECXLNE - The number of the next line in the msg
+12 ; ECXSTAT2 - Patient Station Number
+13 ; ECXDATE - Delivery Date of Prosthesis
+14 ; ECXTYPE - Type of Transaction work performed
+15 ; ECXSRCE - Source of prosthesis
+16 ; ECXHCPCS - CPT/HCPCS code for prosthesis
+17 ; ECXRQST - Requesting Station
+18 ; ECXRCST - Receiving Station
+19 ; ECXPHCPC - PSAS HCPCS code; if 'unknown', then use CPT/HCPCS code
+20 ; ECXPHPCD - PSAS HCPCS Code Description ;187
+21 ; ECXNPPDC - NPPD code for repairs or new issues
+22 ; ECXHCPCD - PSAS HCPCS/CPT HCPCS Description
+23 ; Output (KILLed by NTEG)
+24 ; ECXMISS - 1 indicates missing information
+25 ; ECXGOOD - 0 indicates record should not be extracted
+26 ;
+27 NEW ECXGOOD,ECXMISS
+28 ;187
NEW CPTSTR
+29 SET (ECXRCST,ECXRQST,ECXNPPDC)=""
SET ECXGOOD=1
SET ECXSTAT2=$PIECE(ECXN0,U,10)
+30 IF ECXSTAT2]""
Begin DoDot:1
+31 KILL ECXDIC
+32 SET DA=ECXSTAT2
SET DIC="^DIC(4,"
SET DIQ(0)="I"
SET DIQ="ECXDIC"
SET DR=".01;99"
+33 DO EN^DIQ1
SET ECXSTAT2=$GET(ECXDIC(4,DA,99,"I"))
KILL DIC,DIQ,DA,DR,ECXDIC
+34 ;*Screen for incorrect Station
if (ECINST'=$EXTRACT(ECXSTAT2,1,3))
SET ECXGOOD=0
End DoDot:1
+35 ;
+36 ;** Screen out records
+37 ;*SHIP/DEL is not NULL
if ($PIECE(ECXN0,U,17)'="")
SET ECXGOOD=0
+38 ;*PICKUP/DEL is not NULL
if ($PIECE(ECXN0,U,26)'="")
SET ECXGOOD=0
+39 ;*NO ADMIN CT=1
if (+($PIECE($GET(^RMPR(660,ECXPIEN,"AM")),U,2))=1)
SET ECXGOOD=0
+40 ;*HISTORICAL DATA is not NULL
if (($PIECE(ECXN0,U,15))'="")
SET ECXGOOD=0
+41 ;
+42 SET ECXDATE=$PIECE(ECXN0,U,12)
SET ECXTYPE=$PIECE(ECXN0,U,4)
SET ECXSRCE=$PIECE(ECXN0,U,14)
+43 SET ECXHCPCS=$PIECE($GET(^ICPT(+$PIECE(ECXN0,U,22),0)),U,1)
SET ECXCMOD=""
+44 SET ECXHCPCS=$$CPT^ECXUTL3(ECXHCPCS,ECXCMOD)
+45 ;get psas hcpcs code from file #661.1
+46 SET ECXPHCPC=$PIECE($GET(^RMPR(660,ECXPIEN,1)),U,4)
Begin DoDot:1
+47 ;get nppd code for repairs and new issues 10 characters in length.
+48 IF "X5"[ECXTYPE
SET ECXNPPDC=$TRANSLATE($$GET1^DIQ(661.1,ECXPHCPC_",",5)," ","_")
+49 IF "ISR"[ECXTYPE
SET ECXNPPDC=$TRANSLATE($$GET1^DIQ(661.1,ECXPHCPC_",",6)," ","_")
+50 ;187 Get PSAS HCPC Code and Code Description
IF +ECXPHCPC
Begin DoDot:2
+51 SET DA=ECXPHCPC
SET DIC="^RMPR(661.1,"
SET DIQ(0)="I"
SET DIQ="ECXDIC"
SET DR=".01;.02"
+52 DO EN^DIQ1
+53 ;Code
SET ECXPHCPC=ECXDIC(661.1,DA,.01,"I")
+54 ;Description
SET ECXPHCPD=ECXDIC(661.1,DA,.02,"I")
+55 KILL DIC,DIQ,DA,DR,ECXDIC
End DoDot:2
+56 IF ECXPHCPC="UNKNOWN"
SET ECXPHCPC=$EXTRACT(ECXHCPCS,1,5)
Begin DoDot:2
+57 ; 187 Get the versioned shortname
SET ECXPHPCD=$PIECE($$CPT^ICPTCOD(ECXPHCPC,""),U,3)
End DoDot:2
End DoDot:1
+58 ;
+59 ;* Get Requesting Station Number
+60 IF ECXFORM["-3"
Begin DoDot:1
+61 SET ECXRQST=$PIECE(ECXNLB,U,1)
+62 IF ECXRQST]""
Begin DoDot:2
+63 SET DA=ECXRQST
SET DIC="^DIC(4,"
SET DIQ(0)="I"
SET DIQ="ECXDIC"
SET DR=".01;99"
+64 DO EN^DIQ1
SET ECXRQST=$GET(ECXDIC(4,DA,99,"I"))
KILL DIC,DIQ,DA,DR,ECXDIC
End DoDot:2
End DoDot:1
+65 if (ECXFORM'["-3")
SET ECXRQST=""
+66 ;
+67 ;* Screen out records
+68 ;*FORM REQUESTED ON = 13
if (+$PIECE(ECXFORM,U,2)=13)
SET ECXGOOD=0
+69 ;
+70 ;* Get Receiving Station Number
+71 IF ECXFORM["-3"
Begin DoDot:1
+72 SET ECXRCST=$PIECE(ECXNLB,U,4)
+73 IF ECXRCST]""
Begin DoDot:2
+74 SET DA=ECXRCST
SET DIC="^DIC(4,"
SET DIQ(0)="I"
SET DIQ="ECXDIC"
SET DR=".01;99"
+75 DO EN^DIQ1
SET ECXRCST=$GET(ECXDIC(4,DA,99,"I"))
KILL DIC,DIQ,DA,DR,ECXDIC
End DoDot:2
End DoDot:1
+76 if (ECXFORM'["-3")
SET ECXRCST=""
+77 ;
+78 ;** Check for integrity and set up the problem variable if right DIV
+79 IF ECXGOOD
DO CHK
+80 QUIT ECXGOOD
+81 ;
CHK ;*Check variables
+1 ; Input
+2 ; Variables set in and Output from NTEG^ECXPRO1
+3 ; Output
+4 ; ^TMP("ECX-PRO EXC",$J, - Global of records with integrity problems
+5 ;
+6 SET ECXMISS=""
+7 IF ECXSTAT2']""
SET ECXMISS=ECXMISS_"1"
+8 SET ECXMISS=ECXMISS_U
+9 IF ECXDFN=0
SET ECXMISS=ECXMISS_"1"
+10 SET ECXMISS=ECXMISS_U
+11 ;I ECXSSN']"" S ECXMISS=ECXMISS_"1"
+12 SET ECXMISS=ECXMISS_U
+13 ;I ECXNA=" " S ECXMISS=ECXMISS_"1"
+14 SET ECXMISS=ECXMISS_U
+15 IF ECXDATE']""
SET ECXMISS=ECXMISS_"1"
+16 SET ECXMISS=ECXMISS_U
+17 IF ECXTYPE']""
SET ECXMISS=ECXMISS_"1"
+18 SET ECXMISS=ECXMISS_U
+19 IF ECXSRCE']""
SET ECXMISS=ECXMISS_"1"
+20 SET ECXMISS=ECXMISS_U
+21 ;S ECXMISS=ECXMISS_"1" ;*HCPCS code check disabled
IF ECXHCPCS']""
SET ECXGOOD=0
+22 SET ECXMISS=ECXMISS_U
+23 IF ECXFORM["-3"
Begin DoDot:1
+24 IF ECXRQST']""
SET ECXMISS=ECXMISS_"1"
End DoDot:1
+25 SET ECXMISS=ECXMISS_U
+26 IF ECXFORM']""
SET ECXMISS=ECXMISS_"1"
+27 SET ECXMISS=ECXMISS_U
+28 IF ECXFORM["-3"
Begin DoDot:1
+29 IF ECXRCST']""
SET ECXMISS=ECXMISS_"1"
End DoDot:1
+30 IF ECXMISS'="^^^^^^^^^^"
Begin DoDot:1
+31 SET ECXGOOD=0
+32 DO ECXMISLN^ECXPRO2(ECXMISS,.ECXLNE,ECXPIEN)
End DoDot:1
+33 QUIT
+34 ;
PROSINFO(ECXDA,ECXLB,ECX0,ECXFORM) ;*Get Prosthetics Information
+1 ;
+2 ; Input
+3 ; ECDA - The IEN for the Prosthetics record
+4 ; ECX0 - The zero node of the Prosthetics record
+5 ; ECXLB - The LB node of the Prosthetics record
+6 ; ECXFORM - The Form Requested On (to determine Lab transactions)
+7 ;
+8 ; Output (to be KILLed by calling routine)
+9 ; ECXCTAMT - The Cost of Transaction
+10 ; ECXLLC - The Lab Labor Cost
+11 ; ECXLMC - The Lab Material Cost
+12 ; ECXGRPR - The AMIS Grouper number
+13 ; ECXBILST - The Billing Status
+14 ; ECXQTY - The Quantity
+15 ; ECXNCOST - The New Cost of Transaction, implemented in Patch 174
+16 ; ECXNLLC - The New Lab Labor Cost, implemented in Patch 174
+17 ; ECXNLMC - The New Lab Material Cost, implemented in Patch 174
+18 ;
+19 ;174
NEW MAXAMT
+20 ;174
SET MAXAMT=$SELECT(ECXLOGIC>2019:999999999,1:999999)
+21 SET (ECXLLC,ECXLMC,ECXCTAMT)=""
SET ECXBILST=$PIECE($GET(^RMPR(660,ECXDA,"AM")),U,3)
+22 SET ECXQTY=$PIECE(ECX0,U,7)
+23 if (+ECXQTY=0)
SET ECXQTY=1
+24 ;
+25 ;- Set Quantity field to 8 chars (right-justified & padded w/zeros)
+26 SET ECXQTY=$$RJ^XLFSTR(ECXQTY,8,0)
+27 SET ECXGRPR=$PIECE($GET(^RMPR(660,ECXDA,"AMS")),U,1)
SET ECXCTAMT=$PIECE(ECX0,U,16)
+28 IF ECXFORM["-3"
Begin DoDot:1
+29 SET ECXCTAMT=$PIECE(ECXLB,U,9)
SET ECXLLC=$PIECE(ECXLB,U,7)
SET ECXLMC=$PIECE(ECXLB,U,8)
End DoDot:1
+30 ;
+31 ;- If Stock Issue or Inventory Issue, Cost of Transaction=0
+32 ;I $P(ECXFORM,U,2)=11!($P(ECXFORM,U,2)=12) S ECXCTAMT=0 ;154 Commented out line to allow costs to come through for inventory or stock issue
+33 if ECXCTAMT=""
SET ECXCTAMT=0
if ECXCTAMT>MAXAMT
SET ECXCTAMT=MAXAMT
+34 if ECXLLC=""
SET ECXLLC=0
if ECXLLC>MAXAMT
SET ECXLLC=MAXAMT
+35 if ECXLMC=""
SET ECXLMC=0
if ECXLMC>MAXAMT
SET ECXLMC=MAXAMT
+36 ;
+37 ;- Round to next dollar amount
+38 IF (ECXCTAMT#1)>.50
SET ECXCTAMT=(ECXCTAMT+1)\1
+39 IF (ECXLLC#1)>.50
SET ECXLLC=(ECXLLC+1)\1
+40 IF (ECXLMC#1)>.50
SET ECXLMC=(ECXLMC+1)\1
+41 ;
+42 ;174
IF ECXLOGIC>2019
SET ECXNCOST=ECXCTAMT
SET ECXNLLC=ECXLLC
SET ECXNLMC=ECXLMC
+43 QUIT
