NURA6I2 ;HIRMFO/MD,RM,FT-NPSB REPORT FOR ENTIRE SERVICE ;8/23/96 09:46
;;4.0;NURSING SERVICE;**13**;Apr 25, 1997
Q:'$D(^DIC(213.9,1,"OFF")) Q:$P(^DIC(213.9,1,"OFF"),"^",1)=1
S (NURQUEUE,NURQUIT,NURPLSW,NURMDSW,NURSW1,NURPAGE,NUROUT)=0,NRNLPN=1
D EN1^NURSAUTL G QUIT:NUROUT D EN9^NURSAGSP
I NURMDSW S DIC(0)="AEQMZ",NURPLSCR=0 D EN5^NURSAGSP K NURPLSCR I $G(NUROUT) G QUIT
I NURMDSW=0,NURPLSW=1 S NURPLSCR=0 D PRD^NURSAGSP K NURPLSCR I $G(NUROUT) G QUIT
D EN3^NURSAGSP G QUIT:NUROUT
D EN1^NURSAGP1 G QUIT:NUROUT
W ! S ZTDESC="NPSB Report for Entire Nursing Service",ZTRTN="START^NURA6I2",NURS132=1 D EN7^NURSUT0 G:POP!($D(ZTSK)) QUIT
START ;
K ^TMP($J)
S X="" F S X=$O(^NURSF(210,"AC",X)) Q:X="" I X'="R" F DA=0:0 S DA=$O(^NURSF(210,"AC",X,DA)) Q:DA'>0 I $D(^NURSF(210,DA,0)),+$P(^(0),U) S DA(1)=$P(^(0),U) W:$R(100)&($E(IOST)="C") "." D SORT1
W ! S X=$O(^TMP($J,""))
I X="" S NURFAC(2)=$S($G(NURFAC)=0:$G(NURFAC(1)),1:""),NURPROG(2)=$S($G(NURPROG)=0:$G(NURPROG(1)),1:"") D NHDR W !,"THERE IS NO DATA FOR THIS REPORT" G QUIT
U IO S (NURQUIT,NURPAGE,NURSW1,NUROUT)=0 D NPRINT
QUIT K ^TMP($J) D CLOSE^NURSUT1,^NURAKILL
Q
SORT1 F NURNODE4=0:0 S NURNODE4=$O(^NURSF(211.8,"C",DA(1),NURNODE4)) Q:NURNODE4'>0 F NURNODE5=0:0 S NURNODE5=$O(^NURSF(211.8,"C",DA(1),NURNODE4,NURNODE5)) Q:NURNODE5'>0 D
.I $D(^NURSF(211.8,NURNODE4,1,NURNODE5,0)),$P(^(0),U)'>DT&(('$P(^(0),U,6))!($P(^(0),U,6)'<DT)) D SORT2
.Q
Q
SORT2 Q:NURSZAP>7&(NURSZDA'=DA) S NURSZORT=1 D EN3^NURSAUTL:NURSZAP>6,EN2^NURSAUTL:NURSZORT&NURSZAP Q:'NURSZORT
I NURMDSW S NURFAC(2)=$$EN11^NURSUT3($G(NURNODE4)) Q:$G(NURFAC(2))=""
E S NURFAC(2)=" BLANK"
I NURPLSW S NURPROG(3)=$P($G(^NURSF(211.8,NURNODE4,1,NURNODE5,0)),U,3),NURPROG(2)=$P($G(^NURSF(211.3,+NURPROG(3),0)),U,7) S:NURPROG(2)="" NURPROG(2)=+$O(^NURSF(212.7,"B","NURSING",0)) S NURPROG(2)=$$GET1^DIQ(212.7,NURPROG(2),.01,"I")
E S NURPROG(2)=" BLANK"
I NURMDSW,'$G(NURFAC),$G(NURFAC(1))'=$G(NURFAC(2)) Q
I NURPLSW,'$G(NURPROG),$G(NURPROG(1))'=$G(NURPROG(2)) Q
I $D(^VA(200,DA(1),0)),$P(^(0),"^",1)'="" S N1=$P(^(0),"^",1)
E S N1=" BLANK"
S NLO=$S($D(^NURSF(211.8,NURNODE4,0))&($P(^(0),"^")'=""):$P(^(0),"^"),1:" BLANK")
E S NLO=" BLANK"
I $D(^NURSF(211.4,"B",+NLO)) S NLO(1)=$O(^NURSF(211.4,"B",+NLO,0)) I $D(^NURSF(211.4,+NLO(1),"I")),$E($P(^("I"),"^"))="I" Q
D EN2^NURSUT0 Q:$G(NPSPOS(1))="" I '+NURCAT,'$D(^TMP("NURSCAT",$J,NPSPOS(1))) Q
S NPWARD=NLO D EN7^NURSAUTL S NL1=$S(NPWARD'="":NPWARD,1:" BLANK")
D SETCAT^NURAAGS1
I NURSCATY="R"!(NURSCATY="L")!($E(NURSCATY)="O") F D1=0:0 S D1=$O(^NURSF(210,DA,14,D1)) Q:D1'>0 S ATD=$S(+$P($G(^NURSF(210,DA,14,D1,0)),U,3):$P(^(0),U,3),1:" BLANK") D SAVE
Q
SAVE I 'NSP,ATD<NSPC!(ATD>NSPC(2)) Q
S:NURPROG(2)="NURSING" NURPROG(2)=" "_NURPROG(2)
S ^TMP($J,NURFAC(2),NURPROG(2),ATD,NL1,NURSCATY,N1,DA,D1)=""
Q
NPRINT S NURFAC(2)="" F S NURFAC(2)=$O(^TMP($J,NURFAC(2))) Q:NURFAC(2)="" S NBRK=0 D NHDR D NL Q:NUROUT
Q
NL S NURPROG(4)="" F S NURPROG(4)=$O(^TMP($J,NURFAC(2),NURPROG(4))) Q:NURPROG(4)=""!NUROUT D:$G(NURPLSW)&(NBRK=0) BRK D NM Q:NUROUT W:$G(NURPLSW) !
Q
NM S ATD="" F S ATD=$O(^TMP($J,NURFAC(2),NURPROG(4),ATD)) Q:ATD="" D NO Q:NURQUIT
Q
NO S NL1="" F S NL1=$O(^TMP($J,NURFAC(2),NURPROG(4),ATD,NL1)) Q:NL1="" D NR0 Q:NURQUIT
Q
NR0 S NURCAT="" F S NURCAT=$O(^TMP($J,NURFAC(2),NURPROG(4),ATD,NL1,NURCAT)) Q:NURCAT="" D NR Q:NURQUIT
Q
NR S N1="" F S N1=$O(^TMP($J,NURFAC(2),NURPROG(4),ATD,NL1,NURCAT,N1)) Q:N1="" D NS Q:NURQUIT
Q
NS F DA=0:0 S DA=$O(^TMP($J,NURFAC(2),NURPROG(4),ATD,NL1,NURCAT,N1,DA)) Q:DA'>0 F D1=0:0 S D1=$O(^TMP($J,NURFAC(2),NURPROG(4),ATD,NL1,NURCAT,N1,DA,D1)) Q:D1'>0 D NPPRINT Q:NURQUIT
Q
NPPRINT I ($Y>(IOSL-10)) D NHDR Q:NURQUIT
S:'NURSW1 NURSW1=1 S:'NBRK NBRK=1
W !?2,$E(N1,1,20)
I $D(^VA(200,$P(^NURSF(210,DA,0),"^"),1)),$P(^(1),"^",9)'="" S NURSSN=$P(^(1),"^",9) W ?25,$E(NURSSN,1,3),"-",$E(NURSSN,4,5),"-",$E(NURSSN,6,9)
W ?39,$E(NL1,1,10)
W:NURCAT="R"!(NURCAT="L") ?51,$$CAT^NURSUT2(NURCAT)
S DATA=$G(^NURSF(210,DA,14,D1,0)) F I=4,5,6,3 I +$P(DATA,U,I) S Y=+$P(DATA,U,I) D D^DIQ S ZZ=$S(I=4:61,I=5:77,I=6:93,1:109) W ?ZZ,Y
Q
BRK S NURPROG(2)=$S($G(NURPROG(4))=" BLANK":"NO PRODUCT LINE",$E($G(NURPROG(4)))=" ":$E($G(NURPROG(4)),2,99),1:$G(NURPROG(4))) W !?$$CNTR^NURSUT2(NURPROG(2)),NURPROG(2)
S NURLINE="",$P(NURLINE,"-",$L(NURPROG(2))+1)="" W !?$$CNTR^NURSUT2(NURLINE),NURLINE,!
Q
NHDR I 'NURQUEUE,NURSW1,$E(IOST)="C" D ENDPG^NURSUT1 S:NUROUT NURQUIT=+NUROUT Q:NURQUIT
S NURPAGE=NURPAGE+1 W:$E(IOST)="C"!(NURPAGE>1) @IOF
I $G(NURMDSW) W !,?$$CNTR^NURSUT2(NURFAC(2)),$S($G(NURFAC(2))=" BLANK":"NO FACILITY",1:NURFAC(2))
W !,"NURSING SERVICE NPSB PROFILE" S X="T" D ^%DT D:+Y D^DIQ W ?93,Y,?109,"PAGE: ",NURPAGE
W !!,?93,"TENTATIVE",!,?51,"SERVICE",?61,"DATE WORK COPY",?77,"DATE RETURNED",?93,"DATE FOR",?109,"ACTUAL DATE"
W !,?2,"NAME",?25,"SSN",?39,"LOCATION",?51,"CATEGORY",?61,"IS SENT OUT",?77,"FOR TYPING",?93,"FOR BOARD ACT.",?109,"OF BOARD ACT."
W !,$$REPEAT^XLFSTR("-",132)
I $G(NURPLSW),$G(NBRK) D BRK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURA6I2 5079 printed Dec 13, 2024@02:18:22 Page 2
NURA6I2 ;HIRMFO/MD,RM,FT-NPSB REPORT FOR ENTIRE SERVICE ;8/23/96 09:46
+1 ;;4.0;NURSING SERVICE;**13**;Apr 25, 1997
+2 if '$DATA(^DIC(213.9,1,"OFF"))
QUIT
if $PIECE(^DIC(213.9,1,"OFF"),"^",1)=1
QUIT
+3 SET (NURQUEUE,NURQUIT,NURPLSW,NURMDSW,NURSW1,NURPAGE,NUROUT)=0
SET NRNLPN=1
+4 DO EN1^NURSAUTL
if NUROUT
GOTO QUIT
DO EN9^NURSAGSP
+5 IF NURMDSW
SET DIC(0)="AEQMZ"
SET NURPLSCR=0
DO EN5^NURSAGSP
KILL NURPLSCR
IF $GET(NUROUT)
GOTO QUIT
+6 IF NURMDSW=0
IF NURPLSW=1
SET NURPLSCR=0
DO PRD^NURSAGSP
KILL NURPLSCR
IF $GET(NUROUT)
GOTO QUIT
+7 DO EN3^NURSAGSP
if NUROUT
GOTO QUIT
+8 DO EN1^NURSAGP1
if NUROUT
GOTO QUIT
+9 WRITE !
SET ZTDESC="NPSB Report for Entire Nursing Service"
SET ZTRTN="START^NURA6I2"
SET NURS132=1
DO EN7^NURSUT0
if POP!($DATA(ZTSK))
GOTO QUIT
START ;
+1 KILL ^TMP($JOB)
+2 SET X=""
FOR
SET X=$ORDER(^NURSF(210,"AC",X))
if X=""
QUIT
IF X'="R"
FOR DA=0:0
SET DA=$ORDER(^NURSF(210,"AC",X,DA))
if DA'>0
QUIT
IF $DATA(^NURSF(210,DA,0))
IF +$PIECE(^(0),U)
SET DA(1)=$PIECE(^(0),U)
if $RANDOM(100)&($EXTRACT(IOST)="C")
WRITE "."
DO SORT1
+3 WRITE !
SET X=$ORDER(^TMP($JOB,""))
+4 IF X=""
SET NURFAC(2)=$SELECT($GET(NURFAC)=0:$GET(NURFAC(1)),1:"")
SET NURPROG(2)=$SELECT($GET(NURPROG)=0:$GET(NURPROG(1)),1:"")
DO NHDR
WRITE !,"THERE IS NO DATA FOR THIS REPORT"
GOTO QUIT
+5 USE IO
SET (NURQUIT,NURPAGE,NURSW1,NUROUT)=0
DO NPRINT
QUIT KILL ^TMP($JOB)
DO CLOSE^NURSUT1
DO ^NURAKILL
+1 QUIT
SORT1 FOR NURNODE4=0:0
SET NURNODE4=$ORDER(^NURSF(211.8,"C",DA(1),NURNODE4))
if NURNODE4'>0
QUIT
FOR NURNODE5=0:0
SET NURNODE5=$ORDER(^NURSF(211.8,"C",DA(1),NURNODE4,NURNODE5))
if NURNODE5'>0
QUIT
Begin DoDot:1
+1 IF $DATA(^NURSF(211.8,NURNODE4,1,NURNODE5,0))
IF $PIECE(^(0),U)'>DT&(('$PIECE(^(0),U,6))!($PIECE(^(0),U,6)'<DT))
DO SORT2
+2 QUIT
End DoDot:1
+3 QUIT
SORT2 if NURSZAP>7&(NURSZDA'=DA)
QUIT
SET NURSZORT=1
if NURSZAP>6
DO EN3^NURSAUTL
if NURSZORT&NURSZAP
DO EN2^NURSAUTL
if 'NURSZORT
QUIT
+1 IF NURMDSW
SET NURFAC(2)=$$EN11^NURSUT3($GET(NURNODE4))
if $GET(NURFAC(2))=""
QUIT
+2 IF '$TEST
SET NURFAC(2)=" BLANK"
+3 IF NURPLSW
SET NURPROG(3)=$PIECE($GET(^NURSF(211.8,NURNODE4,1,NURNODE5,0)),U,3)
SET NURPROG(2)=$PIECE($GET(^NURSF(211.3,+NURPROG(3),0)),U,7)
if NURPROG(2)=""
SET NURPROG(2)=+$ORDER(^NURSF(212.7,"B","NURSING",0))
SET NURPROG(2)=$$GET1^DIQ(212.7,NURPROG(2),.01,"I")
+4 IF '$TEST
SET NURPROG(2)=" BLANK"
+5 IF NURMDSW
IF '$GET(NURFAC)
IF $GET(NURFAC(1))'=$GET(NURFAC(2))
QUIT
+6 IF NURPLSW
IF '$GET(NURPROG)
IF $GET(NURPROG(1))'=$GET(NURPROG(2))
QUIT
+7 IF $DATA(^VA(200,DA(1),0))
IF $PIECE(^(0),"^",1)'=""
SET N1=$PIECE(^(0),"^",1)
+8 IF '$TEST
SET N1=" BLANK"
+9 SET NLO=$SELECT($DATA(^NURSF(211.8,NURNODE4,0))&($PIECE(^(0),"^")'=""):$PIECE(^(0),"^"),1:" BLANK")
+10 IF '$TEST
SET NLO=" BLANK"
+11 IF $DATA(^NURSF(211.4,"B",+NLO))
SET NLO(1)=$ORDER(^NURSF(211.4,"B",+NLO,0))
IF $DATA(^NURSF(211.4,+NLO(1),"I"))
IF $EXTRACT($PIECE(^("I"),"^"))="I"
QUIT
+12 DO EN2^NURSUT0
if $GET(NPSPOS(1))=""
QUIT
IF '+NURCAT
IF '$DATA(^TMP("NURSCAT",$JOB,NPSPOS(1)))
QUIT
+13 SET NPWARD=NLO
DO EN7^NURSAUTL
SET NL1=$SELECT(NPWARD'="":NPWARD,1:" BLANK")
+14 DO SETCAT^NURAAGS1
+15 IF NURSCATY="R"!(NURSCATY="L")!($EXTRACT(NURSCATY)="O")
FOR D1=0:0
SET D1=$ORDER(^NURSF(210,DA,14,D1))
if D1'>0
QUIT
SET ATD=$SELECT(+$PIECE($GET(^NURSF(210,DA,14,D1,0)),U,3):$PIECE(^(0),U,3),1:" BLANK")
DO SAVE
+16 QUIT
SAVE IF 'NSP
IF ATD<NSPC!(ATD>NSPC(2))
QUIT
+1 if NURPROG(2)="NURSING"
SET NURPROG(2)=" "_NURPROG(2)
+2 SET ^TMP($JOB,NURFAC(2),NURPROG(2),ATD,NL1,NURSCATY,N1,DA,D1)=""
+3 QUIT
NPRINT SET NURFAC(2)=""
FOR
SET NURFAC(2)=$ORDER(^TMP($JOB,NURFAC(2)))
if NURFAC(2)=""
QUIT
SET NBRK=0
DO NHDR
DO NL
if NUROUT
QUIT
+1 QUIT
NL SET NURPROG(4)=""
FOR
SET NURPROG(4)=$ORDER(^TMP($JOB,NURFAC(2),NURPROG(4)))
if NURPROG(4)=""!NUROUT
QUIT
if $GET(NURPLSW)&(NBRK=0)
DO BRK
DO NM
if NUROUT
QUIT
if $GET(NURPLSW)
WRITE !
+1 QUIT
NM SET ATD=""
FOR
SET ATD=$ORDER(^TMP($JOB,NURFAC(2),NURPROG(4),ATD))
if ATD=""
QUIT
DO NO
if NURQUIT
QUIT
+1 QUIT
NO SET NL1=""
FOR
SET NL1=$ORDER(^TMP($JOB,NURFAC(2),NURPROG(4),ATD,NL1))
if NL1=""
QUIT
DO NR0
if NURQUIT
QUIT
+1 QUIT
NR0 SET NURCAT=""
FOR
SET NURCAT=$ORDER(^TMP($JOB,NURFAC(2),NURPROG(4),ATD,NL1,NURCAT))
if NURCAT=""
QUIT
DO NR
if NURQUIT
QUIT
+1 QUIT
NR SET N1=""
FOR
SET N1=$ORDER(^TMP($JOB,NURFAC(2),NURPROG(4),ATD,NL1,NURCAT,N1))
if N1=""
QUIT
DO NS
if NURQUIT
QUIT
+1 QUIT
NS FOR DA=0:0
SET DA=$ORDER(^TMP($JOB,NURFAC(2),NURPROG(4),ATD,NL1,NURCAT,N1,DA))
if DA'>0
QUIT
FOR D1=0:0
SET D1=$ORDER(^TMP($JOB,NURFAC(2),NURPROG(4),ATD,NL1,NURCAT,N1,DA,D1))
if D1'>0
QUIT
DO NPPRINT
if NURQUIT
QUIT
+1 QUIT
NPPRINT IF ($Y>(IOSL-10))
DO NHDR
if NURQUIT
QUIT
+1 if 'NURSW1
SET NURSW1=1
if 'NBRK
SET NBRK=1
+2 WRITE !?2,$EXTRACT(N1,1,20)
+3 IF $DATA(^VA(200,$PIECE(^NURSF(210,DA,0),"^"),1))
IF $PIECE(^(1),"^",9)'=""
SET NURSSN=$PIECE(^(1),"^",9)
WRITE ?25,$EXTRACT(NURSSN,1,3),"-",$EXTRACT(NURSSN,4,5),"-",$EXTRACT(NURSSN,6,9)
+4 WRITE ?39,$EXTRACT(NL1,1,10)
+5 if NURCAT="R"!(NURCAT="L")
WRITE ?51,$$CAT^NURSUT2(NURCAT)
+6 SET DATA=$GET(^NURSF(210,DA,14,D1,0))
FOR I=4,5,6,3
IF +$PIECE(DATA,U,I)
SET Y=+$PIECE(DATA,U,I)
DO D^DIQ
SET ZZ=$SELECT(I=4:61,I=5:77,I=6:93,1:109)
WRITE ?ZZ,Y
+7 QUIT
BRK SET NURPROG(2)=$SELECT($GET(NURPROG(4))=" BLANK":"NO PRODUCT LINE",$EXTRACT($GET(NURPROG(4)))=" ":$EXTRACT($GET(NURPROG(4)),2,99),1:$GET(NURPROG(4)))
WRITE !?$$CNTR^NURSUT2(NURPROG(2)),NURPROG(2)
+1 SET NURLINE=""
SET $PIECE(NURLINE,"-",$LENGTH(NURPROG(2))+1)=""
WRITE !?$$CNTR^NURSUT2(NURLINE),NURLINE,!
+2 QUIT
NHDR IF 'NURQUEUE
IF NURSW1
IF $EXTRACT(IOST)="C"
DO ENDPG^NURSUT1
if NUROUT
SET NURQUIT=+NUROUT
if NURQUIT
QUIT
+1 SET NURPAGE=NURPAGE+1
if $EXTRACT(IOST)="C"!(NURPAGE>1)
WRITE @IOF
+2 IF $GET(NURMDSW)
WRITE !,?$$CNTR^NURSUT2(NURFAC(2)),$SELECT($GET(NURFAC(2))=" BLANK":"NO FACILITY",1:NURFAC(2))
+3 WRITE !,"NURSING SERVICE NPSB PROFILE"
SET X="T"
DO ^%DT
if +Y
DO D^DIQ
WRITE ?93,Y,?109,"PAGE: ",NURPAGE
+4 WRITE !!,?93,"TENTATIVE",!,?51,"SERVICE",?61,"DATE WORK COPY",?77,"DATE RETURNED",?93,"DATE FOR",?109,"ACTUAL DATE"
+5 WRITE !,?2,"NAME",?25,"SSN",?39,"LOCATION",?51,"CATEGORY",?61,"IS SENT OUT",?77,"FOR TYPING",?93,"FOR BOARD ACT.",?109,"OF BOARD ACT."
+6 WRITE !,$$REPEAT^XLFSTR("-",132)
+7 IF $GET(NURPLSW)
IF $GET(NBRK)
DO BRK
+8 QUIT
