NURAGE ;HIRMFO/RM/MD,FT-PRINT MODULE FOR AGE PROFILE REPORT ;2/27/98 14:21
;;4.0;NURSING SERVICE;**9,13**;Apr 25, 1997
S XAGE=$S(NURDOB'="BLANK":$E(DT,1,3)-$E(NURDOB,1,3)-($E(DT,4,7)<$E(NURDOB,4,7)),1:0)
I 'NURSW1!($Y>(IOSL-9)) D HDGING,HDGBYP Q:NURQUIT
BGNCALC ;
I ((XAGE>17)&(XAGE<21)) S NURSI=1 D SUB S NHIT=38 G NURSBYP
I ((XAGE>20)&(XAGE<30)) S NURSI=2 D SUB S NHIT=44 G NURSBYP
I ((XAGE>29)&(XAGE<40)) S NURSI=3 D SUB S NHIT=50 G NURSBYP
I ((XAGE>39)&(XAGE<50)) S NURSI=4 D SUB S NHIT=56 G NURSBYP
I ((XAGE>49)&(XAGE<60)) S NURSI=5 D SUB S NHIT=62 G NURSBYP
I ((XAGE>59)&(XAGE<70)) S NURSI=6 D SUB S NHIT=68 G NURSBYP
I (XAGE>69) S NURSI=7 D SUB S NHIT=74 G NURSBYP
I '+XAGE S NURSI=8 D SUB S NHIT=32 G NURSBYP
Q
SUB ;
S NURSOLD(NURSI)=NURSOLD(NURSI)+1
I AN<5 S NURSORT(1)=$G(@("^TMP($J,""L"",NURFAC,NURSPROG,"_$S(NSEL["W":"NURNL1,",1:"")_$S(NSEL["C":"NCATPOS,",1:"NPRI,NCATPOS)")_$S(NSEL["C":"NURDOB)",1:""))) I NURSORT(1) D
.I NSEL["C" F X=0:0 S X=$O(^TMP($J,"L1",NURSORT(1),NURN1,DA,X)) Q:X'>0 S Y=0 F S Y=$O(^TMP($J,"L1",NURSORT(1),NURN1,DA,X,Y)) Q:Y'>0 S ^TMP("NURA",$J,NURSI,DA,X_"-"_Y)=""
.E F X=0:0 S X=$O(^TMP($J,"L1",NURSORT(1),NURDOB,NURN1,DA,X)) Q:X'>0 S ^TMP("NURA",$J,NURSI,DA,X_"-"_NCATPOS)=""
I AN=5 S NURSORT(1)=^TMP($J,"L",NURFAC,NURSPROG,NCATPOS,NURDOB,NURN1) I NURSORT(1) F X=0:0 S X=$O(^TMP($J,"L1",NURSORT(1),DA,X)) Q:X'>0 S Y=0 F S Y=$O(^TMP($J,"L1",NURSORT(1),DA,X,Y)) Q:Y'>0 S ^TMP("NURA",$J,NURSI,DA,X_"-"_Y)=""
I AN=6 S NURSORT(1)=^TMP($J,"L",NURFAC,NURSPROG,NPRI,NCATPOS,NURDOB) I NURSORT(1) F X=0:0 S X=$O(^TMP($J,"L1",NURSORT(1),NURN1,DA,X)) Q:X'>0 S ^TMP("NURA",$J,NURSI,DA,X_"-"_NCATPOS)=""
Q
NURSBYP ;
Q:$G(NURSUMSW) I $Y>(IOSL-9) D HDGING Q:NURQUIT
W !,$E(NURN1,1,20),?NHIT,"X"
Q
WRTCAT ;
W:'$G(NURSUMSW) !!,?18,"SUB-TOTAL:",?(33-$L(NURSOLD(8))),NURSOLD(8),?(39-$L(NURSOLD(1))),NURSOLD(1),?(45-$L(NURSOLD(2))),NURSOLD(2),?(51-$L(NURSOLD(3))),NURSOLD(3),?(57-$L(NURSOLD(4))),NURSOLD(4),?(63-$L(NURSOLD(5))),NURSOLD(5)
W:'$G(NURSUMSW) ?(69-$L(NURSOLD(6))),NURSOLD(6),?(75-$L(NURSOLD(7))),NURSOLD(7)
F I=1:1:8 S NURSWOLD(I)=NURSWOLD(I)+NURSOLD(I),NURSMOLD(I)=NURSMOLD(I)+NURSOLD(I),NURSPOLD(I)=NURSPOLD(I)+NURSOLD(I),NURSOLD(I)=0
Q
WRTWARD ;
W:'$G(NURSUMSW) !!,?13,"WARD SUB-TOTAL:",?(33-$L(NURSWOLD(8))),NURSWOLD(8),?(39-$L(NURSWOLD(1))),NURSWOLD(1),?(45-$L(NURSWOLD(2))),NURSWOLD(2),?(51-$L(NURSWOLD(3))),NURSWOLD(3),?(57-$L(NURSWOLD(4))),NURSWOLD(4),?(63-$L(NURSWOLD(5))),NURSWOLD(5)
W:'$G(NURSUMSW) ?(69-$L(NURSWOLD(6))),NURSWOLD(6),?(75-$L(NURSWOLD(7))),NURSWOLD(7)
F I=1:1:8 S NURSFOLD(I)=NURSFOLD(I)+NURSWOLD(I),NURSWOLD(I)=0
Q
PSUBTL ; PRODUCT LINE SUBTOTALS
S X=$E($$PROD^NURSUT2(NURSPROG),1,16) W !!,?(17-$L(X)),X,?18,"SUB-TOTAL:"
W ?(33-$L(NURSPOLD(8))),NURSPOLD(8),?(39-$L(NURSPOLD(1))),NURSPOLD(1),?(45-$L(NURSPOLD(2))),NURSPOLD(2),?(51-$L(NURSPOLD(3))),NURSPOLD(3),?(57-$L(NURSPOLD(4))),NURSPOLD(4),?(63-$L(NURSPOLD(5))),NURSPOLD(5)
W ?(69-$L(NURSPOLD(6))),NURSPOLD(6),?(75-$L(NURSPOLD(7))),NURSPOLD(7)
F I=1:1:8 S NURSPOLD(I)=0
Q
FSUBTL ; FACILITY SUBTOTALS
W !!,?(17-$L(NURFAC)),$E($$FACL^NURSUT2(NURFAC),1,16),?18,"SUB-TOTAL:"
W ?(33-$L(NURSMOLD(8))),NURSMOLD(8),?(39-$L(NURSMOLD(1))),NURSMOLD(1),?(45-$L(NURSMOLD(2))),NURSMOLD(2),?(51-$L(NURSMOLD(3))),NURSMOLD(3),?(57-$L(NURSMOLD(4))),NURSMOLD(4),?(63-$L(NURSMOLD(5))),NURSMOLD(5)
W ?(69-$L(NURSMOLD(6))),NURSMOLD(6),?(75-$L(NURSMOLD(7))),NURSMOLD(7)
F I=1:1:8 S NURSMOLD(I)=0
Q
HDGING ; HEADINGS
I 'NURQUEUE,NURSW1,$E(IOST)="C" D ENDPG Q:NURQUIT
S:'NURSW1 NURSW1=1
W:'($E(IOST)="P"&(NURPAGE=0)) @IOF S NURPAGE=NURPAGE+1
I NURMDSW,$L(NURFAC)>1,'$G(NURSUMSW),$G(NURFAC)'=" BLANK" W !?$$CNTR^NURSUT2(NURFAC),$$FACL^NURSUT2(NURFAC)
W !,"NURSING SERVICE AGE PROFILE BY " W $S(NSEL["W":"LOCATION/SVC ",1:"SERVICE "),$S(NSEL["C":"CATEGORY",NSEL["S":"POSITION",1:"") S Y=DT X ^DD("DD") W " ",Y," PAGE: ",NURPAGE
W !!,"NAME",?29,"NO DOB",?36,"18-20",?42,"21-29",?48,"30-39",?54,"40-49",?60,"50-59",?66,"60-69",?73,"70+"
W !,$$REPEAT^XLFSTR("-",80) S NURSW1(1)=1
I $G(NURPLSW),$L(NURSPROG)>1,'$G(NURSUMSW),$G(NURSPROG)'=" BLANK" N Z S Z=$$PROD^NURSUT2(NURSPROG) W !,?$$CNTR^NURSUT2(Z),$G(Z),!,?$$CNTR^NURSUT2(Z),$$REPEAT^XLFSTR("-",$L(Z)+1)
I NSEL["W",$G(NURNL1)'="" W:$D(^TMP($J,"L",NURFAC,NURSPROG,$G(NURNL1))) !!,?16,"WARD LOCATION: ",NURNL1
Q
HDGBYP ;
Q:$G(NURSUMSW) I ($Y>(IOSL-9)) D HDGING Q:NURQUIT
W !!,?20,"SERVICE " W:(NSEL["C") "CATEGORY: ",$$CAT^NURSUT2(NCATPOS) W:(NSEL["S") "POSITION: ",NCATPOS W ! S NURSCAT=NCATPOS
Q
FINCAT ; SELECT SVC CATEGORY
W !!!,?4,"ASSIGNMENTS FINAL TOTAL:"
F X=1:1:8 S (NURSFOLD(X),NURSWOLD(X))=0 F Y=0:0 S Y=$O(^TMP("NURA",$J,X,Y)) Q:Y'>0 S NURSWOLD(X)=NURSWOLD(X)+1 S Z="" F S Z=$O(^TMP("NURA",$J,X,Y,Z)) Q:Z="" S NURSFOLD(X)=NURSFOLD(X)+1
D PRTOT F X=1:1:8 S NURSFOLD(X)=NURSWOLD(X)
W !!,?6,"PERSONNEL FINAL TOTAL:" D PRTOT
I NURQUIT,$E(IOST)="C" S X="" W !!,"Enter RETURN to continue " R X:DTIME
Q
PRTOT W ?(33-$L(NURSFOLD(8))),NURSFOLD(8),?(39-$L(NURSFOLD(1))),NURSFOLD(1),?(45-$L(NURSFOLD(2))),NURSFOLD(2),?(51-$L(NURSFOLD(3))),NURSFOLD(3),?(57-$L(NURSFOLD(4))),NURSFOLD(4)
W ?(63-$L(NURSFOLD(5))),NURSFOLD(5),?(69-$L(NURSFOLD(6))),NURSFOLD(6),?(75-$L(NURSFOLD(7))),NURSFOLD(7)
Q
ENDPG ; HANDLE EOP
I $E(IOST)'="C"!($G(NURQUIT)) Q
W $C(7),!!,"Press return to continue, or ""^"" to exit: " R NX:DTIME I '$T!(NX="^") S (NURQUIT,NUROUT)=1 Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURAGE 5446 printed Dec 13, 2024@02:19:21 Page 2
NURAGE ;HIRMFO/RM/MD,FT-PRINT MODULE FOR AGE PROFILE REPORT ;2/27/98 14:21
+1 ;;4.0;NURSING SERVICE;**9,13**;Apr 25, 1997
+2 SET XAGE=$SELECT(NURDOB'="BLANK":$EXTRACT(DT,1,3)-$EXTRACT(NURDOB,1,3)-($EXTRACT(DT,4,7)<$EXTRACT(NURDOB,4,7)),1:0)
+3 IF 'NURSW1!($Y>(IOSL-9))
DO HDGING
DO HDGBYP
if NURQUIT
QUIT
BGNCALC ;
+1 IF ((XAGE>17)&(XAGE<21))
SET NURSI=1
DO SUB
SET NHIT=38
GOTO NURSBYP
+2 IF ((XAGE>20)&(XAGE<30))
SET NURSI=2
DO SUB
SET NHIT=44
GOTO NURSBYP
+3 IF ((XAGE>29)&(XAGE<40))
SET NURSI=3
DO SUB
SET NHIT=50
GOTO NURSBYP
+4 IF ((XAGE>39)&(XAGE<50))
SET NURSI=4
DO SUB
SET NHIT=56
GOTO NURSBYP
+5 IF ((XAGE>49)&(XAGE<60))
SET NURSI=5
DO SUB
SET NHIT=62
GOTO NURSBYP
+6 IF ((XAGE>59)&(XAGE<70))
SET NURSI=6
DO SUB
SET NHIT=68
GOTO NURSBYP
+7 IF (XAGE>69)
SET NURSI=7
DO SUB
SET NHIT=74
GOTO NURSBYP
+8 IF '+XAGE
SET NURSI=8
DO SUB
SET NHIT=32
GOTO NURSBYP
+9 QUIT
SUB ;
+1 SET NURSOLD(NURSI)=NURSOLD(NURSI)+1
+2 IF AN<5
SET NURSORT(1)=$GET(@("^TMP($J,""L"",NURFAC,NURSPROG,"_$SELECT(NSEL["W":"NURNL1,",1:"")_$SELECT(NSEL["C":"NCATPOS,",1:"NPRI,NCATPOS)")_$SELECT(NSEL["C":"NURDOB)",1:"")))
IF NURSORT(1)
Begin DoDot:1
+3 IF NSEL["C"
FOR X=0:0
SET X=$ORDER(^TMP($JOB,"L1",NURSORT(1),NURN1,DA,X))
if X'>0
QUIT
SET Y=0
FOR
SET Y=$ORDER(^TMP($JOB,"L1",NURSORT(1),NURN1,DA,X,Y))
if Y'>0
QUIT
SET ^TMP("NURA",$JOB,NURSI,DA,X_"-"_Y)=""
+4 IF '$TEST
FOR X=0:0
SET X=$ORDER(^TMP($JOB,"L1",NURSORT(1),NURDOB,NURN1,DA,X))
if X'>0
QUIT
SET ^TMP("NURA",$JOB,NURSI,DA,X_"-"_NCATPOS)=""
End DoDot:1
+5 IF AN=5
SET NURSORT(1)=^TMP($JOB,"L",NURFAC,NURSPROG,NCATPOS,NURDOB,NURN1)
IF NURSORT(1)
FOR X=0:0
SET X=$ORDER(^TMP($JOB,"L1",NURSORT(1),DA,X))
if X'>0
QUIT
SET Y=0
FOR
SET Y=$ORDER(^TMP($JOB,"L1",NURSORT(1),DA,X,Y))
if Y'>0
QUIT
SET ^TMP("NURA",$JOB,NURSI,DA,X_"-"_Y)=""
+6 IF AN=6
SET NURSORT(1)=^TMP($JOB,"L",NURFAC,NURSPROG,NPRI,NCATPOS,NURDOB)
IF NURSORT(1)
FOR X=0:0
SET X=$ORDER(^TMP($JOB,"L1",NURSORT(1),NURN1,DA,X))
if X'>0
QUIT
SET ^TMP("NURA",$JOB,NURSI,DA,X_"-"_NCATPOS)=""
+7 QUIT
NURSBYP ;
+1 if $GET(NURSUMSW)
QUIT
IF $Y>(IOSL-9)
DO HDGING
if NURQUIT
QUIT
+2 WRITE !,$EXTRACT(NURN1,1,20),?NHIT,"X"
+3 QUIT
WRTCAT ;
+1 if '$GET(NURSUMSW)
WRITE !!,?18,"SUB-TOTAL:",?(33-$LENGTH(NURSOLD(8))),NURSOLD(8),?(39-$LENGTH(NURSOLD(1))),NURSOLD(1),?(45-$LENGTH(NURSOLD(2))),NURSOLD(2),?(51-$LENGTH(NURSOLD(3))),NURSOLD(3),?(57-$LENGTH(NURSOLD(4))),NURSOLD(4),?(63-$LENGTH(NURSOLD(5))),NUR
SOLD(5)
+2 if '$GET(NURSUMSW)
WRITE ?(69-$LENGTH(NURSOLD(6))),NURSOLD(6),?(75-$LENGTH(NURSOLD(7))),NURSOLD(7)
+3 FOR I=1:1:8
SET NURSWOLD(I)=NURSWOLD(I)+NURSOLD(I)
SET NURSMOLD(I)=NURSMOLD(I)+NURSOLD(I)
SET NURSPOLD(I)=NURSPOLD(I)+NURSOLD(I)
SET NURSOLD(I)=0
+4 QUIT
WRTWARD ;
+1 if '$GET(NURSUMSW)
WRITE !!,?13,"WARD SUB-TOTAL:",?(33-$LENGTH(NURSWOLD(8))),NURSWOLD(8),?(39-$LENGTH(NURSWOLD(1))),NURSWOLD(1),?(45-$LENGTH(NURSWOLD(2))),NURSWOLD(2),?(51-$LENGTH(NURSWOLD(3))),NURSWOLD(3),?(57-...
... $LENGTH(NURSWOLD(4))),NURSWOLD(4),?(63-$LENGTH(NURSWOLD(5))),NURSWOLD(5)
+2 if '$GET(NURSUMSW)
WRITE ?(69-$LENGTH(NURSWOLD(6))),NURSWOLD(6),?(75-$LENGTH(NURSWOLD(7))),NURSWOLD(7)
+3 FOR I=1:1:8
SET NURSFOLD(I)=NURSFOLD(I)+NURSWOLD(I)
SET NURSWOLD(I)=0
+4 QUIT
PSUBTL ; PRODUCT LINE SUBTOTALS
+1 SET X=$EXTRACT($$PROD^NURSUT2(NURSPROG),1,16)
WRITE !!,?(17-$LENGTH(X)),X,?18,"SUB-TOTAL:"
+2 WRITE ?(33-$LENGTH(NURSPOLD(8))),NURSPOLD(8),?(39-$LENGTH(NURSPOLD(1))),NURSPOLD(1),?(45-$LENGTH(NURSPOLD(2))),NURSPOLD(2),?(51-$LENGTH(NURSPOLD(3))),NURSPOLD(3),?(57-$LENGTH(NURSPOLD(4))),NURSPOLD(4),?(63-$LENGTH(NURSPOLD(5))),NURSPOLD(5)
+3 WRITE ?(69-$LENGTH(NURSPOLD(6))),NURSPOLD(6),?(75-$LENGTH(NURSPOLD(7))),NURSPOLD(7)
+4 FOR I=1:1:8
SET NURSPOLD(I)=0
+5 QUIT
FSUBTL ; FACILITY SUBTOTALS
+1 WRITE !!,?(17-$LENGTH(NURFAC)),$EXTRACT($$FACL^NURSUT2(NURFAC),1,16),?18,"SUB-TOTAL:"
+2 WRITE ?(33-$LENGTH(NURSMOLD(8))),NURSMOLD(8),?(39-$LENGTH(NURSMOLD(1))),NURSMOLD(1),?(45-$LENGTH(NURSMOLD(2))),NURSMOLD(2),?(51-$LENGTH(NURSMOLD(3))),NURSMOLD(3),?(57-$LENGTH(NURSMOLD(4))),NURSMOLD(4),?(63-$LENGTH(NURSMOLD(5))),NURSMOLD(5)
+3 WRITE ?(69-$LENGTH(NURSMOLD(6))),NURSMOLD(6),?(75-$LENGTH(NURSMOLD(7))),NURSMOLD(7)
+4 FOR I=1:1:8
SET NURSMOLD(I)=0
+5 QUIT
HDGING ; HEADINGS
+1 IF 'NURQUEUE
IF NURSW1
IF $EXTRACT(IOST)="C"
DO ENDPG
if NURQUIT
QUIT
+2 if 'NURSW1
SET NURSW1=1
+3 if '($EXTRACT(IOST)="P"&(NURPAGE=0))
WRITE @IOF
SET NURPAGE=NURPAGE+1
+4 IF NURMDSW
IF $LENGTH(NURFAC)>1
IF '$GET(NURSUMSW)
IF $GET(NURFAC)'=" BLANK"
WRITE !?$$CNTR^NURSUT2(NURFAC),$$FACL^NURSUT2(NURFAC)
+5 WRITE !,"NURSING SERVICE AGE PROFILE BY "
WRITE $SELECT(NSEL["W":"LOCATION/SVC ",1:"SERVICE "),$SELECT(NSEL["C":"CATEGORY",NSEL["S":"POSITION",1:"")
SET Y=DT
XECUTE ^DD("DD")
WRITE " ",Y," PAGE: ",NURPAGE
+6 WRITE !!,"NAME",?29,"NO DOB",?36,"18-20",?42,"21-29",?48,"30-39",?54,"40-49",?60,"50-59",?66,"60-69",?73,"70+"
+7 WRITE !,$$REPEAT^XLFSTR("-",80)
SET NURSW1(1)=1
+8 IF $GET(NURPLSW)
IF $LENGTH(NURSPROG)>1
IF '$GET(NURSUMSW)
IF $GET(NURSPROG)'=" BLANK"
NEW Z
SET Z=$$PROD^NURSUT2(NURSPROG)
WRITE !,?$$CNTR^NURSUT2(Z),$GET(Z),!,?$$CNTR^NURSUT2(Z),$$REPEAT^XLFSTR("-",$LENGTH(Z)+1)
+9 IF NSEL["W"
IF $GET(NURNL1)'=""
if $DATA(^TMP($JOB,"L",NURFAC,NURSPROG,$GET(NURNL1)))
WRITE !!,?16,"WARD LOCATION: ",NURNL1
+10 QUIT
HDGBYP ;
+1 if $GET(NURSUMSW)
QUIT
IF ($Y>(IOSL-9))
DO HDGING
if NURQUIT
QUIT
+2 WRITE !!,?20,"SERVICE "
if (NSEL["C")
WRITE "CATEGORY: ",$$CAT^NURSUT2(NCATPOS)
if (NSEL["S")
WRITE "POSITION: ",NCATPOS
WRITE !
SET NURSCAT=NCATPOS
+3 QUIT
FINCAT ; SELECT SVC CATEGORY
+1 WRITE !!!,?4,"ASSIGNMENTS FINAL TOTAL:"
+2 FOR X=1:1:8
SET (NURSFOLD(X),NURSWOLD(X))=0
FOR Y=0:0
SET Y=$ORDER(^TMP("NURA",$JOB,X,Y))
if Y'>0
QUIT
SET NURSWOLD(X)=NURSWOLD(X)+1
SET Z=""
FOR
SET Z=$ORDER(^TMP("NURA",$JOB,X,Y,Z))
if Z=""
QUIT
SET NURSFOLD(X)=NURSFOLD(X)+1
+3 DO PRTOT
FOR X=1:1:8
SET NURSFOLD(X)=NURSWOLD(X)
+4 WRITE !!,?6,"PERSONNEL FINAL TOTAL:"
DO PRTOT
+5 IF NURQUIT
IF $EXTRACT(IOST)="C"
SET X=""
WRITE !!,"Enter RETURN to continue "
READ X:DTIME
+6 QUIT
PRTOT WRITE ?(33-$LENGTH(NURSFOLD(8))),NURSFOLD(8),?(39-$LENGTH(NURSFOLD(1))),NURSFOLD(1),?(45-$LENGTH(NURSFOLD(2))),NURSFOLD(2),?(51-$LENGTH(NURSFOLD(3))),NURSFOLD(3),?(57-$LENGTH(NURSFOLD(4))),NURSFOLD(4)
+1 WRITE ?(63-$LENGTH(NURSFOLD(5))),NURSFOLD(5),?(69-$LENGTH(NURSFOLD(6))),NURSFOLD(6),?(75-$LENGTH(NURSFOLD(7))),NURSFOLD(7)
+2 QUIT
ENDPG ; HANDLE EOP
+1 IF $EXTRACT(IOST)'="C"!($GET(NURQUIT))
QUIT
+2 WRITE $CHAR(7),!!,"Press return to continue, or ""^"" to exit: "
READ NX:DTIME
IF '$TEST!(NX="^")
SET (NURQUIT,NUROUT)=1
QUIT
+3 QUIT
