- NURARPC3 ;HIRMFO/MD,FT-CONTINUATION OF 1106 ACUITY REPORT DRIVER ;3/19/98 13:12
- ;;4.0;NURSING SERVICE;**1,9****;Apr 25, 1997
- S U="^" I +$G(NDATED)?7N S NURZ=+NDATED_" 0",NURMDSW(3)=0 F S NURZ=$O(^NURSA(213.4,"B",NURZ)) Q:$E(NURZ,1,7)'>0!($E(NURZ,1,7)>+$P(NDATED,U,2)) S NDA=$O(^NURSA(213.4,"B",NURZ,0)) W:$E(IOST)="C"&'$R(30) "." D SORT
- I $D(NDATED) S (ZX,ZY)="" D
- .I NDATED["MT" S ZX=$E(NDATED,1,5)_"00",ZY=$E(NDATED,1,5)_"31"
- .I NDATED?3N S ZX=(NDATED-1)_"1000",ZY=NDATED_"0930"
- .I NDATED["Q" S (ZX,ZY)=+$E(NDATED,1,3),NURZ=$E(NDATED,7) S:NURZ=1 ZX=ZX-1,ZY=ZY-1 S ZX=ZX_$S(NURZ=1:"1000",NURZ=2:"0100",NURZ=3:"0400",1:"0700"),ZY=ZY_$S(NURZ=1:"1231",NURZ=2:"0331",NURZ=3:"0630",1:"0930")
- .I ZX="" Q
- .S NURZ=ZX,NURMDSW(3)=1 F S NURZ=$O(^NURSA(213.4,"AB",NURZ)) Q:NURZ=""!(NURZ>ZY) F NDA=0:0 S NDA=$O(^NURSA(213.4,"AB",NURZ,NDA)) Q:NDA'>0 W:$E(IOST)="C"&'$R(30) "." D PERSORT^NURARPC4
- .Q
- I $O(^TMP($J,""))="" S NURFAC(2)=$S($G(NURFAC)=0:NURFAC(1),1:"") D HEADER^NURARPC2 S NUROUT=1 W !!," THERE IS NO DATA FOR "_$S($G(NHOSPSW):"THIS REPORT ",1:$G(NURSWARD(0))) D:$E(IOST)="C" RERUNRPT Q
- S (NTCEN,DTCEN,NFCEN,NFTCEN)=0 F X=1:1:5 S (NTC(X),DTC(X),NFC(X),NFTC(X))=0
- D:'NURMDSW(3) ^NURARPC2
- D:NURMDSW(3) PERRPT^NURARPC4
- I 'NUROUT,NHOSPSW,NURMDSW,+$G(NURFAC),$O(^TMP("NURBDSM",$J,""))'="" D
- . D HEADER^NURARPC2,HEADER1^NURARPC2
- . W !!,?35,"MULTI-DIVISIONAL SUMMARY"
- . S NBED="" F S NBED=$O(^TMP("NURBDSM",$J,NBED)) Q:NBED="" D
- . . I $Y>(IOSL-6) D HEADER^NURARPC2,HEADER1^NURARPC2 Q:NUROUT W !!,?35,"MULTI-DIVISIONAL SUMMARY"
- . . S NDATA=$G(^TMP("NURBDSM",$J,NBED)),NDATA(1)=($P(NDATA,U)+$P(NDATA,U,2)+$P(NDATA,U,3)+$P(NDATA,U,4)+$P(NDATA,U,5))
- . . W !!,NBED,?33,$J($P(NDATA,U),4),?41,$J($P(NDATA,U,2),4),?49,$J($P(NDATA,U,3),4),?57,$J($P(NDATA,U,4),4),?65,$J($P(NDATA,U,5),4),?73,$J(NDATA(1),4)
- . . Q
- . Q
- I NHOSPSW D:$Y>(IOSL-6)&'NUROUT HEADER^NURARPC2,HEADER1^NURARPC2 D
- . W !,?33,"---- ---- ---- ---- ---- ----"
- . W !,"REPORT TOTAL",?33,$J(NFC(1),4),?41,$J(NFC(2),4),?49,$J(NFC(3),4),?57,$J(NFC(4),4),?65,$J(NFC(5),4),?73,$J(NFCEN,4)
- . Q
- D ^%ZISC
- D:$E(IOST)="C"&'NUROUT RERUNRPT
- K NDATED,NURFAC Q
- SORT ;
- Q:+$$NOVALU^NURARPC1(NDA)'>0
- I NURTYPE=0,'($E($P(^NURSA(213.4,NDA,0),U),8)="D") Q
- I NURTYPE=1,'($E($P(^NURSA(213.4,NDA,0),U),8)="E") Q
- S:'NURMDSW!'(NHOSPSW) NURFAC(2)=" BLANK" S YY("W")=$E($P(^NURSA(213.4,NDA,0),U),9,99)
- I NHOSPSW,$G(NURFAC(2))'=" BLANK" S NURFAC(2)=$$EN12^NURSUT3($G(YY("W"))) Q:$G(NURFAC(2))=""
- I NHOSPSW,NURMDSW,'$G(NURFAC),$G(NURFAC(1))'=$G(NURFAC(2)) Q
- K NBED F D1=0:0 S D1=$O(^NURSA(213.4,NDA,1,D1)) Q:D1'>0 I $D(^NURSA(213.4,NDA,1,D1,0)) S YY("B")=$P(^(0),U) D A
- Q
- A I NHOSPSW,NURSTYPE="U" S NPWARD=YY("W") D EN6^NURSAUTL S F1=$S(NPWARD="":"",1:NPWARD),F2=$S(YY("B")="":" BLANK",$D(^NURSF(213.3,YY("B"),0)):$P(^(0),U),1:" BLANK") G SET
- I NHOSPSW,(YY("B")=NBDSECT!'NBDSECT) S NPWARD=YY("W") D EN6^NURSAUTL S F2=$S(NPWARD="":" BLANK",1:NPWARD),F1=$S(YY("B")="":" BLANK",$D(^NURSF(213.3,YY("B"),0)):$P(^(0),"^"),1:" BLANK") G SET
- I 'NHOSPSW,'NBDSECT,YY("W")=NURSWARD S F1=$S(NURSWARD(0)="":" BLANK",1:NURSWARD(0)),F2=$S(YY("B")="":" BLANK",$D(^NURSF(213.3,YY("B"),0)):$P(^(0),U),1:" BLANK") G SET
- I 'NHOSPSW,YY("B")=NBDSECT,YY("W")=NURSWARD S F1=$S(YY("B")="":" BLANK",$D(^NURSF(213.3,YY("B"),0)):$P(^(0),U),1:" BLANK"),F2=$S(NURSWARD(0)="":" BLANK",1:NURSWARD(0)) G SET
- Q
- SET ; BUILD TMP GLOBAL WITH SELECTED DAILY DATA
- S NBED(D1)=^NURSA(213.4,NDA,1,D1,0),NBED("BEDSEC")=$S($P($G(^NURSF(213.3,+NBED(D1),0)),U)'="":$P($G(^(0)),U),1:" BLANK")_U_$P(NBED(D1),U,2,6)
- I '$D(^TMP($J,$E(NURZ,1,7),NURFAC(2),F1,F2)) S ^TMP($J,$E(NURZ,1,7),NURFAC(2),F1,F2)="0^0^0^0^0"
- I NURMDSW,NHOSPSW,+$G(NURFAC),$P(NBED("BEDSEC"),U)'="" D
- . S:'$D(^TMP("NURBDSM",$J,$P(NBED("BEDSEC"),U))) ^($P(NBED("BEDSEC"),U))="0^0^0^0^0"
- . F Z=2:1:6 S $P(^TMP("NURBDSM",$J,$P(NBED("BEDSEC"),U)),U,(Z-1))=($P(^($P(NBED("BEDSEC"),U)),U,(Z-1))+$P(NBED("BEDSEC"),U,Z))
- . Q
- F Y=2:1:6 S $P(^TMP($J,$E(NURZ,1,7),NURFAC(2),F1,F2),U,(Y-1))=$P(NBED(D1),U,Y)
- Q
- RERUNRPT ;
- S NURSUMSW=0 R !!,"Would you like to run another report? NO//",X:DTIME
- S X=$$UP^XLFSTR(X) I (X?1"N".E)!("^"[X)!('$T) S NUROUT=1 Q
- I X?1"Y".E S NUROUT=0 Q
- W !,"ANSWER YES OR NO" G RERUNRPT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURARPC3 4302 printed Feb 18, 2025@23:46:18 Page 2
- NURARPC3 ;HIRMFO/MD,FT-CONTINUATION OF 1106 ACUITY REPORT DRIVER ;3/19/98 13:12
- +1 ;;4.0;NURSING SERVICE;**1,9****;Apr 25, 1997
- +2 SET U="^"
- IF +$GET(NDATED)?7N
- SET NURZ=+NDATED_" 0"
- SET NURMDSW(3)=0
- FOR
- SET NURZ=$ORDER(^NURSA(213.4,"B",NURZ))
- if $EXTRACT(NURZ,1,7)'>0!($EXTRACT(NURZ,1,7)>+$PIECE(NDATED,U,2))
- QUIT
- SET NDA=$ORDER(^NURSA(213.4,"B",NURZ,0))
- if $EXTRACT(IOST)="C"&'$RANDOM(30)
- WRITE "."
- DO SORT
- +3 IF $DATA(NDATED)
- SET (ZX,ZY)=""
- Begin DoDot:1
- +4 IF NDATED["MT"
- SET ZX=$EXTRACT(NDATED,1,5)_"00"
- SET ZY=$EXTRACT(NDATED,1,5)_"31"
- +5 IF NDATED?3N
- SET ZX=(NDATED-1)_"1000"
- SET ZY=NDATED_"0930"
- +6 IF NDATED["Q"
- SET (ZX,ZY)=+$EXTRACT(NDATED,1,3)
- SET NURZ=$EXTRACT(NDATED,7)
- if NURZ=1
- SET ZX=ZX-1
- SET ZY=ZY-1
- SET ZX=ZX_$SELECT(NURZ=1:"1000",NURZ=2:"0100",NURZ=3:"0400",1:"0700")
- SET ZY=ZY_$SELECT(NURZ=1:"1231",NURZ=2:"0331",NURZ=3:"0630",1:"0930")
- +7 IF ZX=""
- QUIT
- +8 SET NURZ=ZX
- SET NURMDSW(3)=1
- FOR
- SET NURZ=$ORDER(^NURSA(213.4,"AB",NURZ))
- if NURZ=""!(NURZ>ZY)
- QUIT
- FOR NDA=0:0
- SET NDA=$ORDER(^NURSA(213.4,"AB",NURZ,NDA))
- if NDA'>0
- QUIT
- if $EXTRACT(IOST)="C"&'$RANDOM(30)
- WRITE "."
- DO PERSORT^NURARPC4
- +9 QUIT
- End DoDot:1
- +10 IF $ORDER(^TMP($JOB,""))=""
- SET NURFAC(2)=$SELECT($GET(NURFAC)=0:NURFAC(1),1:"")
- DO HEADER^NURARPC2
- SET NUROUT=1
- WRITE !!," THERE IS NO DATA FOR "_$SELECT($GET(NHOSPSW):"THIS REPORT ",1:$GET(NURSWARD(0)))
- if $EXTRACT(IOST)="C"
- DO RERUNRPT
- QUIT
- +11 SET (NTCEN,DTCEN,NFCEN,NFTCEN)=0
- FOR X=1:1:5
- SET (NTC(X),DTC(X),NFC(X),NFTC(X))=0
- +12 if 'NURMDSW(3)
- DO ^NURARPC2
- +13 if NURMDSW(3)
- DO PERRPT^NURARPC4
- +14 IF 'NUROUT
- IF NHOSPSW
- IF NURMDSW
- IF +$GET(NURFAC)
- IF $ORDER(^TMP("NURBDSM",$JOB,""))'=""
- Begin DoDot:1
- +15 DO HEADER^NURARPC2
- DO HEADER1^NURARPC2
- +16 WRITE !!,?35,"MULTI-DIVISIONAL SUMMARY"
- +17 SET NBED=""
- FOR
- SET NBED=$ORDER(^TMP("NURBDSM",$JOB,NBED))
- if NBED=""
- QUIT
- Begin DoDot:2
- +18 IF $Y>(IOSL-6)
- DO HEADER^NURARPC2
- DO HEADER1^NURARPC2
- if NUROUT
- QUIT
- WRITE !!,?35,"MULTI-DIVISIONAL SUMMARY"
- +19 SET NDATA=$GET(^TMP("NURBDSM",$JOB,NBED))
- SET NDATA(1)=($PIECE(NDATA,U)+$PIECE(NDATA,U,2)+$PIECE(NDATA,U,3)+$PIECE(NDATA,U,4)+$PIECE(NDATA,U,5))
- +20 WRITE !!,NBED,?33,$JUSTIFY($PIECE(NDATA,U),4),?41,$JUSTIFY($PIECE(NDATA,U,2),4),?49,$JUSTIFY($PIECE(NDATA,U,3),4),?57,$JUSTIFY($PIECE(NDATA,U,4),4),?65,$JUSTIFY($PIECE(NDATA,U,5),4),?73,$JUSTIFY(NDATA(1),4)
- +21 QUIT
- End DoDot:2
- +22 QUIT
- End DoDot:1
- +23 IF NHOSPSW
- if $Y>(IOSL-6)&'NUROUT
- DO HEADER^NURARPC2
- DO HEADER1^NURARPC2
- Begin DoDot:1
- +24 WRITE !,?33,"---- ---- ---- ---- ---- ----"
- +25 WRITE !,"REPORT TOTAL",?33,$JUSTIFY(NFC(1),4),?41,$JUSTIFY(NFC(2),4),?49,$JUSTIFY(NFC(3),4),?57,$JUSTIFY(NFC(4),4),?65,$JUSTIFY(NFC(5),4),?73,$JUSTIFY(NFCEN,4)
- +26 QUIT
- End DoDot:1
- +27 DO ^%ZISC
- +28 if $EXTRACT(IOST)="C"&'NUROUT
- DO RERUNRPT
- +29 KILL NDATED,NURFAC
- QUIT
- SORT ;
- +1 if +$$NOVALU^NURARPC1(NDA)'>0
- QUIT
- +2 IF NURTYPE=0
- IF '($EXTRACT($PIECE(^NURSA(213.4,NDA,0),U),8)="D")
- QUIT
- +3 IF NURTYPE=1
- IF '($EXTRACT($PIECE(^NURSA(213.4,NDA,0),U),8)="E")
- QUIT
- +4 if 'NURMDSW!'(NHOSPSW)
- SET NURFAC(2)=" BLANK"
- SET YY("W")=$EXTRACT($PIECE(^NURSA(213.4,NDA,0),U),9,99)
- +5 IF NHOSPSW
- IF $GET(NURFAC(2))'=" BLANK"
- SET NURFAC(2)=$$EN12^NURSUT3($GET(YY("W")))
- if $GET(NURFAC(2))=""
- QUIT
- +6 IF NHOSPSW
- IF NURMDSW
- IF '$GET(NURFAC)
- IF $GET(NURFAC(1))'=$GET(NURFAC(2))
- QUIT
- +7 KILL NBED
- FOR D1=0:0
- SET D1=$ORDER(^NURSA(213.4,NDA,1,D1))
- if D1'>0
- QUIT
- IF $DATA(^NURSA(213.4,NDA,1,D1,0))
- SET YY("B")=$PIECE(^(0),U)
- DO A
- +8 QUIT
- A IF NHOSPSW
- IF NURSTYPE="U"
- SET NPWARD=YY("W")
- DO EN6^NURSAUTL
- SET F1=$SELECT(NPWARD="":"",1:NPWARD)
- SET F2=$SELECT(YY("B")="":" BLANK",$DATA(^NURSF(213.3,YY("B"),0)):$PIECE(^(0),U),1:" BLANK")
- GOTO SET
- +1 IF NHOSPSW
- IF (YY("B")=NBDSECT!'NBDSECT)
- SET NPWARD=YY("W")
- DO EN6^NURSAUTL
- SET F2=$SELECT(NPWARD="":" BLANK",1:NPWARD)
- SET F1=$SELECT(YY("B")="":" BLANK",$DATA(^NURSF(213.3,YY("B"),0)):$PIECE(^(0),"^"),1:" BLANK")
- GOTO SET
- +2 IF 'NHOSPSW
- IF 'NBDSECT
- IF YY("W")=NURSWARD
- SET F1=$SELECT(NURSWARD(0)="":" BLANK",1:NURSWARD(0))
- SET F2=$SELECT(YY("B")="":" BLANK",$DATA(^NURSF(213.3,YY("B"),0)):$PIECE(^(0),U),1:" BLANK")
- GOTO SET
- +3 IF 'NHOSPSW
- IF YY("B")=NBDSECT
- IF YY("W")=NURSWARD
- SET F1=$SELECT(YY("B")="":" BLANK",$DATA(^NURSF(213.3,YY("B"),0)):$PIECE(^(0),U),1:" BLANK")
- SET F2=$SELECT(NURSWARD(0)="":" BLANK",1:NURSWARD(0))
- GOTO SET
- +4 QUIT
- SET ; BUILD TMP GLOBAL WITH SELECTED DAILY DATA
- +1 SET NBED(D1)=^NURSA(213.4,NDA,1,D1,0)
- SET NBED("BEDSEC")=$SELECT($PIECE($GET(^NURSF(213.3,+NBED(D1),0)),U)'="":$PIECE($GET(^(0)),U),1:" BLANK")_U_$PIECE(NBED(D1),U,2,6)
- +2 IF '$DATA(^TMP($JOB,$EXTRACT(NURZ,1,7),NURFAC(2),F1,F2))
- SET ^TMP($JOB,$EXTRACT(NURZ,1,7),NURFAC(2),F1,F2)="0^0^0^0^0"
- +3 IF NURMDSW
- IF NHOSPSW
- IF +$GET(NURFAC)
- IF $PIECE(NBED("BEDSEC"),U)'=""
- Begin DoDot:1
- +4 if '$DATA(^TMP("NURBDSM",$JOB,$PIECE(NBED("BEDSEC"),U)))
- SET ^($PIECE(NBED("BEDSEC"),U))="0^0^0^0^0"
- +5 FOR Z=2:1:6
- SET $PIECE(^TMP("NURBDSM",$JOB,$PIECE(NBED("BEDSEC"),U)),U,(Z-1))=($PIECE(^($PIECE(NBED("BEDSEC"),U)),U,(Z-1))+$PIECE(NBED("BEDSEC"),U,Z))
- +6 QUIT
- End DoDot:1
- +7 FOR Y=2:1:6
- SET $PIECE(^TMP($JOB,$EXTRACT(NURZ,1,7),NURFAC(2),F1,F2),U,(Y-1))=$PIECE(NBED(D1),U,Y)
- +8 QUIT
- RERUNRPT ;
- +1 SET NURSUMSW=0
- READ !!,"Would you like to run another report? NO//",X:DTIME
- +2 SET X=$$UP^XLFSTR(X)
- IF (X?1"N".E)!("^"[X)!('$TEST)
- SET NUROUT=1
- QUIT
- +3 IF X?1"Y".E
- SET NUROUT=0
- QUIT
- +4 WRITE !,"ANSWER YES OR NO"
- GOTO RERUNRPT
- +5 QUIT