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

IMRSET1 ;ISC-SF.SEA/JLI,HCIOFO/FT/FAI-REPORTS FOR IMR PACKAGE ;07/17/00  16:12
 ;;2.1;IMMUNOLOGY CASE REGISTRY;**3,5**;Feb 09, 1998
CHK ; Check If Immunology User
 I '$D(^XUSEC("IMRMGR",DUZ)) S IMRLOC="IMRSET1" D ACESSERR^IMRERR K IMRLOC D H^XUS
 Q
INPT ;[IMR INPAT LIST] - Current Inpatients Report
 D CHK
 S DIR(0)="N^1:20:0",DIR("B")=1,DIR("A")="NUMBER OF COPIES TO BE PRINTED" D ^DIR K DIR
 I $D(DIRUT) D EXIT Q  ;quit if question not answered
 S IMRCOPYS=+Y
 D IMRDEV^IMREDIT I POP D EXIT Q  ;quit if no device selected
 I $D(IO("Q")) S ZTRTN="DQINPT^IMRSET1",ZTION=ION_";"_IOM_";"_IOSL,ZTSAVE("IMRCOPYS")="" D ^%ZTLOAD K ZTRTN,ZTION G EXIT
DQINPT ;
 U IO K ^TMP($J) S:'$D(IMRCOPYS) IMRCOPYS=1
 S IMRUT=0,IMRB=$$REPEAT^XLFSTR(" ",34),IMRERR=0
 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
 K IMRI,IMRION
 I IMRERR F I=1:1:5 W !!!!,"THE ICR PACKAGE 'CURRENT INPATIENT LIST' CAN ONLY BE OUTPUT TO A SECURE PRINTER"
 I IMRERR K IMRERR D ^%ZISC Q
 S IMRJ=0,IMRSFY=$E(DT,1,3)_"1001"
 I IMRSFY>DT S IMRSFY=IMRSFY-10000
 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
 .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
 .Q
 K VA,VADM,VAIP
 S X="N",%DT="T" D ^%DT K %DT
 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
 F IMRI=1:1:IMRCOPYS D
 .S IMRPG=0,A="" Q:IMRUT  D HEDR Q:IMRUT  W !!,"A TOTAL OF ",IMRJ," INPATIENTS LISTED"
 .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
 .Q
 S:$D(ZTQUEUED) ZTREQ="@"
 D:'IMRUT EOP
EXIT D ^%ZISC
 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
 K IMRAD,IMRDD,IMRDISP,IMRDSP,IMREC,IMRFB,IMROUT,IMRPTF,IMRST,IMRSUF
 Q
SLOS ;
 S DFN=+^TMP($J,A,B,C),(IMRX0,IMRYLOS)=0,IMRX2=""
 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
 .S (IMRX2,X2)=IMRAD
 .S (IMRX1,X1)=$S(+IMRDD'>0:0,1:+IMRDD)
 .Q:'IMRX2
 .S IMRFLG2=0
 .I 'IMRX1 D DBCHK^IMRLCNT(DFN,IMRX2,.IMRX1,.IMRFLG2) Q:IMRFLG2  S (IMRX1,X1)=$S('IMRX1:(DT+1),1:IMRX1)
 .D ^%DTC S:IMRX2>IMRX0 IMRLOS=$S(X>0:X,1:1),IMRX0=IMRX2 I IMRX1'<IMRSFY D SLOS1
 .Q
 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)
 Q
SLOS1 ;
 S X2=$S(IMRX2'<IMRSFY:IMRX2,1:IMRSFY),X1=IMRX1 D ^%DTC S IMRYLOS=$S(X>0:X,1:1)+IMRYLOS
 Q
CODE(IMRXX) ; Check Suffix For Validity
 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)
 Q IMRY
HEDR ; Print Report Header
 I IOST["C-",IMRPG!(IMRI>1) W ! S DIR(0)="E" D ^DIR K DIR I 'Y S IMRUT=1 Q
 W:$Y>0 @IOF S IMRPG=IMRPG+1
 I $E(IOST,1,2)'="C-",IMRI>1,IMRPG=1 W:$Y>0 @IOF
 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",!
 Q
DQ ;[IMR QUEUED INPAT LIST] - Current Inpatient List (Queue This Option)
 G:$D(ZTQUEUED) DQINPT
 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
DQ2 ;
 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
 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)
 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
 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
 I 'IMRFLG W !,"Select one of the valid devices",$C(7),! G DQ2
 S %DT="AEQXFT",%DT("A")="QUEUE this option to run WHEN: " D ^%DT
 G:Y'>0 DQEXIT
 S IMRDT=+Y,IMRFLG=0
 I $D(^DIC(19.2,0)) D
 .K DIC,DIE,DLAYGO,DR,DA
 .S DIC(0)="ML",DIC="^DIC(19.2,",X="IMR QUEUED INPAT LIST",DLAYGO=19.2
 .D ^DIC Q:Y'>0
 .S DA=+Y,DIE="^DIC(19.2,",DR="2///"_IMRDT_";3////"_ION_";6///1D" D ^DIE
 .S IMRFLG=1
 .Q
 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),!!
 I IMRFLG=0 D
 .W !!,"Sorry, cannot schedule this option to run because the OPTION SCHEDULING",!,"file (19.2) doesn't exist.",!!
 .Q
DQEXIT K %,%DT,%XX,%Y,%YY,D,D0,DA,DI,DIC,DIE,DQ,DR,I,IMRDT,IMRFLG,IMRSTN,POP,X,Y
 Q
EOP ; Check End of Page
 Q:$D(IO("S"))  ;quit if a slave device
 I IOST["C-" K DIR W ! S DIR(0)="E" D ^DIR K DIR I 'Y S IMRUT=1
 Q