source: WorldVistAEHR/trunk/r/ICR_IMMUNOLOGY_CASE_REGISTRY-IMR/IMRSET1.m@ 789

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

initial load of WorldVistAEHR

File size: 5.1 KB
Line 
1IMRSET1 ;ISC-SF.SEA/JLI,HCIOFO/FT/FAI-REPORTS FOR IMR PACKAGE ;07/17/00 16:12
2 ;;2.1;IMMUNOLOGY CASE REGISTRY;**3,5**;Feb 09, 1998
3CHK ; Check If Immunology User
4 I '$D(^XUSEC("IMRMGR",DUZ)) S IMRLOC="IMRSET1" D ACESSERR^IMRERR K IMRLOC D H^XUS
5 Q
6INPT ;[IMR INPAT LIST] - Current Inpatients Report
7 D CHK
8 S DIR(0)="N^1:20:0",DIR("B")=1,DIR("A")="NUMBER OF COPIES TO BE PRINTED" D ^DIR K DIR
9 I $D(DIRUT) D EXIT Q ;quit if question not answered
10 S IMRCOPYS=+Y
11 D IMRDEV^IMREDIT I POP D EXIT Q ;quit if no device selected
12 I $D(IO("Q")) S ZTRTN="DQINPT^IMRSET1",ZTION=ION_";"_IOM_";"_IOSL,ZTSAVE("IMRCOPYS")="" D ^%ZTLOAD K ZTRTN,ZTION G EXIT
13DQINPT ;
14 U IO K ^TMP($J) S:'$D(IMRCOPYS) IMRCOPYS=1
15 S IMRUT=0,IMRB=$$REPEAT^XLFSTR(" ",34),IMRERR=0
16 I $D(ZTQUEUED) S IMRION=$O(^IMR(158.9,1,7,0)) I IMRION>0,$D(^(IMRION,0)),$P(^(0),U)'="" S IMRERR=1 F IMRI=0:0 S IMRI=$O(^IMR(158.9,1,7,IMRI)) Q:IMRI'>0 S IMRION=+^(IMRI,0) I IMRION=IOS S IMRERR=0 Q
17 K IMRI,IMRION
18 I IMRERR F I=1:1:5 W !!!!,"THE ICR PACKAGE 'CURRENT INPATIENT LIST' CAN ONLY BE OUTPUT TO A SECURE PRINTER"
19 I IMRERR K IMRERR D ^%ZISC Q
20 S IMRJ=0,IMRSFY=$E(DT,1,3)_"1001"
21 I IMRSFY>DT S IMRSFY=IMRSFY-10000
22 F IMRI=0:0 S IMRI=$O(^IMR(158,IMRI)) Q:IMRI'>0 S IMR0=^(IMRI,0),X=+IMR0 D XOR^IMRXOR S DFN=X D 51^VADPT S IMRWRD=$P(VAIP(5),U,2) I IMRWRD'="" D
23 .S X=$P(IMR0,U,42),X=$S(X="":" ",1:X),^TMP($J,IMRWRD,VADM(1),$E(VA("BID")_" ",1,7))=DFN_U_X,IMRJ=IMRJ+1
24 .Q
25 K VA,VADM,VAIP
26 S X="N",%DT="T" D ^%DT K %DT
27 S Y=Y_"00000",IMRDT=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_" "_$E(Y,9,10)_":"_$E(Y,11,12),IMRUT=0
28 F IMRI=1:1:IMRCOPYS D
29 .S IMRPG=0,A="" Q:IMRUT D HEDR Q:IMRUT W !!,"A TOTAL OF ",IMRJ," INPATIENTS LISTED"
30 .F I=0:0 S A=$O(^TMP($J,A)) Q:A=""!(IMRUT) W ! S B="" F J=0:0 S B=$O(^TMP($J,A,B)) Q:B=""!(IMRUT) S C="" F L=0:0 S C=$O(^TMP($J,A,B,C)) Q:C=""!(IMRUT) D:($Y+3>IOSL) HEDR Q:IMRUT D SLOS
31 .Q
32 S:$D(ZTQUEUED) ZTREQ="@"
33 D:'IMRUT EOP
34EXIT D ^%ZISC
35 K ^TMP($J),%T,%Y,%ZIS,A,B,C,DFN,IMR0,IMRB,IMRFLG2,IMRI,IMRWRD,I,J,L,K,Y,POP,VA,VADM,X,IMRUT,X1,X2,IMRLOS,IMRYLOS,IMRX1,IMRX2,IMRSFY,IMRX0,IMRERR,IMRFLG,IMRJ,VAERR,VAROOT,DISYS,D,IMRDT,IMRCOPYS,IMRPG,IMRXX,IMRY
36 K IMRAD,IMRDD,IMRDISP,IMRDSP,IMREC,IMRFB,IMROUT,IMRPTF,IMRST,IMRSUF
37 Q
38SLOS ;
39 S DFN=+^TMP($J,A,B,C),(IMRX0,IMRYLOS)=0,IMRX2=""
40 F K=0:0 S K=$O(^DGPT("B",DFN,K)) Q:K'>0 I $D(^DGPT(K,0)) S IMRPTF=K D PTF^IMRUTL S X1=IMRSUF I 'IMRFB,IMREC'=2,$$CODE(X1) D
41 .S (IMRX2,X2)=IMRAD
42 .S (IMRX1,X1)=$S(+IMRDD'>0:0,1:+IMRDD)
43 .Q:'IMRX2
44 .S IMRFLG2=0
45 .I 'IMRX1 D DBCHK^IMRLCNT(DFN,IMRX2,.IMRX1,.IMRFLG2) Q:IMRFLG2 S (IMRX1,X1)=$S('IMRX1:(DT+1),1:IMRX1)
46 .D ^%DTC S:IMRX2>IMRX0 IMRLOS=$S(X>0:X,1:1),IMRX0=IMRX2 I IMRX1'<IMRSFY D SLOS1
47 .Q
48 S IMRX2=$E(IMRX0,4,5)_"/"_$E(IMRX0,6,7)_"/"_$E(IMRX0,2,3) W !,$E(B,1,20),?23,C," ",$P(^TMP($J,A,B,C),U,2)," ",$E(A,1,20),?56,IMRX2,$J(IMRLOS,7)," ",$J(IMRYLOS,3)
49 Q
50SLOS1 ;
51 S X2=$S(IMRX2'<IMRSFY:IMRX2,1:IMRSFY),X1=IMRX1 D ^%DTC S IMRYLOS=$S(X>0:X,1:1)+IMRYLOS
52 Q
53CODE(IMRXX) ; Check Suffix For Validity
54 S IMRY=$S(IMRXX="":1,IMRXX="9AA":1,IMRXX="9AB":1,IMRXX="9BB":1,IMRXX="BU":1,IMRXX="BV":1,IMRXX="A0":1,IMRXX="A4":1,IMRXX="A5":1,IMRXX="PA":1,1:0)
55 Q IMRY
56HEDR ; Print Report Header
57 I IOST["C-",IMRPG!(IMRI>1) W ! S DIR(0)="E" D ^DIR K DIR I 'Y S IMRUT=1 Q
58 W:$Y>0 @IOF S IMRPG=IMRPG+1
59 I $E(IOST,1,2)'="C-",IMRI>1,IMRPG=1 W:$Y>0 @IOF
60 W !!!,IMRDT,?27,"CURRENT INPATIENTS REPORT",?70,"Page ",IMRPG,!!,?23,"LAST",?55,"ADMISSION",?67,"CURR",?74,"YTD",!,"PATIENT",?23,"FOUR",?29,"CAT",?35,"WARD",?58,"DATE",?68,"LOS",?74,"LOS",!
61 Q
62DQ ;[IMR QUEUED INPAT LIST] - Current Inpatient List (Queue This Option)
63 G:$D(ZTQUEUED) DQINPT
64 S DIR(0)="Y",DIR("A")="Do you REALLY want to queue this option to run DAILY",DIR("B")="NO" D ^DIR K DIR Q:'Y
65DQ2 ;
66 S IMRFLG=0 I $O(^IMR(158.9,1,7,0))'>0 W !,$C(7),"Restricted printers must be defined in Site Parameters File For this Option",!! K IMRFLG Q
67 I 'IMRFLG W !!,$C(7),"Select device from:" F I=0:0 S I=$O(^IMR(158.9,1,7,I)) Q:I'>0 I $D(^(I,0)) S X=+^(0) I $D(^%ZIS(1,X,0)) W !?5,$P(^(0),U)
68 I 'IMRFLG W ! S %ZIS="NM" D ^%ZIS Q:POP I IO=IO(0) W !,$C(7),"The HOME device may not be selected as the device to QUEUE this option." G DQ2
69 F I=0:0 S I=$O(^IMR(158.9,1,7,I)) Q:I'>0 I $D(^(I,0)) S X=+^(0) I $D(^%ZIS(1,X,0)) I $P(ION,";",1)=$P(^(0),U) S IMRFLG=1 Q
70 I 'IMRFLG W !,"Select one of the valid devices",$C(7),! G DQ2
71 S %DT="AEQXFT",%DT("A")="QUEUE this option to run WHEN: " D ^%DT
72 G:Y'>0 DQEXIT
73 S IMRDT=+Y,IMRFLG=0
74 I $D(^DIC(19.2,0)) D
75 .K DIC,DIE,DLAYGO,DR,DA
76 .S DIC(0)="ML",DIC="^DIC(19.2,",X="IMR QUEUED INPAT LIST",DLAYGO=19.2
77 .D ^DIC Q:Y'>0
78 .S DA=+Y,DIE="^DIC(19.2,",DR="2///"_IMRDT_";3////"_ION_";6///1D" D ^DIE
79 .S IMRFLG=1
80 .Q
81 I IMRFLG=1 W !!,"The Current Inpatient List is now scheduled to print each day at",! S X=$P(IMRDT,".",2)_"0000" W $E(X,1,2),":",$E(X,3,4)," on device ",ION,!,"beginning on ",$E(IMRDT,4,5),"/",$E(IMRDT,6,7),"/",$E(IMRDT,2,3),!!
82 I IMRFLG=0 D
83 .W !!,"Sorry, cannot schedule this option to run because the OPTION SCHEDULING",!,"file (19.2) doesn't exist.",!!
84 .Q
85DQEXIT K %,%DT,%XX,%Y,%YY,D,D0,DA,DI,DIC,DIE,DQ,DR,I,IMRDT,IMRFLG,IMRSTN,POP,X,Y
86 Q
87EOP ; Check End of Page
88 Q:$D(IO("S")) ;quit if a slave device
89 I IOST["C-" K DIR W ! S DIR(0)="E" D ^DIR K DIR I 'Y S IMRUT=1
90 Q
Note: See TracBrowser for help on using the repository browser.