- 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 Apr 23, 2025@18:06:46 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
