- NURSCPLC ;HIRMFO/RM,FT,MD-PATIENT CENSUS...WARD, AND HOSPITAL ;12/14/98
- ;;4.0;NURSING SERVICE;**20,22,44**;Apr 25, 1997;Build 3
- EN2 ; ENTRY FOR WARD PATIENT CENSUS
- Q:'$D(^DIC(213.9,1,"OFF")) Q:$P(^DIC(213.9,1,"OFF"),"^",1)=1
- S (NURSZAP,NURPLSW,NURMDSW,NURQUIT,NURQUEUE)=0
- D EN9^NURSAGSP
- I NURMDSW S DIC(0)="AEMQZ",NURPLSCR=1 D EN5^NURSAGSP K NURPLSCR I $G(NUROUT) G QUIT
- I NURMDSW=0,NURPLSW=1 S NURPLCSR=1 D PRD^NURSAGSP K NURPLSCR I $G(NUROUT) G QUIT
- W ! D EN1^NURSAGSP G:$G(NUROUT) QUIT
- W ! D EN6^NURSUT0 I $G(NURQUIT) S NUROUT=1 G QUIT
- W ! S ZTDESC="Nursing Patient Census",ZTRTN="START^NURSCPLC" D EN7^NURSUT0 G:POP!($D(ZTSK)) QUIT
- START ;
- U IO S (NURSW1,NURPAGE,NUROUT)=0 K ^TMP($J)
- I NURHOSP S NURIEN=0 F S NURIEN=$O(^NURSF(214,"AF","A",NURIEN)) Q:NURIEN'>0 S DFN="" F S DFN=$O(^NURSF(214,"AF","A",NURIEN,DFN)) Q:DFN'>0 S NPWARD=NURIEN D EN6^NURSAUTL S NURSWARD=$E(NPWARD,1,20) W:$E(IOST)="C"&($R(100)) "." D SORT
- E S NURSWARD="" F S NURSWARD=$O(NURSNLOC(NURSWARD)) Q:NURSWARD="" S NURIEN=0 F S NURIEN=$O(NURSNLOC(NURSWARD,NURIEN)) Q:NURIEN'>0 S DFN=0 F S DFN=$O(^NURSF(214,"AF","A",NURIEN,DFN)) Q:DFN'>0 W:$E(IOST)="C"&($R(100)) "." D SORT
- I $E(IOST)="P" F NURI=1:1 Q:NURI>NCOPY D PRINT S (NURPAGE,NURSW1)=0 W:$G(NCOPY)>1 @IOF
- I $E(IOST)="C" D PRINT
- QUIT ; KILL LOCAL VARIABLES
- D CLOSE^NURSUT1,^NURSKILL
- Q
- SORT ; SORT OF PATIENT CENSUS
- S NURFAC(2)=$S($$EN12^NURSUT3(NURIEN)'="":$$EN12^NURSUT3(NURIEN),1:" BLANK")
- S NURPROG(4)=+$P(^NURSF(211.4,+NURIEN,1),U,4),NURPROG(4)=$$GET1^DIQ(212.7,+NURPROG(4),.01,"I") S:NURPROG(4)="" NURPROG(4)=" BLANK"
- I NURMDSW,$G(NURFAC)=0,NURFAC(2)'=NURFAC(1) Q
- I NURPLSW,$G(NURPROG)=0,NURPROG(4)'=NURPROG(1) Q
- D 1^VADPT
- S NBED=$S(VAIN(5)="":" BLANK",1:VAIN(5)),N1=$S(VADM(1)="":" BLANK",1:VADM(1))
- S:$G(NURSORT)="" NURSORT=1
- N X S X=$G(^TMP($J,"L",NURFAC(2),NURPROG(4),NURSWARD))
- I X="" S X=NURSORT,NURSORT=NURSORT+1,^TMP($J,"L",NURFAC(2),NURPROG(4),NURSWARD)=X,^TMP($J,"NURLOC",NURSWARD)=""
- S ^TMP($J,"L1",X,NBED,N1,DFN)=$S(N1=" BLANK":" ",'$D(^DPT(DFN,.109)):" ",^DPT(DFN,.109)=0:" ",1:"! ")
- K VAIN,VADM Q
- I 'NURQUEUE,NURSW1,$E(IOST)="C" D ENDPG^NURSUT1 Q:NUROUT
- S NURSHD="PATIENT CENSUS"_$S($D(^TMP($J,"NURLOC",NL1)):" FOR "_$E(NL1,1,12),1:"")
- S NURSW1=1
- S NURPAGE=NURPAGE+1 W:$E(IOST)="C"!(NURPAGE>1) @IOF
- I NURMDSW,$G(NURHOSP) W !,?$$CNTR^NURSUT2($G(NURFAC(2))),$S($G(NURFAC(2))=" BLANK":"NO FACILITY",1:$G(NURFAC(2)))
- W !,$E(DT,4,5),"/",$E(DT,6,7),"/",$E(DT,2,3),?28,NURSHD,?68,"PAGE: ",NURPAGE,!
- W !,"ROOM/BED",?17,"PATIENT NAME",?40,"Last 4",?55,"ABSENCE",?64,"BED SEC",?73,"ACUITY"
- W !,$$REPEAT^XLFSTR("-",80),!
- PROD I NURPLSW,$G(NURPROG(4))'=" BLANK" W !?$$CNTR^NURSUT2(NURPROG(4)),$S($E(NURPROG(4),1)=" ":$E(NURPROG(4),2,99),1:$G(NURPROG(4))) W !,?$$CNTR^NURSUT2(NURPROG(4)),$$REPEAT^XLFSTR("-",$L(NURPROG(4))+1),!
- Q
- PRINT ;PRINT ROUTINE
- I $O(^TMP($J,""))="",'$D(NURSNLOC) S NL1="THE HOSPITAL",NURPROG(4)=$S($G(NURPROG)=0:NURPROG(1),1:" BLANK"),NURFAC(2)=$S($G(NURFAC)=0:NURFAC(1),1:" BLANK") D HEADER W $C(7),!,"THERE IS NO DATA FOR THIS REPORT" Q
- I $O(^TMP($J,""))="",$D(NURSNLOC) S NURPROG(4)=$S($G(NURPROG)=0:NURPROG(1),1:" BLANK") S NL1="" F S NL1=$O(NURSNLOC(NL1)) Q:NL1="" D:NURSW1=0 HEADER S NURSW1=1 D NODATA^NURSUT1
- I $O(^TMP($J,""))'="",$D(NURSNLOC) D I NURSW1=1 D ENDPG^NURSUT1 S NURSW1=0
- . S (NURX,NURY,NURZ)="" 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 NL1="" F S NL1=$O(NURSNLOC(NL1)) Q:NL1="" I '$D(^TMP($J,"NURLOC",NL1)) D
- . . S NURPROG(4)=$S($G(NURPROG)=0:NURPROG(1),1:" BLANK"),NURFAC(2)=$S($G(NURFAC)=0:NURFAC(1),1:"") D:NURSW1=0 HEADER S NURSW1=1 D NODATA^NURSUT1
- . . Q
- . Q
- S NURFAC(2)="" F S NURFAC(2)=$O(^TMP($J,"L",NURFAC(2))) Q:NURFAC(2)="" D NM Q:$G(NUROUT) S NURSW1=0
- Q
- NM S NURPROG(4)="" F S NURPROG(4)=$O(^TMP($J,"L",NURFAC(2),NURPROG(4))) Q:NURPROG(4)="" D NN Q:$G(NUROUT) W !!
- Q
- NN S NL1="" F S NL1=$O(^TMP($J,"L",NURFAC(2),NURPROG(4),NL1)) Q:NL1="" S NURSORT=$G(^TMP($J,"L",NURFAC(2),NURPROG(4),NL1)) I NURSORT D HEADER Q:NUROUT D NO Q:$G(NUROUT)
- Q
- NO S NBED="" F S NBED=$O(^TMP($J,"L1",NURSORT,NBED)) Q:NBED="" D NP Q:NUROUT
- Q
- NP S N1="" F S N1=$O(^TMP($J,"L1",NURSORT,NBED,N1)) Q:N1="" D NQ Q:NUROUT
- Q
- NQ S DFN=0 F S DFN=$O(^TMP($J,"L1",NURSORT,NBED,N1,DFN)) Q:DFN'>0 D PRINT1 Q:NUROUT
- Q
- PRINT1 D DEM^VADPT S SSN=VA("BID") D ^NURSAPCH
- S NSEC=$S('$D(^NURSF(214,DFN,0)):"",$P(^(0),"^",4)="":"",'$D(^NURSF(213.3,$P(^NURSF(214,DFN,0),"^",4),0)):"",1:$P(^NURSF(213.3,$P(^NURSF(214,DFN,0),"^",4),1),"^",1)) D FNDCLAS
- D:$Y>(IOSL-6)!('NURSW1) HEADER Q:NUROUT W !,$S(NBED'=" BLANK":NBED,1:""),?17,^TMP($J,"L1",NURSORT,NBED,N1,DFN),$S(N1'=" BLANK":$E(N1,1,19),1:""),?42,SSN,?56,$S($D(NURSX):NURSX,1:""),?66,NSEC,?75,NURCAT
- Q
- FNDCLAS D EN6^NURSCUTL S NURSCLAS("CL")=1 D EN2^NURSCUTL S NURCAT=$S(NURSCLAS'="":$P(^NURSA(214.6,NURSCLAS,0),"^",3),1:"")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURSCPLC 5037 printed Feb 18, 2025@23:48:11 Page 2
- NURSCPLC ;HIRMFO/RM,FT,MD-PATIENT CENSUS...WARD, AND HOSPITAL ;12/14/98
- +1 ;;4.0;NURSING SERVICE;**20,22,44**;Apr 25, 1997;Build 3
- EN2 ; ENTRY FOR WARD PATIENT CENSUS
- +1 if '$DATA(^DIC(213.9,1,"OFF"))
- QUIT
- if $PIECE(^DIC(213.9,1,"OFF"),"^",1)=1
- QUIT
- +2 SET (NURSZAP,NURPLSW,NURMDSW,NURQUIT,NURQUEUE)=0
- +3 DO EN9^NURSAGSP
- +4 IF NURMDSW
- SET DIC(0)="AEMQZ"
- SET NURPLSCR=1
- DO EN5^NURSAGSP
- KILL NURPLSCR
- IF $GET(NUROUT)
- GOTO QUIT
- +5 IF NURMDSW=0
- IF NURPLSW=1
- SET NURPLCSR=1
- DO PRD^NURSAGSP
- KILL NURPLSCR
- IF $GET(NUROUT)
- GOTO QUIT
- +6 WRITE !
- DO EN1^NURSAGSP
- if $GET(NUROUT)
- GOTO QUIT
- +7 WRITE !
- DO EN6^NURSUT0
- IF $GET(NURQUIT)
- SET NUROUT=1
- GOTO QUIT
- +8 WRITE !
- SET ZTDESC="Nursing Patient Census"
- SET ZTRTN="START^NURSCPLC"
- DO EN7^NURSUT0
- if POP!($DATA(ZTSK))
- GOTO QUIT
- START ;
- +1 USE IO
- SET (NURSW1,NURPAGE,NUROUT)=0
- KILL ^TMP($JOB)
- +2 IF NURHOSP
- SET NURIEN=0
- FOR
- SET NURIEN=$ORDER(^NURSF(214,"AF","A",NURIEN))
- if NURIEN'>0
- QUIT
- SET DFN=""
- FOR
- SET DFN=$ORDER(^NURSF(214,"AF","A",NURIEN,DFN))
- if DFN'>0
- QUIT
- SET NPWARD=NURIEN
- DO EN6^NURSAUTL
- SET NURSWARD=$EXTRACT(NPWARD,1,20)
- if $EXTRACT(IOST)="C"&($RANDOM(100))
- WRITE "."
- DO SORT
- +3 IF '$TEST
- SET NURSWARD=""
- FOR
- SET NURSWARD=$ORDER(NURSNLOC(NURSWARD))
- if NURSWARD=""
- QUIT
- SET NURIEN=0
- FOR
- SET NURIEN=$ORDER(NURSNLOC(NURSWARD,NURIEN))
- if NURIEN'>0
- QUIT
- SET DFN=0
- FOR
- SET DFN=$ORDER(^NURSF(214,"AF","A",NURIEN,DFN))
- if DFN'>0
- QUIT
- if $EXTRACT(IOST)="C"&($RANDOM(100))
- WRITE "."
- DO SORT
- +4 IF $EXTRACT(IOST)="P"
- FOR NURI=1:1
- if NURI>NCOPY
- QUIT
- DO PRINT
- SET (NURPAGE,NURSW1)=0
- if $GET(NCOPY)>1
- WRITE @IOF
- +5 IF $EXTRACT(IOST)="C"
- DO PRINT
- QUIT ; KILL LOCAL VARIABLES
- +1 DO CLOSE^NURSUT1
- DO ^NURSKILL
- +2 QUIT
- SORT ; SORT OF PATIENT CENSUS
- +1 SET NURFAC(2)=$SELECT($$EN12^NURSUT3(NURIEN)'="":$$EN12^NURSUT3(NURIEN),1:" BLANK")
- +2 SET NURPROG(4)=+$PIECE(^NURSF(211.4,+NURIEN,1),U,4)
- SET NURPROG(4)=$$GET1^DIQ(212.7,+NURPROG(4),.01,"I")
- if NURPROG(4)=""
- SET NURPROG(4)=" BLANK"
- +3 IF NURMDSW
- IF $GET(NURFAC)=0
- IF NURFAC(2)'=NURFAC(1)
- QUIT
- +4 IF NURPLSW
- IF $GET(NURPROG)=0
- IF NURPROG(4)'=NURPROG(1)
- QUIT
- +5 DO 1^VADPT
- +6 SET NBED=$SELECT(VAIN(5)="":" BLANK",1:VAIN(5))
- SET N1=$SELECT(VADM(1)="":" BLANK",1:VADM(1))
- +7 if $GET(NURSORT)=""
- SET NURSORT=1
- +8 NEW X
- SET X=$GET(^TMP($JOB,"L",NURFAC(2),NURPROG(4),NURSWARD))
- +9 IF X=""
- SET X=NURSORT
- SET NURSORT=NURSORT+1
- SET ^TMP($JOB,"L",NURFAC(2),NURPROG(4),NURSWARD)=X
- SET ^TMP($JOB,"NURLOC",NURSWARD)=""
- +10 SET ^TMP($JOB,"L1",X,NBED,N1,DFN)=$SELECT(N1=" BLANK":" ",'$DATA(^DPT(DFN,.109)):" ",^DPT(DFN,.109)=0:" ",1:"! ")
- +11 KILL VAIN,VADM
- QUIT
- +1 IF 'NURQUEUE
- IF NURSW1
- IF $EXTRACT(IOST)="C"
- DO ENDPG^NURSUT1
- if NUROUT
- QUIT
- +2 SET NURSHD="PATIENT CENSUS"_$SELECT($DATA(^TMP($JOB,"NURLOC",NL1)):" FOR "_$EXTRACT(NL1,1,12),1:"")
- +3 SET NURSW1=1
- +4 SET NURPAGE=NURPAGE+1
- if $EXTRACT(IOST)="C"!(NURPAGE>1)
- WRITE @IOF
- +5 IF NURMDSW
- IF $GET(NURHOSP)
- WRITE !,?$$CNTR^NURSUT2($GET(NURFAC(2))),$SELECT($GET(NURFAC(2))=" BLANK":"NO FACILITY",1:$GET(NURFAC(2)))
- +6 WRITE !,$EXTRACT(DT,4,5),"/",$EXTRACT(DT,6,7),"/",$EXTRACT(DT,2,3),?28,NURSHD,?68,"PAGE: ",NURPAGE,!
- +7 WRITE !,"ROOM/BED",?17,"PATIENT NAME",?40,"Last 4",?55,"ABSENCE",?64,"BED SEC",?73,"ACUITY"
- +8 WRITE !,$$REPEAT^XLFSTR("-",80),!
- PROD IF NURPLSW
- IF $GET(NURPROG(4))'=" BLANK"
- WRITE !?$$CNTR^NURSUT2(NURPROG(4)),$SELECT($EXTRACT(NURPROG(4),1)=" ":$EXTRACT(NURPROG(4),2,99),1:$GET(NURPROG(4)))
- WRITE !,?$$CNTR^NURSUT2(NURPROG(4)),$$REPEAT^XLFSTR("-",$LENGTH(NURPROG(4))+1),!
- +1 QUIT
- PRINT ;PRINT ROUTINE
- +1 IF $ORDER(^TMP($JOB,""))=""
- IF '$DATA(NURSNLOC)
- SET NL1="THE HOSPITAL"
- SET NURPROG(4)=$SELECT($GET(NURPROG)=0:NURPROG(1),1:" BLANK")
- SET NURFAC(2)=$SELECT($GET(NURFAC)=0:NURFAC(1),1:" BLANK")
- DO HEADER
- WRITE $CHAR(7),!,"THERE IS NO DATA FOR THIS REPORT"
- QUIT
- +2 IF $ORDER(^TMP($JOB,""))=""
- IF $DATA(NURSNLOC)
- SET NURPROG(4)=$SELECT($GET(NURPROG)=0:NURPROG(1),1:" BLANK")
- SET NL1=""
- FOR
- SET NL1=$ORDER(NURSNLOC(NL1))
- if NL1=""
- QUIT
- if NURSW1=0
- DO HEADER
- SET NURSW1=1
- DO NODATA^NURSUT1
- +3 IF $ORDER(^TMP($JOB,""))'=""
- IF $DATA(NURSNLOC)
- Begin DoDot:1
- +4 SET (NURX,NURY,NURZ)=""
- 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
- +5 SET NL1=""
- FOR
- SET NL1=$ORDER(NURSNLOC(NL1))
- if NL1=""
- QUIT
- IF '$DATA(^TMP($JOB,"NURLOC",NL1))
- Begin DoDot:2
- +6 SET NURPROG(4)=$SELECT($GET(NURPROG)=0:NURPROG(1),1:" BLANK")
- SET NURFAC(2)=$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 SET NURFAC(2)=""
- FOR
- SET NURFAC(2)=$ORDER(^TMP($JOB,"L",NURFAC(2)))
- if NURFAC(2)=""
- QUIT
- DO NM
- if $GET(NUROUT)
- QUIT
- SET NURSW1=0
- +10 QUIT
- NM SET NURPROG(4)=""
- FOR
- SET NURPROG(4)=$ORDER(^TMP($JOB,"L",NURFAC(2),NURPROG(4)))
- if NURPROG(4)=""
- QUIT
- DO NN
- if $GET(NUROUT)
- QUIT
- WRITE !!
- +1 QUIT
- NN SET NL1=""
- FOR
- SET NL1=$ORDER(^TMP($JOB,"L",NURFAC(2),NURPROG(4),NL1))
- if NL1=""
- QUIT
- SET NURSORT=$GET(^TMP($JOB,"L",NURFAC(2),NURPROG(4),NL1))
- IF NURSORT
- DO HEADER
- if NUROUT
- QUIT
- DO NO
- if $GET(NUROUT)
- QUIT
- +1 QUIT
- NO SET NBED=""
- FOR
- SET NBED=$ORDER(^TMP($JOB,"L1",NURSORT,NBED))
- if NBED=""
- QUIT
- DO NP
- if NUROUT
- QUIT
- +1 QUIT
- NP SET N1=""
- FOR
- SET N1=$ORDER(^TMP($JOB,"L1",NURSORT,NBED,N1))
- if N1=""
- QUIT
- DO NQ
- if NUROUT
- QUIT
- +1 QUIT
- NQ SET DFN=0
- FOR
- SET DFN=$ORDER(^TMP($JOB,"L1",NURSORT,NBED,N1,DFN))
- if DFN'>0
- QUIT
- DO PRINT1
- if NUROUT
- QUIT
- +1 QUIT
- PRINT1 DO DEM^VADPT
- SET SSN=VA("BID")
- DO ^NURSAPCH
- +1 SET NSEC=$SELECT('$DATA(^NURSF(214,DFN,0)):"",$PIECE(^(0),"^",4)="":"",'$DATA(^NURSF(213.3,$PIECE(^NURSF(214,DFN,0),"^",4),0)):"",1:$PIECE(^NURSF(213.3,$PIECE(^NURSF(214,DFN,0),"^",4),1),"^",1))
- DO FNDCLAS
- +2 if $Y>(IOSL-6)!('NURSW1)
- DO HEADER
- if NUROUT
- QUIT
- WRITE !,$SELECT(NBED'=" BLANK":NBED,1:""),?17,^TMP($JOB,"L1",NURSORT,NBED,N1,DFN),$SELECT(N1'=" BLANK":$EXTRACT(N1,1,19),1:""),?42,SSN,?56,$SELECT($DATA(NURSX):NURSX,1:""),?66,NSEC,?75,NURCAT
- +3 QUIT
- FNDCLAS DO EN6^NURSCUTL
- SET NURSCLAS("CL")=1
- DO EN2^NURSCUTL
- SET NURCAT=$SELECT(NURSCLAS'="":$PIECE(^NURSA(214.6,NURSCLAS,0),"^",3),1:"")
- +1 QUIT