PSJ0186 ;BIR/JLC - FIND ORDERS WITH NULL SI / OPI ;09/14/2006
;;5.0; INPATIENT MEDICATIONS ;**186**;16 DE7 97
;
;Reference to ^PS(50.7 is supported by DBIA 2180.
;Reference to ^PS(55 supported by DBIA 2191.
;Reference to ^XPD(9.7 supported by DBIA 2197.
;
EN ; Select device and determine format
I $G(DUZ)="" W !,"Your DUZ is not defined. It must be defined to run this routine." Q
N F1,F2,ZTDESC,XSAVE,ZTRTN
Q:$$SELDEV^PSJMUTL
W:'$D(IO("Q")) !,"this may take a while..."
F1 ;determine whether print format or comma-delimited
W !!,"(P)rint format or (C)omma-delimited output: " R F1:60 W " " I F1="" G EN
I F1="^" G EXIT
I F1'="P",F1'="C" W "Enter P or C" G F1
F2 W !!,"(O)nly active or (A)ll orders: " R F2:60 W " " I F2="" G F1
I F2="^" G EXIT
I F2'="O",F2'="A" D G F2
. W "Enter O for a list of active or recently expired orders only"
. W !?10,"Enter A for all orders since PSB*3*13 was installed."
I $D(IO("Q")) D G EXIT
. N I,A
. S ZTDESC="Search for Special Instruction / Other Print Info Isses (Sort)"
. S XSAVE="F1;F2"
. S ZTRTN="START^PSJ0186"
. F I=1:1 S A=$P(XSAVE,";",I) Q:A="" S ZTSAVE(A)=""
. D ^%ZTLOAD
D START
Q
START ;find potential problem orders
K ^TMP("PSJ0186",$J) N START,S1,DFN,ORDER,A,B,A0,A2,AD2,I,B,RDT,%,FIRST,PG,Y,ZTSAVE
D NOW^%DTC S RDT=$E(%,4,5)_"/"_$E(%,6,7)_"/"_($E(%,1,3)+1700),FIRST=%
I F2="A" S A=$O(^XPD(9.7,"B","PSB*3.0*13","")) I A]"" S FIRST=$P($G(^XPD(9.7,A,1)),"^") I FIRST="" S FIRST=%
S S1=FIRST-8
F S S1=$O(^PS(55,"AUD",S1)) Q:'S1 D
. S DFN=0
. F S DFN=$O(^PS(55,"AUD",S1,DFN)) Q:'DFN D
.. S ORDER=0
.. F S ORDER=$O(^PS(55,"AUD",S1,DFN,ORDER)) Q:'ORDER D
... Q:'$D(^PS(55,DFN,5,ORDER,6)) S A=$G(^(6)) Q:$P(A,"^",2)'=1
... S B=$P(A,"^") I B=""!(B?1." ") D
.... S A0=$G(^PS(55,DFN,5,ORDER,0)),AD2=$G(^(.2)),A2=$G(^(2))
.... S ^TMP("PSJ0186",$J,DFN,"UD",ORDER)=$P(A2,"^",2)_"^"_$P(A2,"^",4)_"^"_$P(AD2,"^")_"^"_$P(A0,"^",9)
S S1=FIRST-8 F S S1=$O(^PS(55,"AIV",S1)) Q:'S1 D
. S DFN=0
. F S DFN=$O(^PS(55,"AIV",S1,DFN)) Q:'DFN D
.. S ORDER=0
.. F S ORDER=$O(^PS(55,"AIV",S1,DFN,ORDER)) Q:'ORDER D
... Q:'$D(^PS(55,DFN,"IV",ORDER,3)) S A=$G(^(3)) Q:$P(A,"^",2)'=1
... S B=$P(A,"^") I B=""!(B?1." ") D
.... S A0=$G(^PS(55,DFN,"IV",ORDER,0)),AD2=$G(^(.2))
.... S ^TMP("PSJ0186",$J,DFN,"IV",ORDER)=$P(A0,"^",2)_"^"_$P(A0,"^",3)_"^"_$P(AD2,"^")_"^"_$P(A0,"^",17)
S (DFN,PG)=0 U IO I F1'="C" D HDR
F S DFN=$O(^TMP("PSJ0186",$J,DFN)) Q:'DFN D
. F I="UD","IV" D
.. S ORDER=0
.. F S ORDER=$O(^TMP("PSJ0186",$J,DFN,I,ORDER)) Q:ORDER="" S A=^(ORDER) D
... S B=^DPT(DFN,0)
... I F1="P" D
.... W $E($P(B,"^"),1,25),?28,$E($P(B,"^",9),6,9),?34,$E($G(^DPT(DFN,.1)),1,10),?45
.... S B=$P(A,"^") W $E(B,4,5),"/",$E(B,6,7),"/",$E(B,1,3)+1700,?57
.... S B=$P(A,"^",2) W $E(B,4,5),"/",$E(B,6,7),"/",$E(B,1,3)+1700," "
.... I $Y+1>IOSL D HDR
.... W $P(A,"^",4)," (",$S(I="UD":"UD",1:"IV"),") ",$P($G(^PS(50.7,$P(A,"^",3),0)),"^"),!
... I F1="C" D
.... W $P(B,"^"),",",$E($P(B,"^",9),6,9),",",$G(^DPT(DFN,.1)),","
.... S B=$P(A,"^") W $E(B,4,5),"/",$E(B,6,7),"/",$E(B,1,3)+1700,","
.... S B=$P(A,"^",2) W $E(B,4,5),"/",$E(B,6,7),"/",$E(B,1,3)+1700,","
.... W $P(A,"^",4),",(",$S(I="UD":"UD",1:"IV"),"),",$P($G(^PS(50.7,$P(A,"^",3),0)),"^"),!
I '$D(^TMP("PSJ0186",$J)) W "Nothing to print",!
EXIT D ^%ZISC Q
HDR S PG=PG+1 W:$Y @IOF W RDT,?32,"SI/OPI RESEARCH",?83,"PAGE: ",PG,!!
W "PATIENT NAME",?28,"SSN",?34,"WARD",?45,"START DATE",?57,"STOP DATE",?69,"ORDER INFO",!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJ0186 3556 printed Apr 09, 2024@21:05:31 Page 2
PSJ0186 ;BIR/JLC - FIND ORDERS WITH NULL SI / OPI ;09/14/2006
+1 ;;5.0; INPATIENT MEDICATIONS ;**186**;16 DE7 97
+2 ;
+3 ;Reference to ^PS(50.7 is supported by DBIA 2180.
+4 ;Reference to ^PS(55 supported by DBIA 2191.
+5 ;Reference to ^XPD(9.7 supported by DBIA 2197.
+6 ;
EN ; Select device and determine format
+1 IF $GET(DUZ)=""
WRITE !,"Your DUZ is not defined. It must be defined to run this routine."
QUIT
+2 NEW F1,F2,ZTDESC,XSAVE,ZTRTN
+3 if $$SELDEV^PSJMUTL
QUIT
+4 if '$DATA(IO("Q"))
WRITE !,"this may take a while..."
F1 ;determine whether print format or comma-delimited
+1 WRITE !!,"(P)rint format or (C)omma-delimited output: "
READ F1:60
WRITE " "
IF F1=""
GOTO EN
+2 IF F1="^"
GOTO EXIT
+3 IF F1'="P"
IF F1'="C"
WRITE "Enter P or C"
GOTO F1
F2 WRITE !!,"(O)nly active or (A)ll orders: "
READ F2:60
WRITE " "
IF F2=""
GOTO F1
+1 IF F2="^"
GOTO EXIT
+2 IF F2'="O"
IF F2'="A"
Begin DoDot:1
+3 WRITE "Enter O for a list of active or recently expired orders only"
+4 WRITE !?10,"Enter A for all orders since PSB*3*13 was installed."
End DoDot:1
GOTO F2
+5 IF $DATA(IO("Q"))
Begin DoDot:1
+6 NEW I,A
+7 SET ZTDESC="Search for Special Instruction / Other Print Info Isses (Sort)"
+8 SET XSAVE="F1;F2"
+9 SET ZTRTN="START^PSJ0186"
+10 FOR I=1:1
SET A=$PIECE(XSAVE,";",I)
if A=""
QUIT
SET ZTSAVE(A)=""
+11 DO ^%ZTLOAD
End DoDot:1
GOTO EXIT
+12 DO START
+13 QUIT
START ;find potential problem orders
+1 KILL ^TMP("PSJ0186",$JOB)
NEW START,S1,DFN,ORDER,A,B,A0,A2,AD2,I,B,RDT,%,FIRST,PG,Y,ZTSAVE
+2 DO NOW^%DTC
SET RDT=$EXTRACT(%,4,5)_"/"_$EXTRACT(%,6,7)_"/"_($EXTRACT(%,1,3)+1700)
SET FIRST=%
+3 IF F2="A"
SET A=$ORDER(^XPD(9.7,"B","PSB*3.0*13",""))
IF A]""
SET FIRST=$PIECE($GET(^XPD(9.7,A,1)),"^")
IF FIRST=""
SET FIRST=%
+4 SET S1=FIRST-8
+5 FOR
SET S1=$ORDER(^PS(55,"AUD",S1))
if 'S1
QUIT
Begin DoDot:1
+6 SET DFN=0
+7 FOR
SET DFN=$ORDER(^PS(55,"AUD",S1,DFN))
if 'DFN
QUIT
Begin DoDot:2
+8 SET ORDER=0
+9 FOR
SET ORDER=$ORDER(^PS(55,"AUD",S1,DFN,ORDER))
if 'ORDER
QUIT
Begin DoDot:3
+10 if '$DATA(^PS(55,DFN,5,ORDER,6))
QUIT
SET A=$GET(^(6))
if $PIECE(A,"^",2)'=1
QUIT
+11 SET B=$PIECE(A,"^")
IF B=""!(B?1." ")
Begin DoDot:4
+12 SET A0=$GET(^PS(55,DFN,5,ORDER,0))
SET AD2=$GET(^(.2))
SET A2=$GET(^(2))
+13 SET ^TMP("PSJ0186",$JOB,DFN,"UD",ORDER)=$PIECE(A2,"^",2)_"^"_$PIECE(A2,"^",4)_"^"_$PIECE(AD2,"^")_"^"_$PIECE(A0,"^",9)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+14 SET S1=FIRST-8
FOR
SET S1=$ORDER(^PS(55,"AIV",S1))
if 'S1
QUIT
Begin DoDot:1
+15 SET DFN=0
+16 FOR
SET DFN=$ORDER(^PS(55,"AIV",S1,DFN))
if 'DFN
QUIT
Begin DoDot:2
+17 SET ORDER=0
+18 FOR
SET ORDER=$ORDER(^PS(55,"AIV",S1,DFN,ORDER))
if 'ORDER
QUIT
Begin DoDot:3
+19 if '$DATA(^PS(55,DFN,"IV",ORDER,3))
QUIT
SET A=$GET(^(3))
if $PIECE(A,"^",2)'=1
QUIT
+20 SET B=$PIECE(A,"^")
IF B=""!(B?1." ")
Begin DoDot:4
+21 SET A0=$GET(^PS(55,DFN,"IV",ORDER,0))
SET AD2=$GET(^(.2))
+22 SET ^TMP("PSJ0186",$JOB,DFN,"IV",ORDER)=$PIECE(A0,"^",2)_"^"_$PIECE(A0,"^",3)_"^"_$PIECE(AD2,"^")_"^"_$PIECE(A0,"^",17)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+23 SET (DFN,PG)=0
USE IO
IF F1'="C"
DO HDR
+24 FOR
SET DFN=$ORDER(^TMP("PSJ0186",$JOB,DFN))
if 'DFN
QUIT
Begin DoDot:1
+25 FOR I="UD","IV"
Begin DoDot:2
+26 SET ORDER=0
+27 FOR
SET ORDER=$ORDER(^TMP("PSJ0186",$JOB,DFN,I,ORDER))
if ORDER=""
QUIT
SET A=^(ORDER)
Begin DoDot:3
+28 SET B=^DPT(DFN,0)
+29 IF F1="P"
Begin DoDot:4
+30 WRITE $EXTRACT($PIECE(B,"^"),1,25),?28,$EXTRACT($PIECE(B,"^",9),6,9),?34,$EXTRACT($GET(^DPT(DFN,.1)),1,10),?45
+31 SET B=$PIECE(A,"^")
WRITE $EXTRACT(B,4,5),"/",$EXTRACT(B,6,7),"/",$EXTRACT(B,1,3)+1700,?57
+32 SET B=$PIECE(A,"^",2)
WRITE $EXTRACT(B,4,5),"/",$EXTRACT(B,6,7),"/",$EXTRACT(B,1,3)+1700," "
+33 IF $Y+1>IOSL
DO HDR
+34 WRITE $PIECE(A,"^",4)," (",$SELECT(I="UD":"UD",1:"IV"),") ",$PIECE($GET(^PS(50.7,$PIECE(A,"^",3),0)),"^"),!
End DoDot:4
+35 IF F1="C"
Begin DoDot:4
+36 WRITE $PIECE(B,"^"),",",$EXTRACT($PIECE(B,"^",9),6,9),",",$GET(^DPT(DFN,.1)),","
+37 SET B=$PIECE(A,"^")
WRITE $EXTRACT(B,4,5),"/",$EXTRACT(B,6,7),"/",$EXTRACT(B,1,3)+1700,","
+38 SET B=$PIECE(A,"^",2)
WRITE $EXTRACT(B,4,5),"/",$EXTRACT(B,6,7),"/",$EXTRACT(B,1,3)+1700,","
+39 WRITE $PIECE(A,"^",4),",(",$SELECT(I="UD":"UD",1:"IV"),"),",$PIECE($GET(^PS(50.7,$PIECE(A,"^",3),0)),"^"),!
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+40 IF '$DATA(^TMP("PSJ0186",$JOB))
WRITE "Nothing to print",!
EXIT DO ^%ZISC
QUIT
HDR SET PG=PG+1
if $Y
WRITE @IOF
WRITE RDT,?32,"SI/OPI RESEARCH",?83,"PAGE: ",PG,!!
+1 WRITE "PATIENT NAME",?28,"SSN",?34,"WARD",?45,"START DATE",?57,"STOP DATE",?69,"ORDER INFO",!!
+2 QUIT
