NURAGEN ;HIRMFO/JH,FT,MD-GENERIC REPORT GENERATOR FOR ADMIN. part 1 ;4/30/97
;;4.0;NURSING SERVICE;**1,13**;Apr 25, 1997
;LAST MODIFIED BY MD; MAR 95
;There are (2) segments of this print module which services 10 Routines
; A9A1,A9E1,A9F1,A9H1,A9J1
; A6A1,A6E1,A6F1,A6H1,A6J1
;
PRINT ; PRINT MODULE
D:$G(NURSUMSW)!'(NURMDSW) HEADER S (NPR0,NPR1,NPR2,NPR3,NPR4,NPR5,NPR6,NPC6,NPC7,NPC8,NX)="" D N
K X,Y,NURLINE,NPC1,NPC2,NPC3,NPC4,NPC5,NPC6,NPC7,NPC8,NPR0,NPR1,NPR2,NPR3,NPR4,NPR5,NPR6,NNURSX,NURAROU,NURSLEV,NURSSP
Q
N S NURFAC="" F S NURFAC=$O(^TMP($J,"L",NURFAC)) Q:NURFAC=""!(NURQUIT) D:$G(NURMDSW)&'$G(NURSUMSW) HEADER D P Q:$G(NURQUIT) D:NURMDSW FSUBTL^NURAGEN1 Q:NURQUIT
Q
P S NURPROG="" F S NURPROG=$O(^TMP($J,"L",NURFAC,NURPROG)) Q:NURPROG=""!(NURQUIT) D PROD,P0 Q:$G(NURQUIT) I NURPLSW,'$G(NURSUMSW) D PSUBTL^NURAGEN1 Q:NURQUIT
Q
P0 S NPC2="" F S NPC2=$O(^TMP($J,"L",NURFAC,NURPROG,NPC2)) Q:NPC2="" D P1 Q:NURQUIT I '$G(NURSUMSW),$G(NURPLSW) D HEADER Q:NURQUIT
Q
P1 S NPC3="" F S NPC3=$O(^TMP($J,"L",NURFAC,NURPROG,NPC2,NPC3)) Q:NPC3="" S:NURSLEV=3 NPC1=0 D P2 Q:NURQUIT
Q
P2 S NPC4="" F S NPC4=$O(^TMP($J,"L",NURFAC,NURPROG,NPC2,NPC3,NPC4)) Q:NPC4="" S:NURSLEV=4 NPC1=0 S NURSORT=$G(^TMP($J,"L",NURFAC,NURPROG,NPC2,NPC3,NPC4)) I NURSORT D P3 Q:NURQUIT
Q
P3 S NPC5="" F S NPC5=$O(^TMP($J,"L1",NURSORT,NPC5)) Q:NPC5="" S:NURSLEV=5 NPC1=0 D P4:NURSLEV>3 Q:NURQUIT D PRINT1:NURSLEV=3
Q
P4 S NPC6="" F S NPC6=$O(^TMP($J,"L1",NURSORT,NPC5,NPC6)) Q:NPC6="" S:NURSLEV=6 NPC1=0 D P5:NURSLEV>4 Q:NURQUIT D PRINT1:NURSLEV=4
Q
P5 S NPC7="" F S NPC7=$O(^TMP($J,"L1",NURSORT,NPC5,NPC6,NPC7)) Q:NPC7="" D P6:NURSLEV>5 Q:NURQUIT D PRINT1:NURSLEV=5
Q
P6 I NURSLEV<7 S NPC8="" F S NPC8=$O(^TMP($J,"L1",NURSORT,NPC5,NPC6,NPC7,NPC8)) Q:NPC8=""!NURQUIT D PRINT1
Q
; DETAIL LINE PRINT ROUTINE
PRINT1 I ($Y>(IOSL-6)) D HEADER Q:NURQUIT
D ENT1^NURAGEN1
S NURSW1=1 W:NPC1=0&'($G(NURSUMSW)) ! S NPC1=NPC1+1 I NURROU=2!(NURROU=6)!(NURROU=10)!(NURROU=12)!(NURROU=16)!(NURROU=20) D PRI4 Q
D PRI1:(NURROU>0&(NURROU<7))!(NURROU=9)!(NURROU=10),PRI2:(NURROU=7)!(NURROU=8)!(NURROU=17),PRI3:(NURROU>10&(NURROU<17))!(NURROU>18&(NURROU<21)),PRI5:NURROU=18
Q
PRI1 W !,NPC1,?6,$E(NPR2,1,10),?17,$E(NPR3,1,10),?28,$E(NPR5,1,20),?52,NPR4
Q
PRI2 I NURROU=7!(NURROU=8) W !,NPC1,?6,$E(NPR2,1,10),?17,NPR3,?28,$E(NPR6,1,20),?50,NPR4,?65,NPR5 Q
W:'$G(NURSUMSW) !,NPC1,?6,$E(NPR2,1,10),?17,$E(NPR5,1,20),?40,NPR3,?59,NPR4
Q
PRI3 W:'$G(NURSUMSW) !,NPC1,?10,$E(NPR2,1,10),?23,$E(NPR4,1,20),?49,NPR3 ;ROU= 11 - 16
Q
PRI4 I NURROU=2!(NURROU=6)!(NURROU=10) W !,NPC1,?6,$S(NPC2'=" BLANK":$E(NPC2,1,10),1:""),?17,$S(NPC4'=" BLANK":NPC4,1:""),?28,$S(NPC6'=" BLANK":$E(NPC6,1,20),1:""),?52,$S(NPC5'=" BLANK":NPC5,1:"") Q
W:'$G(NURSUMSW) !,NPC1,?6,$S(NPC3'=" BLANK":$E(NPC3,1,10),1:""),?17,$S(NPC5'=" BLANK":$E(NPC5,1,20),1:""),?48,$S(NPC4'=" BLANK":NPC4,1:"")
Q
PRI5 W:'$G(NURSUMSW) !,NPC1,?6,$E(NPR2,1,10),?17,$E(NPR5,1,20),?45,NPR3,?61,NPR4 ;6H2
Q
S NX="" I (NURROU=12!(NURROU=14)!(NURROU=16)!(NURROU=18)!(NURROU=20)),'NURMDSW,'NURQUEUE,$E(IOST)="C",NURSW1,$Y<(IOSL-6) G NEXT1
I 'NURQUEUE,$E(IOST)="C",NURSW1 D ENDPG Q:$G(NURQUIT)
NEXT1 I (NURROU=12!(NURROU=14)!(NURROU=16)!(NURROU=18)!(NURROU=20)),'NURMDSW,$Y<(IOSL-6),NURSW1 G NEXTL
S NURPAGE=NURPAGE+1 W:$E(IOST)="C"!(NURPAGE>1) @IOF
I NURMDSW,'$G(NURSUMSW),$L($G(NURFAC))>1 W ?$$CNTR^NURSUT2(NURFAC),$$FACL^NURSUT2($G(NURFAC))
W !,NURSTIL S X="T" D ^%DT D:+Y D^DIQ W ?56,Y,?72,"PAGE: ",NURPAGE
W !!,NURSTIL1,!,NURSTIL2,!,$$REPEAT^XLFSTR("-",80) Q:'NURSW1
PROD I $G(NURPLSW),$L(NURPROG)>1,'$G(NURSUMSW) N Z S Z=$$PROD^NURSUT2($G(NURPROG)) W:$G(Z)'="" !!,?$$CNTR^NURSUT2(NURPROG),$G(Z),!,?$$CNTR^NURSUT2(NURPROG),$$REPEAT^XLFSTR("-",$L(Z)+1)
NEXTL S:NX="T" NURQUIT=1
Q
NODATA ;
I $O(^TMP($J,""))="",'$D(NURSNLOC) S NUROUT=1 S NURPROG=$S($G(NURPROG)=0:NURPROG(1),1:""),NURFAC=$S($G(NURFAC)=0:NURFAC(1),1:"") D HEADER W !!,"THERE IS NO DATA FOR THIS REPORT"
I $O(^TMP($J,""))="",$D(NURSNLOC) S NUROUT=1 S NURPROG=$S($G(NURPROG)=0:NURPROG(1),1:""),NURFAC=$S($G(NURFAC)=0:NURFAC(1),1:"") D HEADER S NL1="" F S NL1=$O(NURSNLOC(NL1)) Q:NL1="" D NODATA^NURSUT1
I $O(^TMP($J,""))'="",$D(NURSNLOC) D I NURSW1=1 D ENDPG^NURSUT1 S NURSW1=0
. S (NURY,NURZ,NURX)="" F S NURY=$O(^TMP($J,"L",NURY)) Q:NURY="" F S NURZ=$O(^TMP($J,"L",NURY,NURZ)) Q:NURZ="" F S NURX=$O(^TMP($J,"L",NURY,NURZ,NURX)) Q:NURX="" S ^TMP("NURLOC",$J,NURX)=""
. S NL1="" F S NL1=$O(NURSNLOC(NL1)) Q:NL1="" I '$D(^TMP("NURLOC",$J,NL1)) D
. . S NURPROG=$S($G(NURPROG)=0:NURPROG(1),1:""),NURFAC=$S($G(NURFAC)=0:NURFAC(1),1:"") D:NURSW1=0 HEADER S NURSW1=1 D NODATA^NURSUT1
. . Q
. Q
Q
CLOSE ; CLOSE DEVICE
W ! I '$G(NURQUIT) D ENDPG
D ^%ZISC
I $D(ZTQUEUED) S ZTREQ="@"
Q
ENDPG ; HANDLE EOP
I $E(IOST)'="C"!($G(NURQUIT)) Q
W $C(7),!!,"Press return to continue, ""T"" for totals, or ""^"" to exit: " R NX:DTIME
S NX=$$UP^XLFSTR(NX)
I '$T!(NX=U) S (NURQUIT,NUROUT)=1
Q
NURAGEN ;HIRMFO/JH,FT,MD-GENERIC REPORT GENERATOR FOR ADMIN. part 1 ;4/30/97
+1 ;;4.0;NURSING SERVICE;**1,13**;Apr 25, 1997
+2 ;LAST MODIFIED BY MD; MAR 95
+3 ;There are (2) segments of this print module which services 10 Routines
+4 ; A9A1,A9E1,A9F1,A9H1,A9J1
+5 ; A6A1,A6E1,A6F1,A6H1,A6J1
+6 ;
PRINT ; PRINT MODULE
+1 IF $GET(NURSUMSW)!'(NURMDSW)
DO HEADER
SET (NPR0,NPR1,NPR2,NPR3,NPR4,NPR5,NPR6,NPC6,NPC7,NPC8,NX)=""
DO N
+2 KILL X,Y,NURLINE,NPC1,NPC2,NPC3,NPC4,NPC5,NPC6,NPC7,NPC8,NPR0,NPR1,NPR2,NPR3,NPR4,NPR5,NPR6,NNURSX,NURAROU,NURSLEV,NURSSP
+3 QUIT
N SET NURFAC=""
FOR
SET NURFAC=$ORDER(^TMP($JOB,"L",NURFAC))
IF NURFAC=""!(NURQUIT)
QUIT
IF $GET(NURMDSW)&'$GET(NURSUMSW)
DO HEADER
DO P
IF $GET(NURQUIT)
QUIT
IF NURMDSW
DO FSUBTL^NURAGEN1
IF NURQUIT
QUIT
+1 QUIT
P SET NURPROG=""
FOR
SET NURPROG=$ORDER(^TMP($JOB,"L",NURFAC,NURPROG))
IF NURPROG=""!(NURQUIT)
QUIT
DO PROD
DO P0
IF $GET(NURQUIT)
QUIT
IF NURPLSW
IF '$GET(NURSUMSW)
DO PSUBTL^NURAGEN1
IF NURQUIT
QUIT
+1 QUIT
P0 SET NPC2=""
FOR
SET NPC2=$ORDER(^TMP($JOB,"L",NURFAC,NURPROG,NPC2))
IF NPC2=""
QUIT
DO P1
IF NURQUIT
QUIT
IF '$GET(NURSUMSW)
IF $GET(NURPLSW)
DO HEADER
IF NURQUIT
QUIT
+1 QUIT
P1 SET NPC3=""
FOR
SET NPC3=$ORDER(^TMP($JOB,"L",NURFAC,NURPROG,NPC2,NPC3))
IF NPC3=""
QUIT
IF NURSLEV=3
SET NPC1=0
DO P2
IF NURQUIT
QUIT
+1 QUIT
P2 SET NPC4=""
FOR
SET NPC4=$ORDER(^TMP($JOB,"L",NURFAC,NURPROG,NPC2,NPC3,NPC4))
IF NPC4=""
QUIT
IF NURSLEV=4
SET NPC1=0
SET NURSORT=$GET(^TMP($JOB,"L",NURFAC,NURPROG,NPC2,NPC3,NPC4))
IF NURSORT
DO P3
IF NURQUIT
QUIT
+1 QUIT
P3 SET NPC5=""
FOR
SET NPC5=$ORDER(^TMP($JOB,"L1",NURSORT,NPC5))
IF NPC5=""
QUIT
IF NURSLEV=5
SET NPC1=0
IF NURSLEV>3
DO P4
IF NURQUIT
QUIT
IF NURSLEV=3
DO PRINT1
+1 QUIT
P4 SET NPC6=""
FOR
SET NPC6=$ORDER(^TMP($JOB,"L1",NURSORT,NPC5,NPC6))
IF NPC6=""
QUIT
IF NURSLEV=6
SET NPC1=0
IF NURSLEV>4
DO P5
IF NURQUIT
QUIT
IF NURSLEV=4
DO PRINT1
+1 QUIT
P5 SET NPC7=""
FOR
SET NPC7=$ORDER(^TMP($JOB,"L1",NURSORT,NPC5,NPC6,NPC7))
IF NPC7=""
QUIT
IF NURSLEV>5
DO P6
IF NURQUIT
QUIT
IF NURSLEV=5
DO PRINT1
+1 QUIT
P6 IF NURSLEV<7
SET NPC8=""
FOR
SET NPC8=$ORDER(^TMP($JOB,"L1",NURSORT,NPC5,NPC6,NPC7,NPC8))
IF NPC8=""!NURQUIT
QUIT
DO PRINT1
+1 QUIT
+2 ; DETAIL LINE PRINT ROUTINE
PRINT1 IF ($Y>(IOSL-6))
DO HEADER
IF NURQUIT
QUIT
+1 DO ENT1^NURAGEN1
+2 SET NURSW1=1
IF NPC1=0&'($GET(NURSUMSW))
WRITE !
SET NPC1=NPC1+1
IF NURROU=2!(NURROU=6)!(NURROU=10)!(NURROU=12)!(NURROU=16)!(NURROU=20)
DO PRI4
QUIT
+3 IF (NURROU>0&(NURROU<7))!(NURROU=9)!(NURROU=10)
DO PRI1
IF (NURROU=7)!(NURROU=8)!(NURROU=17)
DO PRI2
IF (NURROU>10&(NURROU<17))!(NURROU>18&(NURROU<21))
DO PRI3
IF NURROU=18
DO PRI5
+4 QUIT
PRI1 WRITE !,NPC1,?6,$EXTRACT(NPR2,1,10),?17,$EXTRACT(NPR3,1,10),?28,$EXTRACT(NPR5,1,20),?52,NPR4
+1 QUIT
PRI2 IF NURROU=7!(NURROU=8)
WRITE !,NPC1,?6,$EXTRACT(NPR2,1,10),?17,NPR3,?28,$EXTRACT(NPR6,1,20),?50,NPR4,?65,NPR5
QUIT
+1 IF '$GET(NURSUMSW)
WRITE !,NPC1,?6,$EXTRACT(NPR2,1,10),?17,$EXTRACT(NPR5,1,20),?40,NPR3,?59,NPR4
+2 QUIT
PRI3 ;ROU= 11 - 16
IF '$GET(NURSUMSW)
WRITE !,NPC1,?10,$EXTRACT(NPR2,1,10),?23,$EXTRACT(NPR4,1,20),?49,NPR3
+1 QUIT
PRI4 IF NURROU=2!(NURROU=6)!(NURROU=10)
WRITE !,NPC1,?6,$SELECT(NPC2'=" BLANK":$EXTRACT(NPC2,1,10),1:""),?17,$SELECT(NPC4'=" BLANK":NPC4,1:""),?28,$SELECT(NPC6'=" BLANK":$EXTRACT(NPC6,1,20),1:""),?52,$SELECT(NPC5'=" BLANK":NPC5,1:"")
QUIT
+1 IF '$GET(NURSUMSW)
WRITE !,NPC1,?6,$SELECT(NPC3'=" BLANK":$EXTRACT(NPC3,1,10),1:""),?17,$SELECT(NPC5'=" BLANK":$EXTRACT(NPC5,1,20),1:""),?48,$SELECT(NPC4'=" BLANK":NPC4,1:"")
+2 QUIT
PRI5 ;6H2
IF '$GET(NURSUMSW)
WRITE !,NPC1,?6,$EXTRACT(NPR2,1,10),?17,$EXTRACT(NPR5,1,20),?45,NPR3,?61,NPR4
+1 QUIT
+1 SET NX=""
IF (NURROU=12!(NURROU=14)!(NURROU=16)!(NURROU=18)!(NURROU=20))
IF 'NURMDSW
IF 'NURQUEUE
IF $EXTRACT(IOST)="C"
IF NURSW1
IF $Y<(IOSL-6)
GOTO NEXT1
+2 IF 'NURQUEUE
IF $EXTRACT(IOST)="C"
IF NURSW1
DO ENDPG
IF $GET(NURQUIT)
QUIT
NEXT1 IF (NURROU=12!(NURROU=14)!(NURROU=16)!(NURROU=18)!(NURROU=20))
IF 'NURMDSW
IF $Y<(IOSL-6)
IF NURSW1
GOTO NEXTL
+1 SET NURPAGE=NURPAGE+1
IF $EXTRACT(IOST)="C"!(NURPAGE>1)
WRITE @IOF
+2 IF NURMDSW
IF '$GET(NURSUMSW)
IF $LENGTH($GET(NURFAC))>1
WRITE ?$$CNTR^NURSUT2(NURFAC),$$FACL^NURSUT2($GET(NURFAC))
+3 WRITE !,NURSTIL
SET X="T"
DO ^%DT
IF +Y
DO D^DIQ
WRITE ?56,Y,?72,"PAGE: ",NURPAGE
+4 WRITE !!,NURSTIL1,!,NURSTIL2,!,$$REPEAT^XLFSTR("-",80)
IF 'NURSW1
QUIT
PROD IF $GET(NURPLSW)
IF $LENGTH(NURPROG)>1
IF '$GET(NURSUMSW)
NEW Z
SET Z=$$PROD^NURSUT2($GET(NURPROG))
IF $GET(Z)'=""
WRITE !!,?$$CNTR^NURSUT2(NURPROG),$GET(Z),!,?$$CNTR^NURSUT2(NURPROG),$$REPEAT^XLFSTR("-",$LENGTH(Z)+1)
NEXTL IF NX="T"
SET NURQUIT=1
+1 QUIT
NODATA ;
+1 IF $ORDER(^TMP($JOB,""))=""
IF '$DATA(NURSNLOC)
SET NUROUT=1
SET NURPROG=$SELECT($GET(NURPROG)=0:NURPROG(1),1:"")
SET NURFAC=$SELECT($GET(NURFAC)=0:NURFAC(1),1:"")
DO HEADER
WRITE !!,"THERE IS NO DATA FOR THIS REPORT"
+2 IF $ORDER(^TMP($JOB,""))=""
IF $DATA(NURSNLOC)
SET NUROUT=1
SET NURPROG=$SELECT($GET(NURPROG)=0:NURPROG(1),1:"")
SET NURFAC=$SELECT($GET(NURFAC)=0:NURFAC(1),1:"")
DO HEADER
SET NL1=""
FOR
SET NL1=$ORDER(NURSNLOC(NL1))
IF NL1=""
QUIT
DO NODATA^NURSUT1
+3 IF $ORDER(^TMP($JOB,""))'=""
IF $DATA(NURSNLOC)
Begin DoDot:1
+4 SET (NURY,NURZ,NURX)=""
FOR
SET NURY=$ORDER(^TMP($JOB,"L",NURY))
IF NURY=""
QUIT
FOR
SET NURZ=$ORDER(^TMP($JOB,"L",NURY,NURZ))
IF NURZ=""
QUIT
FOR
SET NURX=$ORDER(^TMP($JOB,"L",NURY,NURZ,NURX))
IF NURX=""
QUIT
SET ^TMP("NURLOC",$JOB,NURX)=""
+5 SET NL1=""
FOR
SET NL1=$ORDER(NURSNLOC(NL1))
IF NL1=""
QUIT
IF '$DATA(^TMP("NURLOC",$JOB,NL1))
Begin DoDot:2
+6 SET NURPROG=$SELECT($GET(NURPROG)=0:NURPROG(1),1:"")
SET NURFAC=$SELECT($GET(NURFAC)=0:NURFAC(1),1:"")
IF NURSW1=0
DO HEADER
SET NURSW1=1
DO NODATA^NURSUT1
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
IF NURSW1=1
DO ENDPG^NURSUT1
SET NURSW1=0
+9 QUIT
CLOSE ; CLOSE DEVICE
+1 WRITE !
IF '$GET(NURQUIT)
DO ENDPG
+2 DO ^%ZISC
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 QUIT
ENDPG ; HANDLE EOP
+1 IF $EXTRACT(IOST)'="C"!($GET(NURQUIT))
QUIT
+2 WRITE $CHAR(7),!!,"Press return to continue, ""T"" for totals, or ""^"" to exit: "
READ NX:DTIME
+3 SET NX=$$UP^XLFSTR(NX)
+4 IF '$TEST!(NX=U)
SET (NURQUIT,NUROUT)=1
+5 QUIT
