- 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 Mar 13, 2025@21:10: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
