NURSEPD2 ;HIRMFO/JH,RM-INCOMPLETE NURS M I REPORT (BY CLASS) PART 1 OF 2 ;3/19/98 13:28
;;4.0;NURSING SERVICE;**2,3,10,9**;Apr 25, 1997
EN1 S X=$G(^PRSE(452.7,1,"OFF")) Q:X=""!(X=1)
S X=$G(^DIC(213.9,1,"OFF")) Q:X=""!(X=1)
S (NONE,NUROUT,NURQUEUE,NURSW1)=0 D EN1^NURSAUTL G QUIT:$G(NUROUT)
I NURPLSW=1 D EN13^NURSAGSP G:$G(NUROUT) QUIT
I NURMDSW S DIC(0)="AEMQZ",NURPLSCR=1 D EN5^NURSAGSP K NURPLSCR G:$G(NUROUT) QUIT
I NURMDSW=0,NURPLSW=1 S NURPLSCR=1 D PRD^NURSAGSP K NURPLSCR I $G(NUROUT) G QUIT
D EN10^NURSUT3($G(DUZ)) S DATSEL="NS^N+" D DATSEL^NURSAGP2 G:$G(NUROUT) QUIT
S NURSEL="M" D EN5^NURSAGP1 G:$G(NUROUT) QUIT
I NURPLSW=0!($G(NURSEL(1))=1)!($G(NURSEL(1))="") W ! D EN1^NURSAGSP G QUIT:$G(NUROUT)
I NURPLSW=1,$G(NURSEL(1))=2 W ! D EN3^NURSAGSP G QUIT:$G(NUROUT)
W ! S ZTRTN="START^NURSEPD2",ZTDESC="M.I. DEFICIENCY by SVC-CATEGORY/LOCATION-PROGRAM/CLASS" D EN7^NURSUT0 G QUIT:POP!($D(ZTSK))
START ;DEFINE OUTPUT DATE/HEADERS
S NURS132=$S(IOM'<132:1,1:0) K ^TMP("NURE",$J) U IO S (HOLD,HOLD1,HOLD2,COUNT)=0
S DA=0 F S DA=$O(^NURSF(210,DA)) Q:DA'>0 I $P($G(^NURSF(210,DA,0)),U,2)'="R" D MAINLOOP
D ^NURSEPD3
QUIT ;KILL LOCAL VARIABLES
K ^TMP("NURE",$J) D CLOSE^NURSUT1,^NURSKILL
K NURCLAS,NURD0,NURIEN Q
MAINLOOP ;
S VA200DA=+$G(^NURSF(210,DA,0)),SSN=$P($G(^VA(200,VA200DA,1)),U,9) Q:$G(SSN)="" S PDA=$O(^PRSPC("SSN",SSN,0)) Q:$G(PDA)'>0 D SETMP
I $G(NURSEL(1))=1 D
.I $G(NURSPEC)="" S NONE=1 Q
.S NURDA=0 F S NURDA=$O(^NURSF(211.4,NURDA)) Q:NURDA'>0 I $G(^NURSF(211.4,+NURDA,"I"))="A" D
..S NPWARD=+$G(^NURSF(211.4,NURDA,0)) D EN7^NURSAUTL
..Q:NURSZAP>6&('$D(NURSZLO(NURDA)))
..I $G(NURHOSP)=0,'$D(NURSNLOC(NPWARD)) Q
..S NURSPEC=NPWARD D CHECK Q:NUROUT
..Q
.Q
Q
CHECK S NURFAC(2)=$$EN12^NURSUT3(NURDA),X=$P($G(^NURSF(211.4,+NURDA,1)),U,4),NURPROG(2)=$S($D(^NURSF(212.7,+X,0)):$P(^(0),U),1:" BLANK") S:NURPROG(2)="NURSING" NURPROG(2)=" NURSING" I NURFAC(2)=" BLANK"!(NURPROG(2))=" BLANK" S NUROUT=1 Q
I $G(NSP)!($G(NSP)'>0&(NURSPEC'="")),'$D(^TMP("NURE",$J,"SORT1",NURFAC(2),NURPROG(2),NURSPEC)) S ^(NURSPEC)="",^TMP("NURE",$J,"%",NURFAC(2),NURPROG(2),NURSPEC)="01"
Q
SETMP S X(0)=$G(^PRSPC(PDA,0)),X(1)=$G(^(1)) Q:($P(X(1),U,33)="Y")
S PRSENAM=$P(X(0),U)
F NURNODE4=0:0 S NURNODE4=$O(^NURSF(211.8,"C",VA200DA,NURNODE4)) Q:NURNODE4'>0 D
.F NURNODE5=0:0 S NURNODE5=$O(^NURSF(211.8,"C",VA200DA,NURNODE4,NURNODE5)) Q:NURNODE5'>0 I $D(^NURSF(211.8,NURNODE4,1,NURNODE5,0)),$P(^(0),U)'>DT&(('$P(^(0),U,6))!($P(^(0),U,6)'<DT)) D
..S DA=$O(^NURSF(210,"B",VA200DA,0)) I $P($G(^NURSF(210,+DA,0)),U,2)'="",$P($G(^(0)),U,2)'="R" W:$R(500)&($E(IOST)="C") "." D SORT
Q
SORT ;
Q:NURSZAP>7&(NURSZDA'=DA) S NURSZORT=1 D EN3^NURSAUTL:NURSZAP>6,EN2^NURSAUTL:NURSZORT&NURSZAP Q:'NURSZORT
S NURNEN=$S($G(NURSEL(1))=2:1,1:3) D SETFAC^NURAAGS1,SETPROG^NURAAGS1,SETCAT^NURAAGS1,SETLOC^NURAAGS1
I NURMDSW,'$G(NURFAC),$G(NURFAC(1))'=$G(NURFAC(2)) Q
I NURPLSW,'$G(NURPROG),$G(NURPROG(1))'=$G(NURPROG(2)) Q
S:NURPROG(2)="NURSING" NURPROG(2)=" "_NURPROG(2)
S NURNODE4(1)=$S($D(^NURSF(211.4,"B",+NLOCN)):$O(^NURSF(211.4,"B",+NLOCN,0)),1:0) I $D(^NURSF(211.4,NURNODE4(1),"I")),^("I")'="A" Q
I $G(NURSEL(1))=1!($G(NURSEL(1))="") S NURSPEC=$S(NLOCN(1)="":" BLANK",1:NLOCN(1)),NURSPEC(1)=$$CAT^NURSUT2(NURSCATY)
I $G(NURSEL(1))=2 S NURSPEC=$$CAT^NURSUT2(NURSCATY),NURSPEC(1)=$S(NLOCN(1)="":" BLANK",1:NLOCN(1))
I NURNEN=1,$S($E(NURSCATY)'="O":'$D(^TMP("NURSCAT",$J,NURSCATY)),$P($G(NURSCATY),"O ",2)'="":'$D(^TMP("NURSCAT",$J,$E(NURSCATY,3,99))),$P($G(NURSCATY),"O ",2)="":'$D(^TMP("NURSCAT",$J,NURSCATY)),1:0) Q
I $G(NURHOSP)=0,'$D(NURSNLOC(NURSPEC)) Q
S NAM=$S($P(^VA(200,VA200DA,0),U)'="":$P(^(0),U),1:" BLANK")
W:$E(IOST)="C" "."
F D1=0:0 S D1=$O(^PRSPC(PDA,6,D1)) Q:D1'>0 D
.K DROPDEAD
.S NURS=$G(^PRSPC(PDA,6,D1,0)),CLASSIEN=+$P(NURS,U) Q:CLASSIEN'>0
.Q:$S($P(NURS,U,3)'>0:1,$P(NURS,U,3)>YREND:1,$P(NURS,U,3)>DT:1,1:0)
.S CLASS=$G(^PRSE(452.1,CLASSIEN,0)) Q:CLASS=""
.I $P(CLASS,U,7)'="M" Q ; Only Mandatory Inservice
.S CLASSTXT=$P(CLASS,U),FREQ=$P(CLASS,U,6)
.I 'NSP,NSPC=CLASSTXT S ONELOC=1
.S CLASSTXT(0)=$S(NURS132:CLASSTXT,1:$E(CLASSTXT,1,39))
.S:CLASSTXT(0)="" CLASSTXT(0)=" BLANK"
.I 'NSP,NSPC'=CLASSTXT Q
.I NURSPEC]"",$G(^TMP("NURE",$J,"DA",DA))'>0 D
..S TMP=$G(^TMP("NURE",$J,"%",NURFAC(2),NURPROG(2),NURSPEC)) S:TMP="01" TMP=0 S $P(TMP,U)=$P(TMP,U)+1
..S ^TMP("NURE",$J,"%",NURFAC(2),NURPROG(2),NURSPEC)=TMP,^TMP("NURE",$J,"DA",DA)=1
..Q
.S DATE=$O(^PRSE(452,"AA","M",VA200DA,CLASSTXT,0))
.S LASTDATE=$S(DATE:9999999-DATE\1,1:0)
.I $E(LASTDATE,6,7)="00" D
..N MONTH,YEAR
..S MONTH=+$E(LASTDATE,4,5),YEAR=1700+$E(LASTDATE,1,3)
..S LASTDAY=$S(YEAR#400=0:1,YEAR#4=0&'(YEAR#100=0):1,1:0)
..S LASTDAY=$P("31^"_(28+LASTDAY)_"^31^30^31^30^31^31^30^31^30^31",U,MONTH)
..S LASTDATE=$E(LASTDATE,1,5)_LASTDAY
..Q
.S X1=LASTDATE,X2=FREQ*365.25 D C^%DTC S DROPDEAD=X
.I FREQ=0,DATE Q ; ONE TIME ONLY CLASS
.I DROPDEAD>YREND Q
.I DROPDEAD'<YRST,DROPDEAD'>YREND,DROPDEAD'<DT Q
.I $G(CLASSNUM)'>0 S CLASSNUM=1
.S CLASSNUM(0)=+$G(^TMP("NURE",$J,"SORT1",NURFAC(2),NURPROG(2),NURSPEC,NURSPEC(1)))
.I CLASSNUM(0)'>0 D
..S CLASSNUM(0)=CLASSNUM,CLASSNUM=CLASSNUM+1
..S ^TMP("NURE",$J,"SORT1",NURFAC(2),NURPROG(2),NURSPEC,NURSPEC(1))=CLASSNUM(0)
..Q
.S ^TMP("NURE",$J,"SORT2",CLASSNUM(0),PRSENAM,CLASSTXT(0))=DROPDEAD
.I NURSPEC]"",$G(^TMP("NURE",$J,"DA",DA))'>1 D
..S TMP=$G(^TMP("NURE",$J,"%",NURFAC(2),NURPROG(2),NURSPEC)),$P(TMP,U,2)=$P(TMP,U,2)+1
..S ^TMP("NURE",$J,"%",NURFAC(2),NURPROG(2),NURSPEC)=TMP,^TMP("NURE",$J,"DA",DA)=2
..Q
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURSEPD2 5619 printed Dec 13, 2024@02:22:07 Page 2
NURSEPD2 ;HIRMFO/JH,RM-INCOMPLETE NURS M I REPORT (BY CLASS) PART 1 OF 2 ;3/19/98 13:28
+1 ;;4.0;NURSING SERVICE;**2,3,10,9**;Apr 25, 1997
EN1 SET X=$GET(^PRSE(452.7,1,"OFF"))
if X=""!(X=1)
QUIT
+1 SET X=$GET(^DIC(213.9,1,"OFF"))
if X=""!(X=1)
QUIT
+2 SET (NONE,NUROUT,NURQUEUE,NURSW1)=0
DO EN1^NURSAUTL
if $GET(NUROUT)
GOTO QUIT
+3 IF NURPLSW=1
DO EN13^NURSAGSP
if $GET(NUROUT)
GOTO QUIT
+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 NURPLSCR=1
DO PRD^NURSAGSP
KILL NURPLSCR
IF $GET(NUROUT)
GOTO QUIT
+6 DO EN10^NURSUT3($GET(DUZ))
SET DATSEL="NS^N+"
DO DATSEL^NURSAGP2
if $GET(NUROUT)
GOTO QUIT
+7 SET NURSEL="M"
DO EN5^NURSAGP1
if $GET(NUROUT)
GOTO QUIT
+8 IF NURPLSW=0!($GET(NURSEL(1))=1)!($GET(NURSEL(1))="")
WRITE !
DO EN1^NURSAGSP
if $GET(NUROUT)
GOTO QUIT
+9 IF NURPLSW=1
IF $GET(NURSEL(1))=2
WRITE !
DO EN3^NURSAGSP
if $GET(NUROUT)
GOTO QUIT
+10 WRITE !
SET ZTRTN="START^NURSEPD2"
SET ZTDESC="M.I. DEFICIENCY by SVC-CATEGORY/LOCATION-PROGRAM/CLASS"
DO EN7^NURSUT0
if POP!($DATA(ZTSK))
GOTO QUIT
START ;DEFINE OUTPUT DATE/HEADERS
+1 SET NURS132=$SELECT(IOM'<132:1,1:0)
KILL ^TMP("NURE",$JOB)
USE IO
SET (HOLD,HOLD1,HOLD2,COUNT)=0
+2 SET DA=0
FOR
SET DA=$ORDER(^NURSF(210,DA))
if DA'>0
QUIT
IF $PIECE($GET(^NURSF(210,DA,0)),U,2)'="R"
DO MAINLOOP
+3 DO ^NURSEPD3
QUIT ;KILL LOCAL VARIABLES
+1 KILL ^TMP("NURE",$JOB)
DO CLOSE^NURSUT1
DO ^NURSKILL
+2 KILL NURCLAS,NURD0,NURIEN
QUIT
MAINLOOP ;
+1 SET VA200DA=+$GET(^NURSF(210,DA,0))
SET SSN=$PIECE($GET(^VA(200,VA200DA,1)),U,9)
if $GET(SSN)=""
QUIT
SET PDA=$ORDER(^PRSPC("SSN",SSN,0))
if $GET(PDA)'>0
QUIT
DO SETMP
+2 IF $GET(NURSEL(1))=1
Begin DoDot:1
+3 IF $GET(NURSPEC)=""
SET NONE=1
QUIT
+4 SET NURDA=0
FOR
SET NURDA=$ORDER(^NURSF(211.4,NURDA))
if NURDA'>0
QUIT
IF $GET(^NURSF(211.4,+NURDA,"I"))="A"
Begin DoDot:2
+5 SET NPWARD=+$GET(^NURSF(211.4,NURDA,0))
DO EN7^NURSAUTL
+6 if NURSZAP>6&('$DATA(NURSZLO(NURDA)))
QUIT
+7 IF $GET(NURHOSP)=0
IF '$DATA(NURSNLOC(NPWARD))
QUIT
+8 SET NURSPEC=NPWARD
DO CHECK
if NUROUT
QUIT
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT
CHECK SET NURFAC(2)=$$EN12^NURSUT3(NURDA)
SET X=$PIECE($GET(^NURSF(211.4,+NURDA,1)),U,4)
SET NURPROG(2)=$SELECT($DATA(^NURSF(212.7,+X,0)):$PIECE(^(0),U),1:" BLANK")
if NURPROG(2)="NURSING"
SET NURPROG(2)=" NURSING"
IF NURFAC(2)=" BLANK"!(NURPROG(2))=" BLANK"
SET NUROUT=1
QUIT
+1 IF $GET(NSP)!($GET(NSP)'>0&(NURSPEC'=""))
IF '$DATA(^TMP("NURE",$JOB,"SORT1",NURFAC(2),NURPROG(2),NURSPEC))
SET ^(NURSPEC)=""
SET ^TMP("NURE",$JOB,"%",NURFAC(2),NURPROG(2),NURSPEC)="01"
+2 QUIT
SETMP SET X(0)=$GET(^PRSPC(PDA,0))
SET X(1)=$GET(^(1))
if ($PIECE(X(1),U,33)="Y")
QUIT
+1 SET PRSENAM=$PIECE(X(0),U)
+2 FOR NURNODE4=0:0
SET NURNODE4=$ORDER(^NURSF(211.8,"C",VA200DA,NURNODE4))
if NURNODE4'>0
QUIT
Begin DoDot:1
+3 FOR NURNODE5=0:0
SET NURNODE5=$ORDER(^NURSF(211.8,"C",VA200DA,NURNODE4,NURNODE5))
if NURNODE5'>0
QUIT
IF $DATA(^NURSF(211.8,NURNODE4,1,NURNODE5,0))
IF $PIECE(^(0),U)'>DT&(('$PIECE(^(0),U,6))!($PIECE(^(0),U,6)'<DT))
Begin DoDot:2
+4 SET DA=$ORDER(^NURSF(210,"B",VA200DA,0))
IF $PIECE($GET(^NURSF(210,+DA,0)),U,2)'=""
IF $PIECE($GET(^(0)),U,2)'="R"
if $RANDOM(500)&($EXTRACT(IOST)="C")
WRITE "."
DO SORT
End DoDot:2
End DoDot:1
+5 QUIT
SORT ;
+1 if NURSZAP>7&(NURSZDA'=DA)
QUIT
SET NURSZORT=1
if NURSZAP>6
DO EN3^NURSAUTL
if NURSZORT&NURSZAP
DO EN2^NURSAUTL
if 'NURSZORT
QUIT
+2 SET NURNEN=$SELECT($GET(NURSEL(1))=2:1,1:3)
DO SETFAC^NURAAGS1
DO SETPROG^NURAAGS1
DO SETCAT^NURAAGS1
DO SETLOC^NURAAGS1
+3 IF NURMDSW
IF '$GET(NURFAC)
IF $GET(NURFAC(1))'=$GET(NURFAC(2))
QUIT
+4 IF NURPLSW
IF '$GET(NURPROG)
IF $GET(NURPROG(1))'=$GET(NURPROG(2))
QUIT
+5 if NURPROG(2)="NURSING"
SET NURPROG(2)=" "_NURPROG(2)
+6 SET NURNODE4(1)=$SELECT($DATA(^NURSF(211.4,"B",+NLOCN)):$ORDER(^NURSF(211.4,"B",+NLOCN,0)),1:0)
IF $DATA(^NURSF(211.4,NURNODE4(1),"I"))
IF ^("I")'="A"
QUIT
+7 IF $GET(NURSEL(1))=1!($GET(NURSEL(1))="")
SET NURSPEC=$SELECT(NLOCN(1)="":" BLANK",1:NLOCN(1))
SET NURSPEC(1)=$$CAT^NURSUT2(NURSCATY)
+8 IF $GET(NURSEL(1))=2
SET NURSPEC=$$CAT^NURSUT2(NURSCATY)
SET NURSPEC(1)=$SELECT(NLOCN(1)="":" BLANK",1:NLOCN(1))
+9 IF NURNEN=1
IF $SELECT($EXTRACT(NURSCATY)'="O":'$DATA(^TMP("NURSCAT",$JOB,NURSCATY)),$PIECE($GET(NURSCATY),"O ",2)'="":'$DATA(^TMP("NURSCAT",$JOB,$EXTRACT(NURSCATY,3,99))),$PIECE($GET(NURSCATY),"O ",2)="":'$DATA(^TMP("NURSCAT",$JOB,NURSCATY)),1:0)
QUIT
+10 IF $GET(NURHOSP)=0
IF '$DATA(NURSNLOC(NURSPEC))
QUIT
+11 SET NAM=$SELECT($PIECE(^VA(200,VA200DA,0),U)'="":$PIECE(^(0),U),1:" BLANK")
+12 if $EXTRACT(IOST)="C"
WRITE "."
+13 FOR D1=0:0
SET D1=$ORDER(^PRSPC(PDA,6,D1))
if D1'>0
QUIT
Begin DoDot:1
+14 KILL DROPDEAD
+15 SET NURS=$GET(^PRSPC(PDA,6,D1,0))
SET CLASSIEN=+$PIECE(NURS,U)
if CLASSIEN'>0
QUIT
+16 if $SELECT($PIECE(NURS,U,3)'>0
QUIT
+17 SET CLASS=$GET(^PRSE(452.1,CLASSIEN,0))
if CLASS=""
QUIT
+18 ; Only Mandatory Inservice
IF $PIECE(CLASS,U,7)'="M"
QUIT
+19 SET CLASSTXT=$PIECE(CLASS,U)
SET FREQ=$PIECE(CLASS,U,6)
+20 IF 'NSP
IF NSPC=CLASSTXT
SET ONELOC=1
+21 SET CLASSTXT(0)=$SELECT(NURS132:CLASSTXT,1:$EXTRACT(CLASSTXT,1,39))
+22 if CLASSTXT(0)=""
SET CLASSTXT(0)=" BLANK"
+23 IF 'NSP
IF NSPC'=CLASSTXT
QUIT
+24 IF NURSPEC]""
IF $GET(^TMP("NURE",$JOB,"DA",DA))'>0
Begin DoDot:2
+25 SET TMP=$GET(^TMP("NURE",$JOB,"%",NURFAC(2),NURPROG(2),NURSPEC))
if TMP="01"
SET TMP=0
SET $PIECE(TMP,U)=$PIECE(TMP,U)+1
+26 SET ^TMP("NURE",$JOB,"%",NURFAC(2),NURPROG(2),NURSPEC)=TMP
SET ^TMP("NURE",$JOB,"DA",DA)=1
+27 QUIT
End DoDot:2
+28 SET DATE=$ORDER(^PRSE(452,"AA","M",VA200DA,CLASSTXT,0))
+29 SET LASTDATE=$SELECT(DATE:9999999-DATE\1,1:0)
+30 IF $EXTRACT(LASTDATE,6,7)="00"
Begin DoDot:2
+31 NEW MONTH,YEAR
+32 SET MONTH=+$EXTRACT(LASTDATE,4,5)
SET YEAR=1700+$EXTRACT(LASTDATE,1,3)
+33 SET LASTDAY=$SELECT(YEAR#400=0:1,YEAR#4=0&'(YEAR#100=0):1,1:0)
+34 SET LASTDAY=$PIECE("31^"_(28+LASTDAY)_"^31^30^31^30^31^31^30^31^30^31",U,MONTH)
+35 SET LASTDATE=$EXTRACT(LASTDATE,1,5)_LASTDAY
+36 QUIT
End DoDot:2
+37 SET X1=LASTDATE
SET X2=FREQ*365.25
DO C^%DTC
SET DROPDEAD=X
+38 ; ONE TIME ONLY CLASS
IF FREQ=0
IF DATE
QUIT
+39 IF DROPDEAD>YREND
QUIT
+40 IF DROPDEAD'<YRST
IF DROPDEAD'>YREND
IF DROPDEAD'<DT
QUIT
+41 IF $GET(CLASSNUM)'>0
SET CLASSNUM=1
+42 SET CLASSNUM(0)=+$GET(^TMP("NURE",$JOB,"SORT1",NURFAC(2),NURPROG(2),NURSPEC,NURSPEC(1)))
+43 IF CLASSNUM(0)'>0
Begin DoDot:2
+44 SET CLASSNUM(0)=CLASSNUM
SET CLASSNUM=CLASSNUM+1
+45 SET ^TMP("NURE",$JOB,"SORT1",NURFAC(2),NURPROG(2),NURSPEC,NURSPEC(1))=CLASSNUM(0)
+46 QUIT
End DoDot:2
+47 SET ^TMP("NURE",$JOB,"SORT2",CLASSNUM(0),PRSENAM,CLASSTXT(0))=DROPDEAD
+48 IF NURSPEC]""
IF $GET(^TMP("NURE",$JOB,"DA",DA))'>1
Begin DoDot:2
+49 SET TMP=$GET(^TMP("NURE",$JOB,"%",NURFAC(2),NURPROG(2),NURSPEC))
SET $PIECE(TMP,U,2)=$PIECE(TMP,U,2)+1
+50 SET ^TMP("NURE",$JOB,"%",NURFAC(2),NURPROG(2),NURSPEC)=TMP
SET ^TMP("NURE",$JOB,"DA",DA)=2
+51 QUIT
End DoDot:2
+52 QUIT
End DoDot:1
+53 QUIT
