- NURARPC4 ;HIRMFO/MD-CONTINUATION OF DRIVER TO PRINT AMIS 1106 PATIENT CATEGORY TOTAL ;5/9/97
- ;;4.0;NURSING SERVICE;**1**;Apr 25, 1997
- PERSORT ; TOTAL SUBROUTINE FOR MONTHLY QUARTERLY AND YEARLY CATEGORY TOTALS
- 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 YY("W")=$E($P(^NURSA(213.4,NDA,0),U),9,99) I 'NURMDSW!'(NHOSPSW) S NURFAC(2)=" BLANK"
- I NHOSPSW,$G(NURFAC(2))'=" BLANK" S NURFAC(2)=$$EN12^NURSUT3($G(YY("W"))) Q:$G(NURFAC(2))=""
- I NHOSPSW,$G(NURFAC(1))'="" Q:$G(NURFAC(1))'=$G(NURFAC(2))
- 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="":" BLANK",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 F1=$S(YY("B")="":" BLANK",$D(^NURSF(213.3,YY("B"),0)):$P(^(0),U),1:" BLANK"),F2=$S(NPWARD="":" BLANK",1:NPWARD) 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")="":"",$D(^NURSF(213.3,YY("B"),0)):$P(^(0),U),1:" BLANK"),F2=$S(NURSWARD(0)="":" BLANK",1:NURSWARD(0)) G SET
- E Q
- SET ; ACCUMULATE PERIOD TOTALS IN TMP GLOBAL
- S NBED(D1)=$S($D(^NURSA(213.4,NDA,1,D1,0)):^(0),1:"") Q:NBED(D1)="" S NBED("BEDSEC")=$S($P($G(^NURSF(213.3,+NBED(D1),0)),U)'="":$P(^(0),U),1:" BLANK")_U_$P(NBED(D1),U,2,6)
- I NURMDSW,NHOSPSW,+$G(NURFAC),$P($G(NBED("BEDSEC")),U)'="" D
- . S:'$D(^TMP("NURBDSM",$J,$P(NBED("BEDSEC"),U))) ^($P(NBED("BEDSEC"),U))="0^0^0^0^0"
- . F Z=1:1:5 S $P(^TMP("NURBDSM",$J,$P(NBED("BEDSEC"),U)),U,Z)=($P(^($P(NBED("BEDSEC"),U)),U,Z)+$J($P(NBED("BEDSEC"),U,(Z+1)),0,2))
- . Q
- I '$D(^TMP($J,NURFAC(2),F1,F2)) S ^TMP($J,NURFAC(2),F1,F2)="0^0^0^0^0"
- F Y=1:1:5 S $P(^TMP($J,NURFAC(2),F1,F2),U,Y)=$P(^(F2),U,Y)+$J($P(NBED(D1),U,(Y+1)),0,2)
- Q
- PERRPT ; PERIOD REPORT
- S CATL("CEN")=0
- S NURFAC(2)="" F S NURFAC(2)=$O(^TMP($J,NURFAC(2))) Q:NURFAC(2)="" D:'$G(NURMDSW(1))&'($G(NURSUMSW)) HEADER^NURARPC2 Q:NUROUT D P0 Q:NUROUT D:NHOSPSW&(NURMDSW) BRK2^NURARPC2
- Q
- P0 S NF1="" F S NF1=$O(^TMP($J,NURFAC(2),NF1)) Q:NF1="" D P1 Q:NUROUT S NURMDSW(2)=1 D BRK^NURARPC2
- F X=1:1:5 S NTC(X)=0
- Q
- P1 S NF2="" F S NF2=$O(^TMP($J,NURFAC(2),NF1,NF2)) Q:NF2="" D WRITE Q:NUROUT
- Q
- WRITE ;
- I ($Y>(IOSL-4))!(NURMDSW(1)) D HEADER^NURARPC2 Q:NUROUT D HEADER1^NURARPC2
- S CATL=^TMP($J,NURFAC(2),NF1,NF2)
- F X=1:1:5 S CATL("CEN")=CATL("CEN")+$P(CATL,U,X)
- S NTCEN=NTCEN+CATL("CEN")
- G:$G(NURSUMSW) E
- I NURMDSW(2),NURSTYPE="U" W !,"WARD: ",$S(NBDSECT="":NF1,1:NF2) G B
- I NURMDSW(2) W !,"BED SECTION: ",NF1
- B I NURSTYPE="B" W !,?6,NF2 G C
- W !,?6,$S(NBDSECT="":NF2,1:NF1)
- C W ?34,$J($P(CATL,U),3),?42,$J($P(CATL,U,2),3),?50,$J($P(CATL,U,3),3),?58,$J($P(CATL,U,4),3),?66,$J($P(CATL,U,5),3),?74,$J(CATL("CEN"),3)
- E F X=1:1:5 S NTC(X)=NTC(X)+$P(CATL,U,X)
- S (NURMDSW(1),CATL("CEN"),NURMDSW(2))=0
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURARPC4 3193 printed Feb 18, 2025@23:46:19 Page 2
- NURARPC4 ;HIRMFO/MD-CONTINUATION OF DRIVER TO PRINT AMIS 1106 PATIENT CATEGORY TOTAL ;5/9/97
- +1 ;;4.0;NURSING SERVICE;**1**;Apr 25, 1997
- PERSORT ; TOTAL SUBROUTINE FOR MONTHLY QUARTERLY AND YEARLY CATEGORY TOTALS
- +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 SET YY("W")=$EXTRACT($PIECE(^NURSA(213.4,NDA,0),U),9,99)
- IF 'NURMDSW!'(NHOSPSW)
- SET NURFAC(2)=" BLANK"
- +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 $GET(NURFAC(1))'=""
- 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="":" BLANK",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 F1=$SELECT(YY("B")="":" BLANK",$DATA(^NURSF(213.3,YY("B"),0)):$PIECE(^(0),U),1:" BLANK")
- SET F2=$SELECT(NPWARD="":" BLANK",1:NPWARD)
- 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")="":"",$DATA(^NURSF(213.3,YY("B"),0)):$PIECE(^(0),U),1:" BLANK")
- SET F2=$SELECT(NURSWARD(0)="":" BLANK",1:NURSWARD(0))
- GOTO SET
- +4 IF '$TEST
- QUIT
- SET ; ACCUMULATE PERIOD TOTALS IN TMP GLOBAL
- +1 SET NBED(D1)=$SELECT($DATA(^NURSA(213.4,NDA,1,D1,0)):^(0),1:"")
- if NBED(D1)=""
- QUIT
- SET NBED("BEDSEC")=$SELECT($PIECE($GET(^NURSF(213.3,+NBED(D1),0)),U)'="":$PIECE(^(0),U),1:" BLANK")_U_$PIECE(NBED(D1),U,2,6)
- +2 IF NURMDSW
- IF NHOSPSW
- IF +$GET(NURFAC)
- IF $PIECE($GET(NBED("BEDSEC")),U)'=""
- Begin DoDot:1
- +3 if '$DATA(^TMP("NURBDSM",$JOB,$PIECE(NBED("BEDSEC"),U)))
- SET ^($PIECE(NBED("BEDSEC"),U))="0^0^0^0^0"
- +4 FOR Z=1:1:5
- SET $PIECE(^TMP("NURBDSM",$JOB,$PIECE(NBED("BEDSEC"),U)),U,Z)=($PIECE(^($PIECE(NBED("BEDSEC"),U)),U,Z)+$JUSTIFY($PIECE(NBED("BEDSEC"),U,(Z+1)),0,2))
- +5 QUIT
- End DoDot:1
- +6 IF '$DATA(^TMP($JOB,NURFAC(2),F1,F2))
- SET ^TMP($JOB,NURFAC(2),F1,F2)="0^0^0^0^0"
- +7 FOR Y=1:1:5
- SET $PIECE(^TMP($JOB,NURFAC(2),F1,F2),U,Y)=$PIECE(^(F2),U,Y)+$JUSTIFY($PIECE(NBED(D1),U,(Y+1)),0,2)
- +8 QUIT
- PERRPT ; PERIOD REPORT
- +1 SET CATL("CEN")=0
- +2 SET NURFAC(2)=""
- FOR
- SET NURFAC(2)=$ORDER(^TMP($JOB,NURFAC(2)))
- if NURFAC(2)=""
- QUIT
- if '$GET(NURMDSW(1))&'($GET(NURSUMSW))
- DO HEADER^NURARPC2
- if NUROUT
- QUIT
- DO P0
- if NUROUT
- QUIT
- if NHOSPSW&(NURMDSW)
- DO BRK2^NURARPC2
- +3 QUIT
- P0 SET NF1=""
- FOR
- SET NF1=$ORDER(^TMP($JOB,NURFAC(2),NF1))
- if NF1=""
- QUIT
- DO P1
- if NUROUT
- QUIT
- SET NURMDSW(2)=1
- DO BRK^NURARPC2
- +1 FOR X=1:1:5
- SET NTC(X)=0
- +2 QUIT
- P1 SET NF2=""
- FOR
- SET NF2=$ORDER(^TMP($JOB,NURFAC(2),NF1,NF2))
- if NF2=""
- QUIT
- DO WRITE
- if NUROUT
- QUIT
- +1 QUIT
- WRITE ;
- +1 IF ($Y>(IOSL-4))!(NURMDSW(1))
- DO HEADER^NURARPC2
- if NUROUT
- QUIT
- DO HEADER1^NURARPC2
- +2 SET CATL=^TMP($JOB,NURFAC(2),NF1,NF2)
- +3 FOR X=1:1:5
- SET CATL("CEN")=CATL("CEN")+$PIECE(CATL,U,X)
- +4 SET NTCEN=NTCEN+CATL("CEN")
- +5 if $GET(NURSUMSW)
- GOTO E
- +6 IF NURMDSW(2)
- IF NURSTYPE="U"
- WRITE !,"WARD: ",$SELECT(NBDSECT="":NF1,1:NF2)
- GOTO B
- +7 IF NURMDSW(2)
- WRITE !,"BED SECTION: ",NF1
- B IF NURSTYPE="B"
- WRITE !,?6,NF2
- GOTO C
- +1 WRITE !,?6,$SELECT(NBDSECT="":NF2,1:NF1)
- C WRITE ?34,$JUSTIFY($PIECE(CATL,U),3),?42,$JUSTIFY($PIECE(CATL,U,2),3),?50,$JUSTIFY($PIECE(CATL,U,3),3),?58,$JUSTIFY($PIECE(CATL,U,4),3),?66,$JUSTIFY($PIECE(CATL,U,5),3),?74,$JUSTIFY(CATL("CEN"),3)
- E FOR X=1:1:5
- SET NTC(X)=NTC(X)+$PIECE(CATL,U,X)
- +1 SET (NURMDSW(1),CATL("CEN"),NURMDSW(2))=0
- +2 QUIT