ORINDRP ;BIR/MA - Indication Usage Report ;Mar 30, 2022@08:09:34
;;3.0;ORDER ENTRY/RESULTS REPORTING;**405**;Dec 17, 1997;Build 211
;
Q
EN ;
N SEL,IYR,IDT,IQRT,CQRT,SDT,EDT,LATE,CMT,X,Y,SQRT,SYR,BMT,EMT,MEND,SDT,EDT,%DT
D:'$D(DT) DT^DICRW
S LATE=$E(DT,1,5)_"00"
S IYR="",IYR=$$INSTALDT^XPDUTL("PSO*7.0*441",.IYR)
I IYR S IDT=$P($O(IYR(0)),".")
E S IDT=DT
S IYR=$E(IDT,1,3)+1700
S IQRT=+$E(IDT,4,5),IQRT=$P("1^1^1^2^2^2^3^3^3^4^4^4","^",IQRT)
S CQRT=+$E(DT,4,5),CQRT=$P("1^1^1^2^2^2^3^3^3^4^4^4","^",CQRT)
S CMT=$E(DT,1,3)+1700
W !!
K DIR,DIRUT,DUOUT,DTOUT
S DIR("A")="Select (M)ONTHLY, (Q)UARTERLY or (F)LEXIBLE REPORT: "
S DIR(0)="SA^M:MONTHLY;Q:QUARTERLY;F:FLEXIBLE REPORT"
D ^DIR K DIR I $D(DIRUT) K DIRUT,DUOUT,DTOUT Q
S SEL=Y
D @(Y_"EN")
Q
QEN ;
S BMT="01^04^07^10"
S EMT="03^06^09^12"
W !! S DIR("A")="Select Calendar Quarter",DIR(0)="SBO^1:Quarter 1 (Jan-Mar);2:Quarter 2 (Apr-Jun);3:Quarter 3 (Jul-Sep);4:Quarter 4 (Oct-Dec)"
D ^DIR K DIR G:$D(DIRUT) EN
S SQRT=Y
S MEND=$S("23"[SQRT:30,1:31)
YR ;
S (SYR,X)=$E(DT,1,3)+1700
W !,"Select Calendar Year: ",X,"// " R X:DTIME
I '$T!(X="^") G QEN
S:X="" X=SYR
I X'?4N W $C(7),!,"Enter a four digit calendar year (e.g. "_SYR_")",! G YR
I X<IYR W $C(7),!!," No Data exist prior to "_$E(IDT,4,5)_"/"_IYR,! G YR
I X>SYR W $C(7),!!," Year cannot be in the future",! G YR
I SQRT<IQRT,X=IYR W $C(7),!!," No Data exist prior to Quarter "_IQRT_" of "_IYR,! G YR
I SQRT>CQRT,X=SYR W $C(7),!!," Quarter cannot be in the future",! G YR
S SYR=X-1700
S BMT=$P(BMT,U,SQRT),EMT=$P(EMT,U,SQRT)
S SDT=SYR_BMT_"00"
S EDT=SYR_EMT_"99"
G SOI
;
MEN ;
W !!!,"**** Date Range Selection ****"
SDT ;
W ! S %DT(0)=-DT,%DT="APEM",%DT("A")="Beginning MONTH/YEAR : " D ^%DT K %DT G:"^"[X!(Y<0) EN
I $E(Y,1,5)<$E(IDT,1,5) W $C(7),!!," No Data exist prior to "_$E(IDT,4,5)_"/"_IYR,! G SDT
S SDT=Y
EDT S %DT(0)=SDT W ! S %DT="APEM",%DT("A")=" Ending MONTH/YEAR : " D ^%DT K %DT
G:"^"[X!(Y<0) EN G:(+$E(Y,6,7)'=0)!(+$E(Y,4,5)=0) EDT I Y>LATE W $C(7),!!," End of month cannot be in the future" G EDT
S EDT=$E(Y,1,5)_"99"
S MEND=$P("31^"_($$LEAP($E(EDT,1,3))+28)_"^31^30^31^30^31^31^30^31^30^31",U,$E(EDT,4,5))
G SOI
;
FEN ;
SPR W ! S %DT(0)=IDT,%DT("A")="STARTING DATE: ",%DT="EXAP" D ^%DT G:"^"[X EN G:Y<0 SPR S (%DT(0),SDT)=Y
EPR W ! S %DT(0)=-DT,%DT("A")="ENDING DATE: ",%DT="EXAP" D ^%DT G:"^"[X EN G:Y<0 EPR S EDT=Y_".9999999" K %DT
SOI ;Allow selection of all/single/multiple Orderable item
K DIR,DIRUT,DUOUT,DTOUT N ORALL,ORSEL
S DIR(0)="Y",DIR("A")="Do you want ALL Orderable Items to appear on this report",DIR("B")="Y"
S DIR("?")="Enter Yes to search for all Orderable Items. Enter No to select individual Orderable Item"
D ^DIR K DIR G:$G(DIRUT) EN
S ORALL=Y G:Y DQ
F D Q:$D(DIRUT)
.S DIR(0)="PO^101.43:AEQM",DIR("S")="I $P($G(^ORD(101.43,+Y,0)),""^"",2)[""PS"""
.S DIR("A")="Select "_$S($D(ORSEL):"another ",1:"")_"Orderable Item"
.S DIR("?")="Select Orderable Items to appear on report. Return when finished, ^ to stop processing"
.D ^DIR Q:$D(DIRUT) S ORSEL(+Y)=""
K DIR I $D(ORSEL)'=10!($D(DUOUT))!($D(DTOUT)) G EN
K DIRUT,DUOUT,DTOUT
DQ ;build and print
W ! K %ZIS,IOP,POP S %ZIS="QM" D ^%ZIS G:POP EN
I $D(IO("Q")) D Q
. K IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK,ZTRTN,ZTDESC
. N G S ZTRTN="RPT^ORINDRP",ZTDESC="Indication Usage Report"
. F G="SDT","EDT","MEND","ORALL","SQRT" S:$D(@G) ZTSAVE(G)=""
. S:$D(ORSEL) ZTSAVE("ORSEL(")=""
. D ^%ZTLOAD W:$D(ZTSK) !,"Report is Queued to print !!" K ZTSK
RPT ;
U IO
N ORDT,PKG,PG,ORQ,I,J,K,ORIEN
S ORDT=SDT K ^TMP($J,"ORIND")
F S ORDT=$O(^OR(100,"AF",ORDT)) Q:'ORDT!(ORDT>EDT) S ORIEN="" F S ORIEN=$O(^OR(100,"AF",ORDT,ORIEN)) Q:'ORIEN D:$D(^OR(100,ORIEN,4.5,"ID","INDICATION"))
. Q:+$P($G(^OR(100,ORIEN,3)),"^",11)'=0 ;quit if order type not standard
. S PKG=$$NMSP^ORCD($P($G(^OR(100,ORIEN,0)),"^",14)) Q:PKG'="PS"
. S PKG=$P($G(^ORD(100.98,$P(^OR(100,ORIEN,0),U,11),0)),U,3) Q:PKG="SPLY"!(PKG="NV RX")
. Q:$O(^OR(100,ORIEN,4.5,"ID","ORDERABLE",99),-1)>1 ;quit if multiple orderable item
. I $O(^OR(100,"AF",ORDT,ORIEN,0))=1,$D(^OR(100,ORIEN,8,1,0)) D CHECK
I '$D(^TMP($J,"ORIND")) W !!,"There is no data for the criteria you selected.",! G END
S:+$E(SDT,6,7)=0 SDT=$E(SDT,1,5)_"01"
S:+$E(EDT,6,7)=99 EDT=$E(EDT,1,5)_MEND
S:$L(EDT,".")>1 EDT=$P(EDT,".")
D PRINT
END ;
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
K ^TMP($J,"ORIND")
Q
;
CHECK ;If order matches requirements then save
N OI,OINM,ORUI,ORSI,POI,ND
S PKG=$S(PKG="O RX":"OP",PKG="UD RX"!(PKG="C RX"):"IP",1:"IV")
S J=$O(^OR(100,ORIEN,4.5,"ID","INDICATION",0)) Q:'J Q:$P($G(^OR(100,ORIEN,4.5,J,0)),U,3)'=1 S ORUI=$G(^(1))
S OI=0 S J=$O(^OR(100,ORIEN,4.5,"ID","ORDERABLE",0)) Q:'J I $P($G(^OR(100,ORIEN,4.5,J,0)),U,3)=1 S OI=+$G(^(1)) D:OI
. I 'ORALL,'$D(ORSEL(OI)) Q
. S ND=$G(^ORD(101.43,OI,0)),POI=+$P(ND,U,2),OINM=$E($P(ND,U),1,30) Q:'POI
. D INDCATN^PSS50P7(POI,"OROI")
. D GIND
. S ^TMP($J,"ORIND",OINM,PKG,ORSI)=$G(^TMP($J,"ORIND",OINM,PKG,ORSI))+1
. S ^TMP($J,"ORIND",OINM,PKG,ORSI,ORUI)=$G(^TMP($J,"ORIND",OINM,PKG,ORSI,ORUI))+1
. S ^TMP($J,"ORIND",OINM,PKG)=$G(^TMP($J,"ORIND",OINM,PKG))+1
. S ^TMP($J,"ORIND",OINM)=POI
Q
;
GIND ;
I '$O(^TMP($J,"OROI",0)) S ORSI="FT" Q
S (I,K)=0 F S I=$O(^TMP($J,"OROI",I)) Q:'I!(K) S ND=^(I) D
. I $P(ND,U)=ORUI,$P(ND,U,2) S ORSI="MCI",K=1 Q
. I $P(ND,U)=ORUI S ORSI="OTH",K=1 Q
. S ORSI="FT"
K ^TMP($J,"OROI")
Q
;
PRINT ;
N ORQ,TXT,ICT,CT,L,M,N,O,ARR,POI S ORQ=0
D HDR
S I="" F S I=$O(^TMP($J,"ORIND",I)) Q:I=""!(ORQ) S POI=+$G(^TMP($J,"ORIND",I)) W !,I_"("_POI_")" D
. D SETAR
. F J="OP","IP","IV" I $D(^TMP($J,"ORIND",I,J)) S CT=^(J) D D PL Q:ORQ
.. S TXT=" "_$S(J="OP":"Outpatient",J="IP":"Unit Dose",1:J) D
... K ARR F K="MCI","OTH","FT" I $D(^TMP($J,"ORIND",I,J,K)) S ICT=^(K) D
.... S $E(TXT,$S(K="MCI":31,K="OTH":43,1:55))=ICT_" ("_$J(ICT/CT*100,2,0)_"%)"
.... S L="" F S L=$O(^TMP($J,"ORIND",I,J,K,L)) Q:L="" D
..... S ARR("A"_$S(K="MCI":"1",K="OTH":"2",1:"3"),L)=^TMP($J,"ORIND",I,J,K,L)
..... I $D(NOIND(K,L)) K NOIND(K,L)
. I ORQ K NOIND Q
. I $D(NOIND) D NUIND K NOIND
. W !
Q
;
SETAR ;
K NOIND N ZI,ZND
Q:'POI
D INDCATN^PSS50P7(POI,"OROI")
Q:'$O(^TMP($J,"OROI",0))
S ZI=0 F S ZI=$O(^TMP($J,"OROI",ZI)) Q:'ZI S ZND=^(ZI) D
. I $P(ZND,U)]"" S NOIND($S($P(ZND,U,2):"MCI",1:"OTH"),$P(ZND,U))=""
K ^TMP($J,"OROI")
Q
;
NUIND ;
I $Y>(IOSL-4) D HDR Q:ORQ
W !," These Indications were not used: "
N ZI,ZY,ZJ
S ZI="" F S ZI=$O(NOIND(ZI)) Q:ZI="" D
. S ZJ="" W !,?5,$S(ZI="MCI":"Most Common",1:"Other Indic")
. S ZY=0 F S ZJ=$O(NOIND(ZI,ZJ)) Q:ZJ="" S ZY=ZY+1 D
.. I ZY=1 W ?18," - "_ZJ
.. E W !,?18," - "_ZJ
Q
;
PL ;
I $Y>(IOSL-4) D HDR Q:ORQ
W !,TXT,?68,CT
S M="" F S M=$O(ARR(M)) Q:M=""!(ORQ) W !,?5,$S(M="A1":"Most Common",M="A2":"Other Indic",1:"Free Text")_": " D
. S N="",O=0 F S O=O+1,N=$O(ARR(M,N)) Q:N="" D Q:ORQ
.. W:O>1 ! W ?18,N,?68,$G(ARR(M,N))
.. D:$Y>(IOSL-4) HDR
Q
;
HDR ;
S PG=$G(PG)+1
I PG>1,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR I 'Y S ORQ=1 Q
W @IOF,"CPRS Indication Usage Report For "_$S('ORALL:"Selected",1:"All")_" Orderable Items "_$$FMTE^XLFDT(DT)_" PAGE "_PG
W !,"Selected Date Range: ",$$FMTE^XLFDT(SDT)," to ",$$FMTE^XLFDT(EDT)_$S($G(SQRT):" (Quarter "_SQRT_")",1:"")
W !,"Orderable Item Most Common Other Free Text Total"
W !," Indications Indications Indications"
W !,"-------------------------------------------------------------------------"
Q
;
LEAP(%) ;Check if a Leap year
S:%<1700 %=%+1700
Q (%#4=0)&'(%#100=0)!(%#400=0)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORINDRP 7787 printed Apr 09, 2024@21:28:46 Page 2
ORINDRP ;BIR/MA - Indication Usage Report ;Mar 30, 2022@08:09:34
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**405**;Dec 17, 1997;Build 211
+2 ;
+3 QUIT
EN ;
+1 NEW SEL,IYR,IDT,IQRT,CQRT,SDT,EDT,LATE,CMT,X,Y,SQRT,SYR,BMT,EMT,MEND,SDT,EDT,%DT
+2 if '$DATA(DT)
DO DT^DICRW
+3 SET LATE=$EXTRACT(DT,1,5)_"00"
+4 SET IYR=""
SET IYR=$$INSTALDT^XPDUTL("PSO*7.0*441",.IYR)
+5 IF IYR
SET IDT=$PIECE($ORDER(IYR(0)),".")
+6 IF '$TEST
SET IDT=DT
+7 SET IYR=$EXTRACT(IDT,1,3)+1700
+8 SET IQRT=+$EXTRACT(IDT,4,5)
SET IQRT=$PIECE("1^1^1^2^2^2^3^3^3^4^4^4","^",IQRT)
+9 SET CQRT=+$EXTRACT(DT,4,5)
SET CQRT=$PIECE("1^1^1^2^2^2^3^3^3^4^4^4","^",CQRT)
+10 SET CMT=$EXTRACT(DT,1,3)+1700
+11 WRITE !!
+12 KILL DIR,DIRUT,DUOUT,DTOUT
+13 SET DIR("A")="Select (M)ONTHLY, (Q)UARTERLY or (F)LEXIBLE REPORT: "
+14 SET DIR(0)="SA^M:MONTHLY;Q:QUARTERLY;F:FLEXIBLE REPORT"
+15 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
KILL DIRUT,DUOUT,DTOUT
QUIT
+16 SET SEL=Y
+17 DO @(Y_"EN")
+18 QUIT
QEN ;
+1 SET BMT="01^04^07^10"
+2 SET EMT="03^06^09^12"
+3 WRITE !!
SET DIR("A")="Select Calendar Quarter"
SET DIR(0)="SBO^1:Quarter 1 (Jan-Mar);2:Quarter 2 (Apr-Jun);3:Quarter 3 (Jul-Sep);4:Quarter 4 (Oct-Dec)"
+4 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EN
+5 SET SQRT=Y
+6 SET MEND=$SELECT("23"[SQRT:30,1:31)
YR ;
+1 SET (SYR,X)=$EXTRACT(DT,1,3)+1700
+2 WRITE !,"Select Calendar Year: ",X,"// "
READ X:DTIME
+3 IF '$TEST!(X="^")
GOTO QEN
+4 if X=""
SET X=SYR
+5 IF X'?4N
WRITE $CHAR(7),!,"Enter a four digit calendar year (e.g. "_SYR_")",!
GOTO YR
+6 IF X<IYR
WRITE $CHAR(7),!!," No Data exist prior to "_$EXTRACT(IDT,4,5)_"/"_IYR,!
GOTO YR
+7 IF X>SYR
WRITE $CHAR(7),!!," Year cannot be in the future",!
GOTO YR
+8 IF SQRT<IQRT
IF X=IYR
WRITE $CHAR(7),!!," No Data exist prior to Quarter "_IQRT_" of "_IYR,!
GOTO YR
+9 IF SQRT>CQRT
IF X=SYR
WRITE $CHAR(7),!!," Quarter cannot be in the future",!
GOTO YR
+10 SET SYR=X-1700
+11 SET BMT=$PIECE(BMT,U,SQRT)
SET EMT=$PIECE(EMT,U,SQRT)
+12 SET SDT=SYR_BMT_"00"
+13 SET EDT=SYR_EMT_"99"
+14 GOTO SOI
+15 ;
MEN ;
+1 WRITE !!!,"**** Date Range Selection ****"
SDT ;
+1 WRITE !
SET %DT(0)=-DT
SET %DT="APEM"
SET %DT("A")="Beginning MONTH/YEAR : "
DO ^%DT
KILL %DT
if "^"[X!(Y<0)
GOTO EN
+2 IF $EXTRACT(Y,1,5)<$EXTRACT(IDT,1,5)
WRITE $CHAR(7),!!," No Data exist prior to "_$EXTRACT(IDT,4,5)_"/"_IYR,!
GOTO SDT
+3 SET SDT=Y
EDT SET %DT(0)=SDT
WRITE !
SET %DT="APEM"
SET %DT("A")=" Ending MONTH/YEAR : "
DO ^%DT
KILL %DT
+1 if "^"[X!(Y<0)
GOTO EN
if (+$EXTRACT(Y,6,7)'=0)!(+$EXTRACT(Y,4,5)=0)
GOTO EDT
IF Y>LATE
WRITE $CHAR(7),!!," End of month cannot be in the future"
GOTO EDT
+2 SET EDT=$EXTRACT(Y,1,5)_"99"
+3 SET MEND=$PIECE("31^"_($$LEAP($EXTRACT(EDT,1,3))+28)_"^31^30^31^30^31^31^30^31^30^31",U,$EXTRACT(EDT,4,5))
+4 GOTO SOI
+5 ;
FEN ;
SPR WRITE !
SET %DT(0)=IDT
SET %DT("A")="STARTING DATE: "
SET %DT="EXAP"
DO ^%DT
if "^"[X
GOTO EN
if Y<0
GOTO SPR
SET (%DT(0),SDT)=Y
EPR WRITE !
SET %DT(0)=-DT
SET %DT("A")="ENDING DATE: "
SET %DT="EXAP"
DO ^%DT
if "^"[X
GOTO EN
if Y<0
GOTO EPR
SET EDT=Y_".9999999"
KILL %DT
SOI ;Allow selection of all/single/multiple Orderable item
+1 KILL DIR,DIRUT,DUOUT,DTOUT
NEW ORALL,ORSEL
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want ALL Orderable Items to appear on this report"
SET DIR("B")="Y"
+3 SET DIR("?")="Enter Yes to search for all Orderable Items. Enter No to select individual Orderable Item"
+4 DO ^DIR
KILL DIR
if $GET(DIRUT)
GOTO EN
+5 SET ORALL=Y
if Y
GOTO DQ
+6 FOR
Begin DoDot:1
+7 SET DIR(0)="PO^101.43:AEQM"
SET DIR("S")="I $P($G(^ORD(101.43,+Y,0)),""^"",2)[""PS"""
+8 SET DIR("A")="Select "_$SELECT($DATA(ORSEL):"another ",1:"")_"Orderable Item"
+9 SET DIR("?")="Select Orderable Items to appear on report. Return when finished, ^ to stop processing"
+10 DO ^DIR
if $DATA(DIRUT)
QUIT
SET ORSEL(+Y)=""
End DoDot:1
if $DATA(DIRUT)
QUIT
+11 KILL DIR
IF $DATA(ORSEL)'=10!($DATA(DUOUT))!($DATA(DTOUT))
GOTO EN
+12 KILL DIRUT,DUOUT,DTOUT
DQ ;build and print
+1 WRITE !
KILL %ZIS,IOP,POP
SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO EN
+2 IF $DATA(IO("Q"))
Begin DoDot:1
+3 KILL IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK,ZTRTN,ZTDESC
+4 NEW G
SET ZTRTN="RPT^ORINDRP"
SET ZTDESC="Indication Usage Report"
+5 FOR G="SDT","EDT","MEND","ORALL","SQRT"
if $DATA(@G)
SET ZTSAVE(G)=""
+6 if $DATA(ORSEL)
SET ZTSAVE("ORSEL(")=""
+7 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Report is Queued to print !!"
KILL ZTSK
End DoDot:1
QUIT
RPT ;
+1 USE IO
+2 NEW ORDT,PKG,PG,ORQ,I,J,K,ORIEN
+3 SET ORDT=SDT
KILL ^TMP($JOB,"ORIND")
+4 FOR
SET ORDT=$ORDER(^OR(100,"AF",ORDT))
if 'ORDT!(ORDT>EDT)
QUIT
SET ORIEN=""
FOR
SET ORIEN=$ORDER(^OR(100,"AF",ORDT,ORIEN))
if 'ORIEN
QUIT
if $DATA(^OR(100,ORIEN,4.5,"ID","INDICATION"))
Begin DoDot:1
+5 ;quit if order type not standard
if +$PIECE($GET(^OR(100,ORIEN,3)),"^",11)'=0
QUIT
+6 SET PKG=$$NMSP^ORCD($PIECE($GET(^OR(100,ORIEN,0)),"^",14))
if PKG'="PS"
QUIT
+7 SET PKG=$PIECE($GET(^ORD(100.98,$PIECE(^OR(100,ORIEN,0),U,11),0)),U,3)
if PKG="SPLY"!(PKG="NV RX")
QUIT
+8 ;quit if multiple orderable item
if $ORDER(^OR(100,ORIEN,4.5,"ID","ORDERABLE",99),-1)>1
QUIT
+9 IF $ORDER(^OR(100,"AF",ORDT,ORIEN,0))=1
IF $DATA(^OR(100,ORIEN,8,1,0))
DO CHECK
End DoDot:1
+10 IF '$DATA(^TMP($JOB,"ORIND"))
WRITE !!,"There is no data for the criteria you selected.",!
GOTO END
+11 if +$EXTRACT(SDT,6,7)=0
SET SDT=$EXTRACT(SDT,1,5)_"01"
+12 if +$EXTRACT(EDT,6,7)=99
SET EDT=$EXTRACT(EDT,1,5)_MEND
+13 if $LENGTH(EDT,".")>1
SET EDT=$PIECE(EDT,".")
+14 DO PRINT
END ;
+1 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 KILL ^TMP($JOB,"ORIND")
+3 QUIT
+4 ;
CHECK ;If order matches requirements then save
+1 NEW OI,OINM,ORUI,ORSI,POI,ND
+2 SET PKG=$SELECT(PKG="O RX":"OP",PKG="UD RX"!(PKG="C RX"):"IP",1:"IV")
+3 SET J=$ORDER(^OR(100,ORIEN,4.5,"ID","INDICATION",0))
if 'J
QUIT
if $PIECE($GET(^OR(100,ORIEN,4.5,J,0)),U,3)'=1
QUIT
SET ORUI=$GET(^(1))
+4 SET OI=0
SET J=$ORDER(^OR(100,ORIEN,4.5,"ID","ORDERABLE",0))
if 'J
QUIT
IF $PIECE($GET(^OR(100,ORIEN,4.5,J,0)),U,3)=1
SET OI=+$GET(^(1))
if OI
Begin DoDot:1
+5 IF 'ORALL
IF '$DATA(ORSEL(OI))
QUIT
+6 SET ND=$GET(^ORD(101.43,OI,0))
SET POI=+$PIECE(ND,U,2)
SET OINM=$EXTRACT($PIECE(ND,U),1,30)
if 'POI
QUIT
+7 DO INDCATN^PSS50P7(POI,"OROI")
+8 DO GIND
+9 SET ^TMP($JOB,"ORIND",OINM,PKG,ORSI)=$GET(^TMP($JOB,"ORIND",OINM,PKG,ORSI))+1
+10 SET ^TMP($JOB,"ORIND",OINM,PKG,ORSI,ORUI)=$GET(^TMP($JOB,"ORIND",OINM,PKG,ORSI,ORUI))+1
+11 SET ^TMP($JOB,"ORIND",OINM,PKG)=$GET(^TMP($JOB,"ORIND",OINM,PKG))+1
+12 SET ^TMP($JOB,"ORIND",OINM)=POI
End DoDot:1
+13 QUIT
+14 ;
GIND ;
+1 IF '$ORDER(^TMP($JOB,"OROI",0))
SET ORSI="FT"
QUIT
+2 SET (I,K)=0
FOR
SET I=$ORDER(^TMP($JOB,"OROI",I))
if 'I!(K)
QUIT
SET ND=^(I)
Begin DoDot:1
+3 IF $PIECE(ND,U)=ORUI
IF $PIECE(ND,U,2)
SET ORSI="MCI"
SET K=1
QUIT
+4 IF $PIECE(ND,U)=ORUI
SET ORSI="OTH"
SET K=1
QUIT
+5 SET ORSI="FT"
End DoDot:1
+6 KILL ^TMP($JOB,"OROI")
+7 QUIT
+8 ;
PRINT ;
+1 NEW ORQ,TXT,ICT,CT,L,M,N,O,ARR,POI
SET ORQ=0
+2 DO HDR
+3 SET I=""
FOR
SET I=$ORDER(^TMP($JOB,"ORIND",I))
if I=""!(ORQ)
QUIT
SET POI=+$GET(^TMP($JOB,"ORIND",I))
WRITE !,I_"("_POI_")"
Begin DoDot:1
+4 DO SETAR
+5 FOR J="OP","IP","IV"
IF $DATA(^TMP($JOB,"ORIND",I,J))
SET CT=^(J)
Begin DoDot:2
+6 SET TXT=" "_$SELECT(J="OP":"Outpatient",J="IP":"Unit Dose",1:J)
Begin DoDot:3
+7 KILL ARR
FOR K="MCI","OTH","FT"
IF $DATA(^TMP($JOB,"ORIND",I,J,K))
SET ICT=^(K)
Begin DoDot:4
+8 SET $EXTRACT(TXT,$SELECT(K="MCI":31,K="OTH":43,1:55))=ICT_" ("_$JUSTIFY(ICT/CT*100,2,0)_"%)"
+9 SET L=""
FOR
SET L=$ORDER(^TMP($JOB,"ORIND",I,J,K,L))
if L=""
QUIT
Begin DoDot:5
+10 SET ARR("A"_$SELECT(K="MCI":"1",K="OTH":"2",1:"3"),L)=^TMP($JOB,"ORIND",I,J,K,L)
+11 IF $DATA(NOIND(K,L))
KILL NOIND(K,L)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
DO PL
if ORQ
QUIT
+12 IF ORQ
KILL NOIND
QUIT
+13 IF $DATA(NOIND)
DO NUIND
KILL NOIND
+14 WRITE !
End DoDot:1
+15 QUIT
+16 ;
SETAR ;
+1 KILL NOIND
NEW ZI,ZND
+2 if 'POI
QUIT
+3 DO INDCATN^PSS50P7(POI,"OROI")
+4 if '$ORDER(^TMP($JOB,"OROI",0))
QUIT
+5 SET ZI=0
FOR
SET ZI=$ORDER(^TMP($JOB,"OROI",ZI))
if 'ZI
QUIT
SET ZND=^(ZI)
Begin DoDot:1
+6 IF $PIECE(ZND,U)]""
SET NOIND($SELECT($PIECE(ZND,U,2):"MCI",1:"OTH"),$PIECE(ZND,U))=""
End DoDot:1
+7 KILL ^TMP($JOB,"OROI")
+8 QUIT
+9 ;
NUIND ;
+1 IF $Y>(IOSL-4)
DO HDR
if ORQ
QUIT
+2 WRITE !," These Indications were not used: "
+3 NEW ZI,ZY,ZJ
+4 SET ZI=""
FOR
SET ZI=$ORDER(NOIND(ZI))
if ZI=""
QUIT
Begin DoDot:1
+5 SET ZJ=""
WRITE !,?5,$SELECT(ZI="MCI":"Most Common",1:"Other Indic")
+6 SET ZY=0
FOR
SET ZJ=$ORDER(NOIND(ZI,ZJ))
if ZJ=""
QUIT
SET ZY=ZY+1
Begin DoDot:2
+7 IF ZY=1
WRITE ?18," - "_ZJ
+8 IF '$TEST
WRITE !,?18," - "_ZJ
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
PL ;
+1 IF $Y>(IOSL-4)
DO HDR
if ORQ
QUIT
+2 WRITE !,TXT,?68,CT
+3 SET M=""
FOR
SET M=$ORDER(ARR(M))
if M=""!(ORQ)
QUIT
WRITE !,?5,$SELECT(M="A1":"Most Common",M="A2":"Other Indic",1:"Free Text")_": "
Begin DoDot:1
+4 SET N=""
SET O=0
FOR
SET O=O+1
SET N=$ORDER(ARR(M,N))
if N=""
QUIT
Begin DoDot:2
+5 if O>1
WRITE !
WRITE ?18,N,?68,$GET(ARR(M,N))
+6 if $Y>(IOSL-4)
DO HDR
End DoDot:2
if ORQ
QUIT
End DoDot:1
+7 QUIT
+8 ;
HDR ;
+1 SET PG=$GET(PG)+1
+2 IF PG>1
IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET ORQ=1
QUIT
+3 WRITE @IOF,"CPRS Indication Usage Report For "_$SELECT('ORALL:"Selected",1:"All")_" Orderable Items "_$$FMTE^XLFDT(DT)_" PAGE "_PG
+4 WRITE !,"Selected Date Range: ",$$FMTE^XLFDT(SDT)," to ",$$FMTE^XLFDT(EDT)_$SELECT($GET(SQRT):" (Quarter "_SQRT_")",1:"")
+5 WRITE !,"Orderable Item Most Common Other Free Text Total"
+6 WRITE !," Indications Indications Indications"
+7 WRITE !,"-------------------------------------------------------------------------"
+8 QUIT
+9 ;
LEAP(%) ;Check if a Leap year
+1 if %<1700
SET %=%+1700
+2 QUIT (%#4=0)&'(%#100=0)!(%#400=0)
