ECXCBFK ;ALB/DAN - Cost by feeder key ;6/20/19 08:43
;;3.0;DSS EXTRACTS;**174**;Dec 22, 1997;Build 33
;
N QFLG,ECXOPT,EXTRACT,FY,FP
S QFLG=0
D BEGIN
D SELECT Q:QFLG
K ^TMP($J,"ECXCBFK"),^TMP($J,"ECXPORT")
D GET
D DISPLAY K ^TMP($J,"ECXCBFK"),^TMP($J,"ECXPORT")
Q
;
BEGIN ;Give report details
W @IOF
W !,"This report prints costs by feeder key for a selected extract",!,"from PRE, UDP, IVP or BCM."
W !!,"**This report is export only so after making your selections, the",!,"results will be displayed to the screen for capture.",!
Q
;
SELECT ;Select extract system and extract number
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DIC,STDT
S DIR(0)="SO^1:PRE;2:IVP;3:UDP;4:BCM",DIR("A")="Select extract type" D ^DIR K DIR I $G(DIRUT) S QFLG=1 Q
S ECXOPT=Y(0)
S DIC=727,DIC(0)="AEMQ",DIC("S")="I $P($G(^(""HEAD"")),U)=ECXOPT&($P($G(^(0)),U,6)>0)"
S DIC("W")="W:$G(DZ)[""?"" ?12,""Date range: "",$$FMTE^XLFDT($P(^(0),U,4),""2Z""),"" to "",$$FMTE^XLFDT($P(^(0),U,5),""2Z""),?48,""Records Extracted: "",$S($P(^(0),U,6)'="""":$P(^(0),U,6),1:""Inc."")"
D ^DIC
S EXTRACT=+Y I EXTRACT'>0 S QFLG=1 Q
S STDT=$P(^ECX(727,EXTRACT,0),U,4) ;Get extract start date
S FY=$$FISCAL^ECXUTL1(STDT) ;Get FY from start date
S FP=$S($E(STDT,4,5)>9:$E(STDT,4,5)-9,1:$E(STDT,4,5)+3) ;Set Fiscal Period based on month
Q
;
GET ;Find data
N FK,NODE,FILE,FILEAC,SEQ,VAP,NDC,STA,NODE0,NODE1,NODE2,NODE3,TYPE,DESC
W !!,"Gathering data..."
S FILE=$S(ECXOPT="PRE":"^ECX(727.81,",ECXOPT="UDP":"^ECX(727.809,",ECXOPT="IVP":"^ECX(727.819,",1:"^ECX(727.833,")
S FILEAC=FILE_"""AC"""_","_EXTRACT_")"
S SEQ=0 F S SEQ=$O(@FILEAC@(SEQ)) Q:'+SEQ D
.I SEQ#10000=0 W "."
.S NODE0=@(FILE_SEQ_",0)") ;Set 0 node
.S:ECXOPT="PRE" NODE2=@(FILE_SEQ_",2)") ;If PRE get 2 node
.S FK=$S(ECXOPT="PRE":$P(NODE0,U,28),ECXOPT="UDP":$P(NODE0,U,18),ECXOPT="IVP":$P(NODE0,U,19),1:"BCM") ;BCM doesn't have a feeder key, need to build it
.I FK="BCM" D ;Build feeder key for BCM
..S NODE1=$G(^ECX(727.833,SEQ,1)),NODE2=$G(^(2)),NODE3=$G(^(3))
..S VAP=$$RJ^XLFSTR($P(NODE2,U,6),5,0) ;Set 5 digit VA Product code, padded with zeroes in needed
..S NDC=$TR($P(NODE2,U,7),"-","") ;Remove hyphens from NDC (if it exists)
..S FK=VAP_$S(NDC="":"000000000000",1:NDC) ;Pad with zeroes if missing
.S UNIT=$$INFO(FK,"UNIT",ECXOPT) ;Get units
.S DESC=$$INFO(FK,"DESC",ECXOPT) ;Get description
.S STA=$$GET1^DIQ($S(ECXOPT="PRE":727.81,ECXOPT="UDP":727.809,ECXOPT="IVP":727.819,1:727.833),SEQ_",","PRODUCTION DIVISION CODE") S:STA="" STA="Unresolved Station"
.S $P(^TMP($J,"ECXCBFK",STA,FK,UNIT),U)=+$P($G(^TMP($J,"ECXCBFK",STA,FK,UNIT)),U)+1 ;Increment counter
.I ECXOPT="BCM" D Q
..S $P(^TMP($J,"ECXCBFK",STA,FK,UNIT),U,2)=$P(^TMP($J,"ECXCBFK",STA,FK,UNIT),U,2)+$P(NODE1,U,7) ;add units
..S TYPE=$P(NODE1,U,9)
..S $P(^TMP($J,"ECXCBFK",STA,FK,UNIT),U,3)=$P(^TMP($J,"ECXCBFK",STA,FK,UNIT),U,3)+$S(TYPE="D":$P(NODE3,U,14),TYPE="A":$P(NODE3,U,12),TYPE="S":$P(NODE3,U,13),1:0) ;Get cost, use 0 if not found
..S ^TMP($J,"ECXCBFK",STA,FK,UNIT,"DESC")=DESC
.S $P(^TMP($J,"ECXCBFK",STA,FK,UNIT),U,2)=$P(^TMP($J,"ECXCBFK",STA,FK,UNIT),U,2)+$S(ECXOPT="PRE":$P(NODE0,U,17),ECXOPT="UDP":$P(NODE0,U,11),1:$P(NODE0,U,20)) ;Count quantity/doses given
.S $P(^TMP($J,"ECXCBFK",STA,FK,UNIT),U,3)=$P(^TMP($J,"ECXCBFK",STA,FK,UNIT),U,3)+$S(ECXOPT="PRE":$P(NODE0,U,18),ECXOPT="UDP":$P(NODE0,U,14),1:$P(NODE0,U,13)) ;Get cost of medication
.S ^TMP($J,"ECXCBFK",STA,FK,UNIT,"DESC")=DESC
Q
;
INFO(FK,FIELD,OPTION) ;Get information from drug identified in feeder key
N DRUG,UNITS,NDC,DIC,X,D,VALUE
I FK["LCD" D Q VALUE ;If no VA product, use Drug file IEN from feeder key
.S DRUG=+$P(FK,"LCD",2) S VALUE=$$VALUE(DRUG,FIELD,FK)
.Q
I FK["LCL" D Q VALUE
.S DRUG=+$P(FK,"LCL",2) S VALUE=$$VALUE(DRUG,FIELD,FK)
.Q
S NDC=$S(OPTION="IVP":$TR($P(NODE0,U,16),"-",""),OPTION="UDP":$TR($P(NODE0,U,17),"-",""),OPTION="PRE":"PRE",1:$E(FK,6,30))
I OPTION'="PRE" D
.S:NDC="000000000000" NDC="" ;Set NDC to blank if all zeroes to avoid incorrect lookup on drugs with all zeroes as NDC
.S DIC=50,DIC(0)="M",D="NDC^C" ;Use NDC and C xrefs for lookup
.D MIX^PSSDI(50,"ECX",.DIC,D,NDC)
.I Y'>0,NDC'="" S NDC=$$RJ^XLFSTR(NDC,12,0) D MIX^PSSDI(50,"ECX",.DIC,D,NDC) ;If drug not found, try padding NDC with leading zeroes
.S DRUG=+Y S:DRUG'>0 DRUG=0
I OPTION="PRE" D
.S DIC=52,DIC(0)="",X=$P(NODE2,U,8) D ^DIC
.S DRUG=$$GET1^DIQ(52,+Y,6,"I")
S VALUE=$$VALUE(DRUG,FIELD,FK)
Q VALUE
;
DISPLAY ;Put results in exportable format
N STA,FK,UNI,CNT,DATA,DESC
S ^TMP($J,"ECXPORT",0)="STATION^FY^FP^DESCRIPTION^FEEDER KEY^UNIT^ENCOUNTERS^"_$S(ECXOPT="BCM":"COMPONENT DOSES GIVEN",ECXOPT="IVP":"TOTAL DOSES",1:"QUANTITY")_"^TOTAL COST^UNIT COST"
S CNT=1
S STA="" F S STA=$O(^TMP($J,"ECXCBFK",STA)) Q:STA="" S FK="" F S FK=$O(^TMP($J,"ECXCBFK",STA,FK)) Q:FK="" S UNIT="" F S UNIT=$O(^TMP($J,"ECXCBFK",STA,FK,UNIT)) Q:UNIT="" D
.S DATA=^TMP($J,"ECXCBFK",STA,FK,UNIT)
.S DESC=^TMP($J,"ECXCBFK",STA,FK,UNIT,"DESC")
.S ^TMP($J,"ECXPORT",CNT)=STA_U_FY_U_FP_U_DESC_U_FK_U_UNIT_U_$P(DATA,U)_U_+$P(DATA,U,2)_U_$FN(+$P(DATA,U,3),",",2)_U_$S(+$P(DATA,U,2)=0:"--",1:$FN($P(DATA,U,3)/$P(DATA,U,2),",",4))
.S CNT=CNT+1
D EXPDISP^ECXUTL1
Q
;
VALUE(DRUG,FIELD,FK) ;Get unit or name from drug
S VALUE=$$GET1^DIQ(50,DRUG_",",$S(FIELD="UNIT":14.5,1:.01)) S:VALUE="" VALUE="Not Found"
I VALUE="Not Found",FIELD="UNIT" S VALUE=$$GET1^DIQ(50,DRUG_",",902) S:VALUE="" VALUE="Not Found"
I VALUE="Not Found" D
.S DRUG=+$E(FK,1,5)
.I DRUG S VALUE=$$GET1^DIQ(50.68,DRUG_",",$S(FIELD="UNIT":8,1:.01)) S:VALUE="" VALUE="Not Found"
.I DRUG,FIELD="UNIT",VALUE="Not Found" S VALUE=$$GET1^DIQ(50.68,DRUG_",",3) S:VALUE="" VALUE="Not Found" ;if unit not found in 'unit' field then look in 'VA dispense unit' field
Q VALUE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXCBFK 5850 printed Dec 13, 2024@01:52:18 Page 2
ECXCBFK ;ALB/DAN - Cost by feeder key ;6/20/19 08:43
+1 ;;3.0;DSS EXTRACTS;**174**;Dec 22, 1997;Build 33
+2 ;
+3 NEW QFLG,ECXOPT,EXTRACT,FY,FP
+4 SET QFLG=0
+5 DO BEGIN
+6 DO SELECT
if QFLG
QUIT
+7 KILL ^TMP($JOB,"ECXCBFK"),^TMP($JOB,"ECXPORT")
+8 DO GET
+9 DO DISPLAY
KILL ^TMP($JOB,"ECXCBFK"),^TMP($JOB,"ECXPORT")
+10 QUIT
+11 ;
BEGIN ;Give report details
+1 WRITE @IOF
+2 WRITE !,"This report prints costs by feeder key for a selected extract",!,"from PRE, UDP, IVP or BCM."
+3 WRITE !!,"**This report is export only so after making your selections, the",!,"results will be displayed to the screen for capture.",!
+4 QUIT
+5 ;
SELECT ;Select extract system and extract number
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DIC,STDT
+2 SET DIR(0)="SO^1:PRE;2:IVP;3:UDP;4:BCM"
SET DIR("A")="Select extract type"
DO ^DIR
KILL DIR
IF $GET(DIRUT)
SET QFLG=1
QUIT
+3 SET ECXOPT=Y(0)
+4 SET DIC=727
SET DIC(0)="AEMQ"
SET DIC("S")="I $P($G(^(""HEAD"")),U)=ECXOPT&($P($G(^(0)),U,6)>0)"
+5 SET DIC("W")="W:$G(DZ)[""?"" ?12,""Date range: "",$$FMTE^XLFDT($P(^(0),U,4),""2Z""),"" to "",$$FMTE^XLFDT($P(^(0),U,5),""2Z""),?48,""Records Extracted: "",$S($P(^(0),U,6)'="""":$P(^(0),U,6),1:""Inc."")"
+6 DO ^DIC
+7 SET EXTRACT=+Y
IF EXTRACT'>0
SET QFLG=1
QUIT
+8 ;Get extract start date
SET STDT=$PIECE(^ECX(727,EXTRACT,0),U,4)
+9 ;Get FY from start date
SET FY=$$FISCAL^ECXUTL1(STDT)
+10 ;Set Fiscal Period based on month
SET FP=$SELECT($EXTRACT(STDT,4,5)>9:$EXTRACT(STDT,4,5)-9,1:$EXTRACT(STDT,4,5)+3)
+11 QUIT
+12 ;
GET ;Find data
+1 NEW FK,NODE,FILE,FILEAC,SEQ,VAP,NDC,STA,NODE0,NODE1,NODE2,NODE3,TYPE,DESC
+2 WRITE !!,"Gathering data..."
+3 SET FILE=$SELECT(ECXOPT="PRE":"^ECX(727.81,",ECXOPT="UDP":"^ECX(727.809,",ECXOPT="IVP":"^ECX(727.819,",1:"^ECX(727.833,")
+4 SET FILEAC=FILE_"""AC"""_","_EXTRACT_")"
+5 SET SEQ=0
FOR
SET SEQ=$ORDER(@FILEAC@(SEQ))
if '+SEQ
QUIT
Begin DoDot:1
+6 IF SEQ#10000=0
WRITE "."
+7 ;Set 0 node
SET NODE0=@(FILE_SEQ_",0)")
+8 ;If PRE get 2 node
if ECXOPT="PRE"
SET NODE2=@(FILE_SEQ_",2)")
+9 ;BCM doesn't have a feeder key, need to build it
SET FK=$SELECT(ECXOPT="PRE":$PIECE(NODE0,U,28),ECXOPT="UDP":$PIECE(NODE0,U,18),ECXOPT="IVP":$PIECE(NODE0,U,19),1:"BCM")
+10 ;Build feeder key for BCM
IF FK="BCM"
Begin DoDot:2
+11 SET NODE1=$GET(^ECX(727.833,SEQ,1))
SET NODE2=$GET(^(2))
SET NODE3=$GET(^(3))
+12 ;Set 5 digit VA Product code, padded with zeroes in needed
SET VAP=$$RJ^XLFSTR($PIECE(NODE2,U,6),5,0)
+13 ;Remove hyphens from NDC (if it exists)
SET NDC=$TRANSLATE($PIECE(NODE2,U,7),"-","")
+14 ;Pad with zeroes if missing
SET FK=VAP_$SELECT(NDC="":"000000000000",1:NDC)
End DoDot:2
+15 ;Get units
SET UNIT=$$INFO(FK,"UNIT",ECXOPT)
+16 ;Get description
SET DESC=$$INFO(FK,"DESC",ECXOPT)
+17 SET STA=$$GET1^DIQ($SELECT(ECXOPT="PRE":727.81,ECXOPT="UDP":727.809,ECXOPT="IVP":727.819,1:727.833),SEQ_",","PRODUCTION DIVISION CODE")
if STA=""
SET STA="Unresolved Station"
+18 ;Increment counter
SET $PIECE(^TMP($JOB,"ECXCBFK",STA,FK,UNIT),U)=+$PIECE($GET(^TMP($JOB,"ECXCBFK",STA,FK,UNIT)),U)+1
+19 IF ECXOPT="BCM"
Begin DoDot:2
+20 ;add units
SET $PIECE(^TMP($JOB,"ECXCBFK",STA,FK,UNIT),U,2)=$PIECE(^TMP($JOB,"ECXCBFK",STA,FK,UNIT),U,2)+$PIECE(NODE1,U,7)
+21 SET TYPE=$PIECE(NODE1,U,9)
+22 ;Get cost, use 0 if not found
SET $PIECE(^TMP($JOB,"ECXCBFK",STA,FK,UNIT),U,3)=$PIECE(^TMP($JOB,"ECXCBFK",STA,FK,UNIT),U,3)+$SELECT(TYPE="D":$PIECE(NODE3,U,14),TYPE="A":$PIECE(NODE3,U,12),TYPE="S":$PIECE(NODE3,U,13),1:0)
+23 SET ^TMP($JOB,"ECXCBFK",STA,FK,UNIT,"DESC")=DESC
End DoDot:2
QUIT
+24 ;Count quantity/doses given
SET $PIECE(^TMP($JOB,"ECXCBFK",STA,FK,UNIT),U,2)=$PIECE(^TMP($JOB,"ECXCBFK",STA,FK,UNIT),U,2)+$SELECT(ECXOPT="PRE":$PIECE(NODE0,U,17),ECXOPT="UDP":$PIECE(NODE0,U,11),1:$PIECE(NODE0,U,20))
+25 ;Get cost of medication
SET $PIECE(^TMP($JOB,"ECXCBFK",STA,FK,UNIT),U,3)=$PIECE(^TMP($JOB,"ECXCBFK",STA,FK,UNIT),U,3)+$SELECT(ECXOPT="PRE":$PIECE(NODE0,U,18),ECXOPT="UDP":$PIECE(NODE0,U,14),1:$PIECE(NODE0,U,13))
+26 SET ^TMP($JOB,"ECXCBFK",STA,FK,UNIT,"DESC")=DESC
End DoDot:1
+27 QUIT
+28 ;
INFO(FK,FIELD,OPTION) ;Get information from drug identified in feeder key
+1 NEW DRUG,UNITS,NDC,DIC,X,D,VALUE
+2 ;If no VA product, use Drug file IEN from feeder key
IF FK["LCD"
Begin DoDot:1
+3 SET DRUG=+$PIECE(FK,"LCD",2)
SET VALUE=$$VALUE(DRUG,FIELD,FK)
+4 QUIT
End DoDot:1
QUIT VALUE
+5 IF FK["LCL"
Begin DoDot:1
+6 SET DRUG=+$PIECE(FK,"LCL",2)
SET VALUE=$$VALUE(DRUG,FIELD,FK)
+7 QUIT
End DoDot:1
QUIT VALUE
+8 SET NDC=$SELECT(OPTION="IVP":$TRANSLATE($PIECE(NODE0,U,16),"-",""),OPTION="UDP":$TRANSLATE($PIECE(NODE0,U,17),"-",""),OPTION="PRE":"PRE",1:$EXTRACT(FK,6,30))
+9 IF OPTION'="PRE"
Begin DoDot:1
+10 ;Set NDC to blank if all zeroes to avoid incorrect lookup on drugs with all zeroes as NDC
if NDC="000000000000"
SET NDC=""
+11 ;Use NDC and C xrefs for lookup
SET DIC=50
SET DIC(0)="M"
SET D="NDC^C"
+12 DO MIX^PSSDI(50,"ECX",.DIC,D,NDC)
+13 ;If drug not found, try padding NDC with leading zeroes
IF Y'>0
IF NDC'=""
SET NDC=$$RJ^XLFSTR(NDC,12,0)
DO MIX^PSSDI(50,"ECX",.DIC,D,NDC)
+14 SET DRUG=+Y
if DRUG'>0
SET DRUG=0
End DoDot:1
+15 IF OPTION="PRE"
Begin DoDot:1
+16 SET DIC=52
SET DIC(0)=""
SET X=$PIECE(NODE2,U,8)
DO ^DIC
+17 SET DRUG=$$GET1^DIQ(52,+Y,6,"I")
End DoDot:1
+18 SET VALUE=$$VALUE(DRUG,FIELD,FK)
+19 QUIT VALUE
+20 ;
DISPLAY ;Put results in exportable format
+1 NEW STA,FK,UNI,CNT,DATA,DESC
+2 SET ^TMP($JOB,"ECXPORT",0)="STATION^FY^FP^DESCRIPTION^FEEDER KEY^UNIT^ENCOUNTERS^"_$SELECT(ECXOPT="BCM":"COMPONENT DOSES GIVEN",ECXOPT="IVP":"TOTAL DOSES",1:"QUANTITY")_"^TOTAL COST^UNIT COST"
+3 SET CNT=1
+4 SET STA=""
FOR
SET STA=$ORDER(^TMP($JOB,"ECXCBFK",STA))
if STA=""
QUIT
SET FK=""
FOR
SET FK=$ORDER(^TMP($JOB,"ECXCBFK",STA,FK))
if FK=""
QUIT
SET UNIT=""
FOR
SET UNIT=$ORDER(^TMP($JOB,"ECXCBFK",STA,FK,UNIT))
if UNIT=""
QUIT
Begin DoDot:1
+5 SET DATA=^TMP($JOB,"ECXCBFK",STA,FK,UNIT)
+6 SET DESC=^TMP($JOB,"ECXCBFK",STA,FK,UNIT,"DESC")
+7 SET ^TMP($JOB,"ECXPORT",CNT)=STA_U_FY_U_FP_U_DESC_U_FK_U_UNIT_U_$PIECE(DATA,U)_U_+$PIECE(DATA,U,2)_U_$FNUMBER(+$PIECE(DATA,U,3),",",2)_U_$SELECT(+$PIECE(DATA,U,2)=0:"--",1:$FNUMBER($PIECE(DATA,U,3)/$PIECE(DATA,U,2),",",4))
+8 SET CNT=CNT+1
End DoDot:1
+9 DO EXPDISP^ECXUTL1
+10 QUIT
+11 ;
VALUE(DRUG,FIELD,FK) ;Get unit or name from drug
+1 SET VALUE=$$GET1^DIQ(50,DRUG_",",$SELECT(FIELD="UNIT":14.5,1:.01))
if VALUE=""
SET VALUE="Not Found"
+2 IF VALUE="Not Found"
IF FIELD="UNIT"
SET VALUE=$$GET1^DIQ(50,DRUG_",",902)
if VALUE=""
SET VALUE="Not Found"
+3 IF VALUE="Not Found"
Begin DoDot:1
+4 SET DRUG=+$EXTRACT(FK,1,5)
+5 IF DRUG
SET VALUE=$$GET1^DIQ(50.68,DRUG_",",$SELECT(FIELD="UNIT":8,1:.01))
if VALUE=""
SET VALUE="Not Found"
+6 ;if unit not found in 'unit' field then look in 'VA dispense unit' field
IF DRUG
IF FIELD="UNIT"
IF VALUE="Not Found"
SET VALUE=$$GET1^DIQ(50.68,DRUG_",",3)
if VALUE=""
SET VALUE="Not Found"
End DoDot:1
+7 QUIT VALUE
