- 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
- 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
