source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJ0186.m@ 1061

Last change on this file since 1061 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 3.4 KB
Line 
1PSJ0186 ;BIR/JLC - FIND ORDERS WITH NULL SI / OPI ;09/14/2006
2 ;;5.0; INPATIENT MEDICATIONS ;**186**;16 DE7 97
3 ;
4 ;Reference to ^PS(50.7 is supported by DBIA 2180.
5 ;Reference to ^PS(55 supported by DBIA 2191.
6 ;Reference to ^XPD(9.7 supported by DBIA 2197.
7 ;
8EN ; Select device and determine format
9 I $G(DUZ)="" W !,"Your DUZ is not defined. It must be defined to run this routine." Q
10 N F1,F2,ZTDESC,XSAVE,ZTRTN
11 Q:$$SELDEV^PSJMUTL
12 W:'$D(IO("Q")) !,"this may take a while..."
13F1 ;determine whether print format or comma-delimited
14 W !!,"(P)rint format or (C)omma-delimited output: " R F1:60 W " " I F1="" G EN
15 I F1="^" G EXIT
16 I F1'="P",F1'="C" W "Enter P or C" G F1
17F2 W !!,"(O)nly active or (A)ll orders: " R F2:60 W " " I F2="" G F1
18 I F2="^" G EXIT
19 I F2'="O",F2'="A" D G F2
20 . W "Enter O for a list of active or recently expired orders only"
21 . W !?10,"Enter A for all orders since PSB*3*13 was installed."
22 I $D(IO("Q")) D G EXIT
23 . N I,A
24 . S ZTDESC="Search for Special Instruction / Other Print Info Isses (Sort)"
25 . S XSAVE="F1;F2"
26 . S ZTRTN="START^PSJ0186"
27 . F I=1:1 S A=$P(XSAVE,";",I) Q:A="" S ZTSAVE(A)=""
28 . D ^%ZTLOAD
29 D START
30 Q
31START ;find potential problem orders
32 K ^TMP("PSJ0186",$J) N START,S1,DFN,ORDER,A,B,A0,A2,AD2,I,B,RDT,%,FIRST,PG,Y,ZTSAVE
33 D NOW^%DTC S RDT=$E(%,4,5)_"/"_$E(%,6,7)_"/"_($E(%,1,3)+1700),FIRST=%
34 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=%
35 S S1=FIRST-8
36 F S S1=$O(^PS(55,"AUD",S1)) Q:'S1 D
37 . S DFN=0
38 . F S DFN=$O(^PS(55,"AUD",S1,DFN)) Q:'DFN D
39 .. S ORDER=0
40 .. F S ORDER=$O(^PS(55,"AUD",S1,DFN,ORDER)) Q:'ORDER D
41 ... Q:'$D(^PS(55,DFN,5,ORDER,6)) S A=$G(^(6)) Q:$P(A,"^",2)'=1
42 ... S B=$P(A,"^") I B=""!(B?1." ") D
43 .... S A0=$G(^PS(55,DFN,5,ORDER,0)),AD2=$G(^(.2)),A2=$G(^(2))
44 .... S ^TMP("PSJ0186",$J,DFN,"UD",ORDER)=$P(A2,"^",2)_"^"_$P(A2,"^",4)_"^"_$P(AD2,"^")_"^"_$P(A0,"^",9)
45 S S1=FIRST-8 F S S1=$O(^PS(55,"AIV",S1)) Q:'S1 D
46 . S DFN=0
47 . F S DFN=$O(^PS(55,"AIV",S1,DFN)) Q:'DFN D
48 .. S ORDER=0
49 .. F S ORDER=$O(^PS(55,"AIV",S1,DFN,ORDER)) Q:'ORDER D
50 ... Q:'$D(^PS(55,DFN,"IV",ORDER,3)) S A=$G(^(3)) Q:$P(A,"^",2)'=1
51 ... S B=$P(A,"^") I B=""!(B?1." ") D
52 .... S A0=$G(^PS(55,DFN,"IV",ORDER,0)),AD2=$G(^(.2))
53 .... S ^TMP("PSJ0186",$J,DFN,"IV",ORDER)=$P(A0,"^",2)_"^"_$P(A0,"^",3)_"^"_$P(AD2,"^")_"^"_$P(A0,"^",17)
54 S (DFN,PG)=0 U IO I F1'="C" D HDR
55 F S DFN=$O(^TMP("PSJ0186",$J,DFN)) Q:'DFN D
56 . F I="UD","IV" D
57 .. S ORDER=0
58 .. F S ORDER=$O(^TMP("PSJ0186",$J,DFN,I,ORDER)) Q:ORDER="" S A=^(ORDER) D
59 ... S B=^DPT(DFN,0)
60 ... I F1="P" D
61 .... W $E($P(B,"^"),1,25),?28,$E($P(B,"^",9),6,9),?34,$E($G(^DPT(DFN,.1)),1,10),?45
62 .... S B=$P(A,"^") W $E(B,4,5),"/",$E(B,6,7),"/",$E(B,1,3)+1700,?57
63 .... S B=$P(A,"^",2) W $E(B,4,5),"/",$E(B,6,7),"/",$E(B,1,3)+1700," "
64 .... I $Y+1>IOSL D HDR
65 .... W $P(A,"^",4)," (",$S(I="UD":"UD",1:"IV"),") ",$P($G(^PS(50.7,$P(A,"^",3),0)),"^"),!
66 ... I F1="C" D
67 .... W $P(B,"^"),",",$E($P(B,"^",9),6,9),",",$G(^DPT(DFN,.1)),","
68 .... S B=$P(A,"^") W $E(B,4,5),"/",$E(B,6,7),"/",$E(B,1,3)+1700,","
69 .... S B=$P(A,"^",2) W $E(B,4,5),"/",$E(B,6,7),"/",$E(B,1,3)+1700,","
70 .... W $P(A,"^",4),",(",$S(I="UD":"UD",1:"IV"),"),",$P($G(^PS(50.7,$P(A,"^",3),0)),"^"),!
71 I '$D(^TMP("PSJ0186",$J)) W "Nothing to print",!
72EXIT D ^%ZISC Q
73HDR S PG=PG+1 W:$Y @IOF W RDT,?32,"SI/OPI RESEARCH",?83,"PAGE: ",PG,!!
74 W "PATIENT NAME",?28,"SSN",?34,"WARD",?45,"START DATE",?57,"STOP DATE",?69,"ORDER INFO",!!
75 Q
Note: See TracBrowser for help on using the repository browser.