- NURAAGS0 ;HIRMFO/RM,JH,MD-MULTIDIVISIONAL GENERIC SORT ROUTINE FOR ADMIN REPORTS ;11/18/96
- ;;4.0;NURSING SERVICE;;Apr 25, 1997
- EN1 ; SER.CAT-SPEC. SORT
- S NURNEN=1 D ACSORT
- G Q
- EN2 ; PRIO.SQ.-SER.POS.-SPEC. SORT
- I 'NURSER S NURNEN=2 D CSORT G Q
- S NURNEN=2 D ACSORT
- G Q
- EN3 ; LOC-SER.CAT.-SPEC. SORT
- S NURNEN=3
- I 'NURHOSP D ESORT G Q
- D ACSORT,EN4^NURSAUTL:NURSZAP=7
- G Q
- EN4 ; LOC.-PRIO.SQ.-SER.POS.-SPEC. SORT
- S NURNEN=4
- I 'NURHOSP D ESORT G Q
- D ACSORT,EN4^NURSAUTL:NURSZAP=7
- Q K D0,DA,NURNEN,NLOCN,NNM,NPRI,NURSCATY,NSPEC,NPODA,NSPOSN,NURSZORT,NPWARD,NURNODE4,NUREQWRD,NURCAT,NURFLAG,NURSCAT,NURSZ
- Q
- ACSORT ; SORT FROM NURSING "AC" & "C" XREF
- S Z="" F S Z=$O(^NURSF(210,"AC",Z)) Q:Z="" I Z'="R" S DA=0 F S DA=$O(^NURSF(210,"AC",Z,DA)) Q:DA'>0 I +$G(^NURSF(210,DA,0)) S DA(1)=+^(0) D:$D(^VA(200,DA(1),0))
- .S NURNODE4=0 F S NURNODE4=$O(^NURSF(211.8,"C",DA(1),NURNODE4)) Q:NURNODE4'>0 S NURNODE5=0 F S NURNODE5=$O(^NURSF(211.8,"C",DA(1),NURNODE4,NURNODE5)) Q:NURNODE5'>0 D CHKPOS^NURAAGS1 D:+NURNEN(1) SETVAR
- .Q
- Q
- ESORT ; SORT FROM NURSING "B" XREF
- S NURSZ="" F S NURSZ=$O(NURSNLOC(NURSZ)) Q:NURSZ="" S NURSIEN=0 F S NURSIEN=$O(NURSNLOC(NURSZ,NURSIEN)) Q:NURSIEN'>0 S NUREQWRD=+$G(NURSNLOC(NURSZ,NURSIEN)) D:+NUREQWRD
- .S NURNODE4=0 F S NURNODE4=$O(^NURSF(211.8,"B",NUREQWRD,NURNODE4)) Q:NURNODE4'>0 S NURNODE5=0 F S NURNODE5=$O(^NURSF(211.8,NURNODE4,1,NURNODE5)) Q:NURNODE5'>0 D CHKPOS^NURAAGS1 D:+NURNEN(1)
- ..S DA(1)=$S($D(^NURSF(211.8,NURNODE4,1,NURNODE5,0)):$P(^(0),U,2),1:""),DA=$O(^NURSF(210,"B",DA(1),0)) I (+DA>0),'$D(^NURSF(210,"AC","R",+DA)),$D(^VA(200,DA(1),0)) D SETVAR
- ..Q
- .Q
- Q
- CSORT ; SORT FROM NURSING "D" XREF
- S DA(1)=0 F S DA(1)=$O(^NURSF(211.8,"AD",DA(1))) Q:DA(1)'>0 S NURNODE4=0 F S NURNODE4=$O(^NURSF(211.8,"AD",DA(1),NPOS,NURNODE4)) Q:NURNODE4'>0 D
- .S NURNODE5=0 F S NURNODE5=$O(^NURSF(211.8,"AD",DA(1),NPOS,NURNODE4,NURNODE5)) Q:NURNODE5'>0 S DA=$O(^NURSF(210,"B",DA(1),0)) I $P($G(^NURSF(210,+DA,0)),U,2)'="R",'$D(^NURSF(210,"AC","R",+DA)) D CHKPOS^NURAAGS1 D:NURNEN(1) SETVAR
- .Q
- Q
- SETVAR ; SET SUBSCRIPTS FOR GLOBAL SET
- S NURSZORT=1 I NRPT=10 S:NURSZAP&(NURSZDA'=DA)&(NURSZAP>7) NURSZORT=0
- E D EN3^NURSAUTL:NURSZAP>6,EN2^NURSAUTL:NURSZORT&NURSZAP
- Q:'NURSZORT
- D SETCAT^NURAAGS1:NURNEN=1!(NURNEN=3),SETPOS^NURAAGS1:NURNEN=2!(NURNEN=4),SETFAC^NURAAGS1,SETPROG^NURAAGS1,SETLOC^NURAAGS1
- I $D(^NURSF(211.4,"B",+NLOCN)) S NLOCN(2)=$O(^NURSF(211.4,"B",+NLOCN,0)) I $D(^NURSF(211.4,NLOCN(2),"I")),$E($P(^("I"),U))="I" Q
- I $G(NURMDSW),'$G(NURFAC),$G(NURFAC(1))'=$G(NURFAC(2)) Q
- I $G(NURPLSW),$G(NURPROG)=0,$G(NURPROG(1))'=$G(NURPROG(2)) Q
- I $G(NURPLSW) S:NURPROG(2)="NURSING" NURPROG(2)=" NURSING"
- I (NURNEN=3!(NURNEN=4)),'NURHOSP,'$D(NURSNLOC(NLOCN(1))) Q
- I (NURNEN=1!(NURNEN=3)),$S($E(NURSCATY)'="O":'$D(^TMP("NURSCAT",$J,$E(NURSCATY))),$P($G(NURSCATY),"O ",2)="":'$D(^TMP("NURSCAT",$J,$E(NURSCATY))),$P($G(NURSCATY),"O ",2)'="":'$D(^TMP("NURSCAT",$J,$E(NURSCATY,3,99))),1:0) Q
- I (NURNEN=2!(NURNEN=4)) S NPODA=$O(^NURSF(211.3,"B",NSPOSN,"")) Q:NPODA="" Q:'$D(^NURSF(211.3,NPODA,0)) I $S((NRPT=6!(NRPT=2))&NURSER&($P(^NURSF(211.3,NPODA,0),U,5)'="R"):1,NURSER:0,NPOS'=NPODA:1,1:0) Q
- Q:'$D(^VA(200,DA(1),0)) S NNM=$S($P(^VA(200,DA(1),0),U)'="":$P(^(0),U),1:"VA # "_DA(1))
- K NSPEC I NRPT=1 I $P($G(^NURSF(210,DA,17)),U,2)'="",$D(^NURSF(212.1,$P(^NURSF(210,DA,17),U,2),0)),$P(^(0),U,3)'="" S NSPEC=$P(^(0),U,3)
- I NRPT=2 S D0=0 F S D0=$O(^NURSF(210,DA,12,D0)) Q:D0'>0 D SETCERT^NURAAGS1
- I NRPT=3 Q:$S('$D(^NURSF(211.8,NURNODE4,1,NURNODE5,0)):1,NURSZAP<7:0,$D(NURSZLO($O(^NURSF(211.4,"B",+$P(^NURSF(211.8,NURNODE4,0),U),"")))):0,1:1) I $P($G(^NURSF(211.8,NURNODE4,1,NURNODE5,0)),U,4)'="" S NSPEC=$P(^(0),U,4)
- I NRPT=4 I $P($G(^VA(200,DA(1),1)),U,2)'="" S NSPEC=$P(^(1),U,2)
- I NRPT=5 I $P($G(^NURSF(210,DA,7)),U,1)'="",$P($G(^NURSF(211.1,$P(^NURSF(210,DA,7),U,1),0)),U,1)'="" S NSPEC=$P(^(0),U,1)
- I NRPT=6 I $P($G(^NURSF(210,DA,17)),U,1),$P($G(^NURSF(212.1,$P(^NURSF(210,DA,17),U,1),0)),U,1)'="" S NSPEC=$P(^(0),U,3)
- I NRPT=7 I $D(^VA(200,DA(1),1)) S NSPEC=$S(+$P(^(1),U,3):$P(^(1),U,3),1:"BLANK") I 'NSP,(+NSPEC<NSPC!(+NSPEC>NSPC(1))) Q
- I NRPT=8 S D0=0 F S D0=$O(^NURSF(210,DA,4,D0)) Q:D0'>0 D
- .I '$G(NSTAT),$G(NSTAT(1))'=+$G(^NURSF(210,DA,4,D0,0)) Q
- .D:NURSCATY="R"!(NURSCATY="L")!($E(NURSCATY)="O") SETLIC^NURAAGS1,SETUPTL^NURAAGS1:$S(NSP:1,$E(NSPEC,1,7)'<NSPC&($E(NSPEC,1,7)'>NSPC(2)):1,1:0)
- .Q
- I NRPT=8,'$O(^NURSF(210,DA,4,0)),NURSCATY="R"!(NURSCATY="L")!($E(NURSCATY)="O") S NSPEC=" BLANK"_0 D SETUPTL^NURAAGS1:$S(NSP:1,$E(NSPEC,1,7)'<NSPC&($E(NSPEC,1,7)'>NSPC(2)):1,1:0)
- I NRPT=9 S D0=0 F S D0=$O(^NURSF(210,DA,10,D0)) Q:D0'>0 D SETMIL^NURAAGS1
- I NRPT=10 S:$G(NURSORT)="" NURSORT=1 D Q
- .I NURPLSW,NURPROG(2)'=" BLANK" S NURPROG(3)=+$O(^NURSF(212.7,"NURSING",0)),NURPROG(3)=$$GET1^DIQ(212.7,NURPROG(3),.01,"I")
- .N X S X=$G(^TMP($J,"L",NURFAC(2),NURPROG(2),NLOCN(1),NPRI,NSPOSN))
- .W:$E(IOST)="C"&($R(100)) "." I X="" S X=NURSORT,NURSORT=NURSORT+1,^TMP($J,"L",NURFAC(2),NURPROG(2),NLOCN(1),NPRI,NSPOSN)=X
- .S ^TMP($J,"L1",X,NNM,DA,NURNODE4)=""
- .Q
- Q:(NRPT=2)!(NRPT=8)!(NRPT=9)
- I NRPT=6,$D(NURSCATY),NURSCATY'="R" Q
- I NRPT=6,$D(NSPOSN),1=$S($O(^NURSF(211.3,"B",NSPOSN,""))="":0,$P(^NURSF(211.3,$O(^NURSF(211.3,"B",NSPOSN,"")),0),U,5)'="R":1,1:0) Q
- I '$D(NSPEC) S NSPEC=" BLANK"
- Q:NRPT=1!(NRPT=7)&(NSPEC=" BLANK")
- I NRPT'=7,'NSP,NSPC'=NSPEC Q
- D SETUPTL^NURAAGS1 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURAAGS0 5448 printed Jan 18, 2025@03:19:55 Page 2
- NURAAGS0 ;HIRMFO/RM,JH,MD-MULTIDIVISIONAL GENERIC SORT ROUTINE FOR ADMIN REPORTS ;11/18/96
- +1 ;;4.0;NURSING SERVICE;;Apr 25, 1997
- EN1 ; SER.CAT-SPEC. SORT
- +1 SET NURNEN=1
- DO ACSORT
- +2 GOTO Q
- EN2 ; PRIO.SQ.-SER.POS.-SPEC. SORT
- +1 IF 'NURSER
- SET NURNEN=2
- DO CSORT
- GOTO Q
- +2 SET NURNEN=2
- DO ACSORT
- +3 GOTO Q
- EN3 ; LOC-SER.CAT.-SPEC. SORT
- +1 SET NURNEN=3
- +2 IF 'NURHOSP
- DO ESORT
- GOTO Q
- +3 DO ACSORT
- if NURSZAP=7
- DO EN4^NURSAUTL
- +4 GOTO Q
- EN4 ; LOC.-PRIO.SQ.-SER.POS.-SPEC. SORT
- +1 SET NURNEN=4
- +2 IF 'NURHOSP
- DO ESORT
- GOTO Q
- +3 DO ACSORT
- if NURSZAP=7
- DO EN4^NURSAUTL
- Q KILL D0,DA,NURNEN,NLOCN,NNM,NPRI,NURSCATY,NSPEC,NPODA,NSPOSN,NURSZORT,NPWARD,NURNODE4,NUREQWRD,NURCAT,NURFLAG,NURSCAT,NURSZ
- +1 QUIT
- ACSORT ; SORT FROM NURSING "AC" & "C" XREF
- +1 SET Z=""
- FOR
- SET Z=$ORDER(^NURSF(210,"AC",Z))
- if Z=""
- QUIT
- IF Z'="R"
- SET DA=0
- FOR
- SET DA=$ORDER(^NURSF(210,"AC",Z,DA))
- if DA'>0
- QUIT
- IF +$GET(^NURSF(210,DA,0))
- SET DA(1)=+^(0)
- if $DATA(^VA(200,DA(1),0))
- Begin DoDot:1
- +2 SET NURNODE4=0
- FOR
- SET NURNODE4=$ORDER(^NURSF(211.8,"C",DA(1),NURNODE4))
- if NURNODE4'>0
- QUIT
- SET NURNODE5=0
- FOR
- SET NURNODE5=$ORDER(^NURSF(211.8,"C",DA(1),NURNODE4,NURNODE5))
- if NURNODE5'>0
- QUIT
- DO CHKPOS^NURAAGS1
- if +NURNEN(1)
- DO SETVAR
- +3 QUIT
- End DoDot:1
- +4 QUIT
- ESORT ; SORT FROM NURSING "B" XREF
- +1 SET NURSZ=""
- FOR
- SET NURSZ=$ORDER(NURSNLOC(NURSZ))
- if NURSZ=""
- QUIT
- SET NURSIEN=0
- FOR
- SET NURSIEN=$ORDER(NURSNLOC(NURSZ,NURSIEN))
- if NURSIEN'>0
- QUIT
- SET NUREQWRD=+$GET(NURSNLOC(NURSZ,NURSIEN))
- if +NUREQWRD
- Begin DoDot:1
- +2 SET NURNODE4=0
- FOR
- SET NURNODE4=$ORDER(^NURSF(211.8,"B",NUREQWRD,NURNODE4))
- if NURNODE4'>0
- QUIT
- SET NURNODE5=0
- FOR
- SET NURNODE5=$ORDER(^NURSF(211.8,NURNODE4,1,NURNODE5))
- if NURNODE5'>0
- QUIT
- DO CHKPOS^NURAAGS1
- if +NURNEN(1)
- Begin DoDot:2
- +3 SET DA(1)=$SELECT($DATA(^NURSF(211.8,NURNODE4,1,NURNODE5,0)):$PIECE(^(0),U,2),1:"")
- SET DA=$ORDER(^NURSF(210,"B",DA(1),0))
- IF (+DA>0)
- IF '$DATA(^NURSF(210,"AC","R",+DA))
- IF $DATA(^VA(200,DA(1),0))
- DO SETVAR
- +4 QUIT
- End DoDot:2
- +5 QUIT
- End DoDot:1
- +6 QUIT
- CSORT ; SORT FROM NURSING "D" XREF
- +1 SET DA(1)=0
- FOR
- SET DA(1)=$ORDER(^NURSF(211.8,"AD",DA(1)))
- if DA(1)'>0
- QUIT
- SET NURNODE4=0
- FOR
- SET NURNODE4=$ORDER(^NURSF(211.8,"AD",DA(1),NPOS,NURNODE4))
- if NURNODE4'>0
- QUIT
- Begin DoDot:1
- +2 SET NURNODE5=0
- FOR
- SET NURNODE5=$ORDER(^NURSF(211.8,"AD",DA(1),NPOS,NURNODE4,NURNODE5))
- if NURNODE5'>0
- QUIT
- SET DA=$ORDER(^NURSF(210,"B",DA(1),0))
- IF $PIECE($GET(^NURSF(210,+DA,0)),U,2)'="R"
- IF '$DATA(^NURSF(210,"AC","R",+DA))
- DO CHKPOS^NURAAGS1
- if NURNEN(1)
- DO SETVAR
- +3 QUIT
- End DoDot:1
- +4 QUIT
- SETVAR ; SET SUBSCRIPTS FOR GLOBAL SET
- +1 SET NURSZORT=1
- IF NRPT=10
- if NURSZAP&(NURSZDA'=DA)&(NURSZAP>7)
- SET NURSZORT=0
- +2 IF '$TEST
- if NURSZAP>6
- DO EN3^NURSAUTL
- if NURSZORT&NURSZAP
- DO EN2^NURSAUTL
- +3 if 'NURSZORT
- QUIT
- +4 if NURNEN=1!(NURNEN=3)
- DO SETCAT^NURAAGS1
- if NURNEN=2!(NURNEN=4)
- DO SETPOS^NURAAGS1
- DO SETFAC^NURAAGS1
- DO SETPROG^NURAAGS1
- DO SETLOC^NURAAGS1
- +5 IF $DATA(^NURSF(211.4,"B",+NLOCN))
- SET NLOCN(2)=$ORDER(^NURSF(211.4,"B",+NLOCN,0))
- IF $DATA(^NURSF(211.4,NLOCN(2),"I"))
- IF $EXTRACT($PIECE(^("I"),U))="I"
- QUIT
- +6 IF $GET(NURMDSW)
- IF '$GET(NURFAC)
- IF $GET(NURFAC(1))'=$GET(NURFAC(2))
- QUIT
- +7 IF $GET(NURPLSW)
- IF $GET(NURPROG)=0
- IF $GET(NURPROG(1))'=$GET(NURPROG(2))
- QUIT
- +8 IF $GET(NURPLSW)
- if NURPROG(2)="NURSING"
- SET NURPROG(2)=" NURSING"
- +9 IF (NURNEN=3!(NURNEN=4))
- IF 'NURHOSP
- IF '$DATA(NURSNLOC(NLOCN(1)))
- QUIT
- +10 IF (NURNEN=1!(NURNEN=3))
- IF $SELECT($EXTRACT(NURSCATY)'="O":'$DATA(^TMP("NURSCAT",$JOB,$EXTRACT(NURSCATY))),$PIECE($GET(NURSCATY),"O ",2)="":'$DATA(^TMP("NURSCAT",$JOB,$EXTRACT(NURSCATY))),$PIECE($GET(NURSCATY),"O ",2)'="":'$DATA(^TMP("NURSCAT",$JOB,...
- ... $EXTRACT(NURSCATY,3,99))),1:0)
- QUIT
- +11 IF (NURNEN=2!(NURNEN=4))
- SET NPODA=$ORDER(^NURSF(211.3,"B",NSPOSN,""))
- if NPODA=""
- QUIT
- if '$DATA(^NURSF(211.3,NPODA,0))
- QUIT
- IF $SELECT((NRPT=6!(NRPT=2))&NURSER&($PIECE(^NURSF(211.3,NPODA,0),U,5)'="R"):1,NURSER:0,NPOS'=NPODA:1,1:0)
- QUIT
- +12 if '$DATA(^VA(200,DA(1),0))
- QUIT
- SET NNM=$SELECT($PIECE(^VA(200,DA(1),0),U)'="":$PIECE(^(0),U),1:"VA # "_DA(1))
- +13 KILL NSPEC
- IF NRPT=1
- IF $PIECE($GET(^NURSF(210,DA,17)),U,2)'=""
- IF $DATA(^NURSF(212.1,$PIECE(^NURSF(210,DA,17),U,2),0))
- IF $PIECE(^(0),U,3)'=""
- SET NSPEC=$PIECE(^(0),U,3)
- +14 IF NRPT=2
- SET D0=0
- FOR
- SET D0=$ORDER(^NURSF(210,DA,12,D0))
- if D0'>0
- QUIT
- DO SETCERT^NURAAGS1
- +15 IF NRPT=3
- if $SELECT('$DATA(^NURSF(211.8,NURNODE4,1,NURNODE5,0))
- QUIT
- IF $PIECE($GET(^NURSF(211.8,NURNODE4,1,NURNODE5,0)),U,4)'=""
- SET NSPEC=$PIECE(^(0),U,4)
- +16 IF NRPT=4
- IF $PIECE($GET(^VA(200,DA(1),1)),U,2)'=""
- SET NSPEC=$PIECE(^(1),U,2)
- +17 IF NRPT=5
- IF $PIECE($GET(^NURSF(210,DA,7)),U,1)'=""
- IF $PIECE($GET(^NURSF(211.1,$PIECE(^NURSF(210,DA,7),U,1),0)),U,1)'=""
- SET NSPEC=$PIECE(^(0),U,1)
- +18 IF NRPT=6
- IF $PIECE($GET(^NURSF(210,DA,17)),U,1)
- IF $PIECE($GET(^NURSF(212.1,$PIECE(^NURSF(210,DA,17),U,1),0)),U,1)'=""
- SET NSPEC=$PIECE(^(0),U,3)
- +19 IF NRPT=7
- IF $DATA(^VA(200,DA(1),1))
- SET NSPEC=$SELECT(+$PIECE(^(1),U,3):$PIECE(^(1),U,3),1:"BLANK")
- IF 'NSP
- IF (+NSPEC<NSPC!(+NSPEC>NSPC(1)))
- QUIT
- +20 IF NRPT=8
- SET D0=0
- FOR
- SET D0=$ORDER(^NURSF(210,DA,4,D0))
- if D0'>0
- QUIT
- Begin DoDot:1
- +21 IF '$GET(NSTAT)
- IF $GET(NSTAT(1))'=+$GET(^NURSF(210,DA,4,D0,0))
- QUIT
- +22 if NURSCATY="R"!(NURSCATY="L")!($EXTRACT(NURSCATY)="O")
- DO SETLIC^NURAAGS1
- if $SELECT(NSP:1,$EXTRACT(NSPEC,1,7)'<NSPC&($EXTRACT(NSPEC,1,7)'>NSPC(2)):1,1:0)
- DO SETUPTL^NURAAGS1
- +23 QUIT
- End DoDot:1
- +24 IF NRPT=8
- IF '$ORDER(^NURSF(210,DA,4,0))
- IF NURSCATY="R"!(NURSCATY="L")!($EXTRACT(NURSCATY)="O")
- SET NSPEC=" BLANK"_0
- if $SELECT(NSP:1,$EXTRACT(NSPEC,1,7)'<NSPC&($EXTRACT(NSPEC,1,7)'>NSPC(2)):1,1:0)
- DO SETUPTL^NURAAGS1
- +25 IF NRPT=9
- SET D0=0
- FOR
- SET D0=$ORDER(^NURSF(210,DA,10,D0))
- if D0'>0
- QUIT
- DO SETMIL^NURAAGS1
- +26 IF NRPT=10
- if $GET(NURSORT)=""
- SET NURSORT=1
- Begin DoDot:1
- +27 IF NURPLSW
- IF NURPROG(2)'=" BLANK"
- SET NURPROG(3)=+$ORDER(^NURSF(212.7,"NURSING",0))
- SET NURPROG(3)=$$GET1^DIQ(212.7,NURPROG(3),.01,"I")
- +28 NEW X
- SET X=$GET(^TMP($JOB,"L",NURFAC(2),NURPROG(2),NLOCN(1),NPRI,NSPOSN))
- +29 if $EXTRACT(IOST)="C"&($RANDOM(100))
- WRITE "."
- IF X=""
- SET X=NURSORT
- SET NURSORT=NURSORT+1
- SET ^TMP($JOB,"L",NURFAC(2),NURPROG(2),NLOCN(1),NPRI,NSPOSN)=X
- +30 SET ^TMP($JOB,"L1",X,NNM,DA,NURNODE4)=""
- +31 QUIT
- End DoDot:1
- QUIT
- +32 if (NRPT=2)!(NRPT=8)!(NRPT=9)
- QUIT
- +33 IF NRPT=6
- IF $DATA(NURSCATY)
- IF NURSCATY'="R"
- QUIT
- +34 IF NRPT=6
- IF $DATA(NSPOSN)
- IF 1=$SELECT($ORDER(^NURSF(211.3,"B",NSPOSN,""))="":0,$PIECE(^NURSF(211.3,$ORDER(^NURSF(211.3,"B",NSPOSN,"")),0),U,5)'="R":1,1:0)
- QUIT
- +35 IF '$DATA(NSPEC)
- SET NSPEC=" BLANK"
- +36 if NRPT=1!(NRPT=7)&(NSPEC=" BLANK")
- QUIT
- +37 IF NRPT'=7
- IF 'NSP
- IF NSPC'=NSPEC
- QUIT
- +38 DO SETUPTL^NURAAGS1
- QUIT