- NURAAGS1 ;HIRMFO/RM,MD-MULTIDIVISIONAL GENERIC SORT ROUTINE FOR ADMIN REPORTS ;5/2/97
- ;;4.0;NURSING SERVICE;**1**;Apr 25, 1997
- SETCAT ; SET CATEGORY VARIABLE NURSCATY
- N X,Y
- S X=$P($G(^NURSF(211.8,NURNODE4,1,NURNODE5,0)),U,3),Y=$G(^NURSF(211.3,+X,0))
- I Y'="" S NURSCATY=$P(Y,U,5) S:NURSCATY="O" NURSCATY=NURSCATY_" "_$$UP^XLFSTR($P(Y,U,6))
- E S NURSCATY=" BLANK"
- Q
- SETLOC ; SET LOCATION VARIABLE NLOCN
- S NLOCN=$S($D(^NURSF(211.8,NURNODE4,0)):$P(^(0),U),1:"")
- I +NLOCN S NPWARD=NLOCN D EN7^NURSAUTL S NLOCN(1)=$S(NPWARD'="":$E(NPWARD,1,10),1:" BLANK")
- Q
- SETPOS ; SET SERVICE POSITION AND PRIORITY SEQUENCE VARIABLES NSPOSN,NPRI
- I $D(^NURSF(211.8,NURNODE4,1,NURNODE5,0)),$P(^(0),U,3)'="",$D(^NURSF(211.3,$P(^NURSF(211.8,NURNODE4,1,NURNODE5,0),U,3),0)) G C
- E S (NSPOSN,NPRI)=" BLANK" Q
- C I $P(^NURSF(211.3,$P(^NURSF(211.8,NURNODE4,1,NURNODE5,0),U,3),0),U,1)'="" S NSPOSN=$P(^(0),U,1)
- E S NSPOSN=" BLANK"
- I $P(^NURSF(211.3,$P(^NURSF(211.8,NURNODE4,1,NURNODE5,0),U,3),0),U,3)'="" S NPRI=$P(^(0),U,3)
- E S NPRI=" BLANK"
- Q
- SETFAC ; SET FACILITY VARIBLE NURFAC(2)
- I $G(NURMDSW) S NURFAC(2)=$$EN11^NURSUT3($G(NURNODE4)) S:NURFAC(2)="" NURFAC(2)=" BLANK"
- E S NURFAC(2)=" BLANK"
- Q
- SETPROG ; SET PRODUCT LINE VARIBLE NURPROG(2)
- I $G(NURPLSW) D
- . I NURNEN=3!(NURNEN=4) D
- . . S NURPROG(2)=$O(^NURSF(211.4,"B",+$P(^NURSF(211.8,NURNODE4,0),U),""))
- . . S NURPROG(2)=+$P($G(^NURSF(211.4,+NURPROG(2),1)),U,4)
- . . Q
- . I NURNEN=1!(NURNEN=2) D
- . . S NURPROG(2)=$P($G(^NURSF(211.8,+NURNODE4,1,+NURNODE5,0)),U,3)
- . . S NURPROG(2)=+$P($G(^NURSF(211.3,+NURPROG(2),0)),U,7)
- . . Q
- . S:NURPROG(2)="" NURPROG(2)=+$O(^NURSF(212.7,"B","NURSING",0))
- . S NURPROG(2)=$$GET1^DIQ(212.7,+NURPROG(2),.01,"I")
- . S:NURPROG(2)="" NURPROG(2)=" BLANK"
- . Q
- E S NURPROG(2)=" BLANK"
- Q
- SETCERT ; SET ^TMP($J FOR CERTIFICATION REPORTS
- S DATA=+$P($G(^NURSF(210,DA,12,D0,0)),U) I DATA>0,$P($G(^NURSF(212.2,+DATA,0)),U,2)'="" S NSPEC(1)=$P(^(0),U,2)
- E S NSPEC(1)=" BLANK"
- I $P($G(^NURSF(210,DA,12,D0,0)),U,4)'="" S NSPEC=$P(^(0),U,4)
- E S NSPEC=" BLANK"
- I 'NSP,NSPC'=NSPEC(1) Q
- I 'NSP(1),NSPEC>NSPC(2)!(NSPEC<NSPC(1)) Q
- I NSPEC(1)'=" BLANK" D SETUTIL
- Q
- SETMIL ; SET ^TMP($J FOR MILITARY REPORTS
- I $D(^NURSF(210,DA,10,D0,0)),$P(^(0),U,1)'="" S NSPEC(1)=$P(^(0),U,1)
- E S NSPEC(1)=" BLANK"
- I $D(^NURSF(210,DA,10,D0,0)),$P(^(0),U,2)'="",$D(^DIC(23,$P(^NURSF(210,DA,10,D0,0),U,2),0)),$P(^(0),U,1)'="" S NSPEC=$P(^(0),U,1)
- E S NSPEC=" BLANK"
- I 'NSP,NSPC'=NSPEC(1) Q
- I 'NSP(1),NSPC(1)'=NSPEC Q
- D SETUTIL
- Q
- SETUTIL ;
- W:$E(IOST)="C"&($R(100)) "."
- I NURPLSW S NURPROG(3)=+$O(^NURSF(212.7,"B","NURSING",0)),NURPROG(3)=$$GET1^DIQ(212.7,NURPROG(3),.01,"I") S:NURPROG(2)=NURPROG(3) NURPROG(2)=" "_NURPROG(2)
- I NURNEN=1 S:$G(NURSORT)="" NURSORT=1 D
- . N X S X=$G(^TMP($J,"L",NURFAC(2),NURPROG(2),NURSCATY,NSPEC(1),NSPEC))
- . I X="" S X=NURSORT,NURSORT=NURSORT+1,^TMP($J,"L",NURFAC(2),NURPROG(2),NURSCATY,NSPEC(1),NSPEC)=X
- . S ^TMP($J,"L1",X,NNM,DA,NURNODE4,NURNODE5)=""
- . Q
- I NURNEN=2 S:$G(NURSORT)="" NURSORT=1 D
- . N X S X=$G(^TMP($J,"L",NURFAC(2),NURPROG(2),NPRI,NSPOSN,NSPEC(1)))
- . I X="" S X=NURSORT,NURSORT=NURSORT+1,^TMP($J,"L",NURFAC(2),NURPROG(2),NPRI,NSPOSN,NSPEC(1))=X
- . S ^TMP($J,"L1",X,NSPEC,NNM,DA,NURNODE4,NURNODE5)=""
- . Q
- I NURNEN=3 S:$G(NURSORT)="" NURSORT=1 D
- . N X S X=$G(^TMP($J,"L",NURFAC(2),NURPROG(2),NLOCN(1),NURSCATY,NSPEC(1)))
- . I X="" S X=NURSORT,NURSORT=NURSORT+1,^TMP($J,"L",NURFAC(2),NURPROG(2),NLOCN(1),NURSCATY,NSPEC(1))=X
- . S ^TMP($J,"L1",X,NSPEC,NNM,DA,NURNODE4,NURNODE5)=""
- . Q
- I NURNEN=4 S:$G(NURSORT)="" NURSORT=1 D
- . N X S X=$G(^TMP($J,"L",NURFAC(2),NURPROG(2),NLOCN(1),NPRI,NSPOSN))
- . 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,NSPEC(1),NSPEC,NNM,DA,NURNODE4,NURNODE5)=""
- . Q
- Q
- SETLIC ; SET VARIABLES FOR LICENSE REPORTS
- I $D(^NURSF(210,DA,4,D0,0)),$P(^(0),U,3)'="" S NSPEC=$P(^(0),U,3)_D0
- E S NSPEC=" BLANK"_D0
- Q
- SETUPTL ; BUILD TMP ARRAY
- W:$E(IOST)="C"&($R(100)) "."
- I NURPLSW S NURPROG(3)=+$O(^NURSF(212.7,"B","NURSING",0)),NURPROG(3)=$$GET1^DIQ(212.7,NURPROG(3),.01,"I") S:NURPROG(2)=NURPROG(3) NURPROG(2)=" "_NURPROG(2)
- I NURNEN=1 S:$G(NURSORT)="" NURSORT=1 D
- . N X S X=$G(^TMP($J,"L",NURFAC(2),NURPROG(2),NURSCATY,NSPEC,NNM))
- . I X="" S X=NURSORT,NURSORT=NURSORT+1,^TMP($J,"L",NURFAC(2),NURPROG(2),NURSCATY,NSPEC,NNM)=X
- . S ^TMP($J,"L1",X,DA,NURNODE4,NURNODE5)=""
- . Q
- I NURNEN=2 S:$G(NURSORT)="" NURSORT=1 D
- . N X S X=$G(^TMP($J,"L",NURFAC(2),NURPROG(2),NPRI,NSPOSN,NSPEC))
- . I X="" S X=NURSORT,NURSORT=NURSORT+1,^TMP($J,"L",NURFAC(2),NURPROG(2),NPRI,NSPOSN,NSPEC)=X
- . S ^TMP($J,"L1",X,NNM,DA,NURNODE4)=""
- . Q
- I NURNEN=3 S:$G(NURSORT)="" NURSORT=1 D
- . N X S X=$G(^TMP($J,"L",NURFAC(2),NURPROG(2),NLOCN(1),NURSCATY,NSPEC))
- . I X="" S X=NURSORT,NURSORT=NURSORT+1,^TMP($J,"L",NURFAC(2),NURPROG(2),NLOCN(1),NURSCATY,NSPEC)=X
- . S ^TMP($J,"L1",X,NNM,DA,NURNODE4,NURNODE5)=""
- . Q
- I NURNEN=4 S:$G(NURSORT)="" NURSORT=1 D
- . N X S X=$G(^TMP($J,"L",NURFAC(2),NURPROG(2),NLOCN(1),NPRI,NSPOSN))
- . 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,NSPEC,NNM,DA,NURNODE4)=""
- . Q
- Q
- CHKPOS ; SELECT ACTIVE POSITIONS
- S NURNEN(1)=0 I $P(^NURSF(211.8,NURNODE4,1,NURNODE5,0),U)'>DT&('$P(^(0),U,6)!($P(^(0),U,6)'<DT)) S NURNEN(1)=1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURAAGS1 5506 printed Jan 18, 2025@03:19:56 Page 2
- NURAAGS1 ;HIRMFO/RM,MD-MULTIDIVISIONAL GENERIC SORT ROUTINE FOR ADMIN REPORTS ;5/2/97
- +1 ;;4.0;NURSING SERVICE;**1**;Apr 25, 1997
- SETCAT ; SET CATEGORY VARIABLE NURSCATY
- +1 NEW X,Y
- +2 SET X=$PIECE($GET(^NURSF(211.8,NURNODE4,1,NURNODE5,0)),U,3)
- SET Y=$GET(^NURSF(211.3,+X,0))
- +3 IF Y'=""
- SET NURSCATY=$PIECE(Y,U,5)
- if NURSCATY="O"
- SET NURSCATY=NURSCATY_" "_$$UP^XLFSTR($PIECE(Y,U,6))
- +4 IF '$TEST
- SET NURSCATY=" BLANK"
- +5 QUIT
- SETLOC ; SET LOCATION VARIABLE NLOCN
- +1 SET NLOCN=$SELECT($DATA(^NURSF(211.8,NURNODE4,0)):$PIECE(^(0),U),1:"")
- +2 IF +NLOCN
- SET NPWARD=NLOCN
- DO EN7^NURSAUTL
- SET NLOCN(1)=$SELECT(NPWARD'="":$EXTRACT(NPWARD,1,10),1:" BLANK")
- +3 QUIT
- SETPOS ; SET SERVICE POSITION AND PRIORITY SEQUENCE VARIABLES NSPOSN,NPRI
- +1 IF $DATA(^NURSF(211.8,NURNODE4,1,NURNODE5,0))
- IF $PIECE(^(0),U,3)'=""
- IF $DATA(^NURSF(211.3,$PIECE(^NURSF(211.8,NURNODE4,1,NURNODE5,0),U,3),0))
- GOTO C
- +2 IF '$TEST
- SET (NSPOSN,NPRI)=" BLANK"
- QUIT
- C IF $PIECE(^NURSF(211.3,$PIECE(^NURSF(211.8,NURNODE4,1,NURNODE5,0),U,3),0),U,1)'=""
- SET NSPOSN=$PIECE(^(0),U,1)
- +1 IF '$TEST
- SET NSPOSN=" BLANK"
- +2 IF $PIECE(^NURSF(211.3,$PIECE(^NURSF(211.8,NURNODE4,1,NURNODE5,0),U,3),0),U,3)'=""
- SET NPRI=$PIECE(^(0),U,3)
- +3 IF '$TEST
- SET NPRI=" BLANK"
- +4 QUIT
- SETFAC ; SET FACILITY VARIBLE NURFAC(2)
- +1 IF $GET(NURMDSW)
- SET NURFAC(2)=$$EN11^NURSUT3($GET(NURNODE4))
- if NURFAC(2)=""
- SET NURFAC(2)=" BLANK"
- +2 IF '$TEST
- SET NURFAC(2)=" BLANK"
- +3 QUIT
- SETPROG ; SET PRODUCT LINE VARIBLE NURPROG(2)
- +1 IF $GET(NURPLSW)
- Begin DoDot:1
- +2 IF NURNEN=3!(NURNEN=4)
- Begin DoDot:2
- +3 SET NURPROG(2)=$ORDER(^NURSF(211.4,"B",+$PIECE(^NURSF(211.8,NURNODE4,0),U),""))
- +4 SET NURPROG(2)=+$PIECE($GET(^NURSF(211.4,+NURPROG(2),1)),U,4)
- +5 QUIT
- End DoDot:2
- +6 IF NURNEN=1!(NURNEN=2)
- Begin DoDot:2
- +7 SET NURPROG(2)=$PIECE($GET(^NURSF(211.8,+NURNODE4,1,+NURNODE5,0)),U,3)
- +8 SET NURPROG(2)=+$PIECE($GET(^NURSF(211.3,+NURPROG(2),0)),U,7)
- +9 QUIT
- End DoDot:2
- +10 if NURPROG(2)=""
- SET NURPROG(2)=+$ORDER(^NURSF(212.7,"B","NURSING",0))
- +11 SET NURPROG(2)=$$GET1^DIQ(212.7,+NURPROG(2),.01,"I")
- +12 if NURPROG(2)=""
- SET NURPROG(2)=" BLANK"
- +13 QUIT
- End DoDot:1
- +14 IF '$TEST
- SET NURPROG(2)=" BLANK"
- +15 QUIT
- SETCERT ; SET ^TMP($J FOR CERTIFICATION REPORTS
- +1 SET DATA=+$PIECE($GET(^NURSF(210,DA,12,D0,0)),U)
- IF DATA>0
- IF $PIECE($GET(^NURSF(212.2,+DATA,0)),U,2)'=""
- SET NSPEC(1)=$PIECE(^(0),U,2)
- +2 IF '$TEST
- SET NSPEC(1)=" BLANK"
- +3 IF $PIECE($GET(^NURSF(210,DA,12,D0,0)),U,4)'=""
- SET NSPEC=$PIECE(^(0),U,4)
- +4 IF '$TEST
- SET NSPEC=" BLANK"
- +5 IF 'NSP
- IF NSPC'=NSPEC(1)
- QUIT
- +6 IF 'NSP(1)
- IF NSPEC>NSPC(2)!(NSPEC<NSPC(1))
- QUIT
- +7 IF NSPEC(1)'=" BLANK"
- DO SETUTIL
- +8 QUIT
- SETMIL ; SET ^TMP($J FOR MILITARY REPORTS
- +1 IF $DATA(^NURSF(210,DA,10,D0,0))
- IF $PIECE(^(0),U,1)'=""
- SET NSPEC(1)=$PIECE(^(0),U,1)
- +2 IF '$TEST
- SET NSPEC(1)=" BLANK"
- +3 IF $DATA(^NURSF(210,DA,10,D0,0))
- IF $PIECE(^(0),U,2)'=""
- IF $DATA(^DIC(23,$PIECE(^NURSF(210,DA,10,D0,0),U,2),0))
- IF $PIECE(^(0),U,1)'=""
- SET NSPEC=$PIECE(^(0),U,1)
- +4 IF '$TEST
- SET NSPEC=" BLANK"
- +5 IF 'NSP
- IF NSPC'=NSPEC(1)
- QUIT
- +6 IF 'NSP(1)
- IF NSPC(1)'=NSPEC
- QUIT
- +7 DO SETUTIL
- +8 QUIT
- SETUTIL ;
- +1 if $EXTRACT(IOST)="C"&($RANDOM(100))
- WRITE "."
- +2 IF NURPLSW
- SET NURPROG(3)=+$ORDER(^NURSF(212.7,"B","NURSING",0))
- SET NURPROG(3)=$$GET1^DIQ(212.7,NURPROG(3),.01,"I")
- if NURPROG(2)=NURPROG(3)
- SET NURPROG(2)=" "_NURPROG(2)
- +3 IF NURNEN=1
- if $GET(NURSORT)=""
- SET NURSORT=1
- Begin DoDot:1
- +4 NEW X
- SET X=$GET(^TMP($JOB,"L",NURFAC(2),NURPROG(2),NURSCATY,NSPEC(1),NSPEC))
- +5 IF X=""
- SET X=NURSORT
- SET NURSORT=NURSORT+1
- SET ^TMP($JOB,"L",NURFAC(2),NURPROG(2),NURSCATY,NSPEC(1),NSPEC)=X
- +6 SET ^TMP($JOB,"L1",X,NNM,DA,NURNODE4,NURNODE5)=""
- +7 QUIT
- End DoDot:1
- +8 IF NURNEN=2
- if $GET(NURSORT)=""
- SET NURSORT=1
- Begin DoDot:1
- +9 NEW X
- SET X=$GET(^TMP($JOB,"L",NURFAC(2),NURPROG(2),NPRI,NSPOSN,NSPEC(1)))
- +10 IF X=""
- SET X=NURSORT
- SET NURSORT=NURSORT+1
- SET ^TMP($JOB,"L",NURFAC(2),NURPROG(2),NPRI,NSPOSN,NSPEC(1))=X
- +11 SET ^TMP($JOB,"L1",X,NSPEC,NNM,DA,NURNODE4,NURNODE5)=""
- +12 QUIT
- End DoDot:1
- +13 IF NURNEN=3
- if $GET(NURSORT)=""
- SET NURSORT=1
- Begin DoDot:1
- +14 NEW X
- SET X=$GET(^TMP($JOB,"L",NURFAC(2),NURPROG(2),NLOCN(1),NURSCATY,NSPEC(1)))
- +15 IF X=""
- SET X=NURSORT
- SET NURSORT=NURSORT+1
- SET ^TMP($JOB,"L",NURFAC(2),NURPROG(2),NLOCN(1),NURSCATY,NSPEC(1))=X
- +16 SET ^TMP($JOB,"L1",X,NSPEC,NNM,DA,NURNODE4,NURNODE5)=""
- +17 QUIT
- End DoDot:1
- +18 IF NURNEN=4
- if $GET(NURSORT)=""
- SET NURSORT=1
- Begin DoDot:1
- +19 NEW X
- SET X=$GET(^TMP($JOB,"L",NURFAC(2),NURPROG(2),NLOCN(1),NPRI,NSPOSN))
- +20 IF X=""
- SET X=NURSORT
- SET NURSORT=NURSORT+1
- SET ^TMP($JOB,"L",NURFAC(2),NURPROG(2),NLOCN(1),NPRI,NSPOSN)=X
- +21 SET ^TMP($JOB,"L1",X,NSPEC(1),NSPEC,NNM,DA,NURNODE4,NURNODE5)=""
- +22 QUIT
- End DoDot:1
- +23 QUIT
- SETLIC ; SET VARIABLES FOR LICENSE REPORTS
- +1 IF $DATA(^NURSF(210,DA,4,D0,0))
- IF $PIECE(^(0),U,3)'=""
- SET NSPEC=$PIECE(^(0),U,3)_D0
- +2 IF '$TEST
- SET NSPEC=" BLANK"_D0
- +3 QUIT
- SETUPTL ; BUILD TMP ARRAY
- +1 if $EXTRACT(IOST)="C"&($RANDOM(100))
- WRITE "."
- +2 IF NURPLSW
- SET NURPROG(3)=+$ORDER(^NURSF(212.7,"B","NURSING",0))
- SET NURPROG(3)=$$GET1^DIQ(212.7,NURPROG(3),.01,"I")
- if NURPROG(2)=NURPROG(3)
- SET NURPROG(2)=" "_NURPROG(2)
- +3 IF NURNEN=1
- if $GET(NURSORT)=""
- SET NURSORT=1
- Begin DoDot:1
- +4 NEW X
- SET X=$GET(^TMP($JOB,"L",NURFAC(2),NURPROG(2),NURSCATY,NSPEC,NNM))
- +5 IF X=""
- SET X=NURSORT
- SET NURSORT=NURSORT+1
- SET ^TMP($JOB,"L",NURFAC(2),NURPROG(2),NURSCATY,NSPEC,NNM)=X
- +6 SET ^TMP($JOB,"L1",X,DA,NURNODE4,NURNODE5)=""
- +7 QUIT
- End DoDot:1
- +8 IF NURNEN=2
- if $GET(NURSORT)=""
- SET NURSORT=1
- Begin DoDot:1
- +9 NEW X
- SET X=$GET(^TMP($JOB,"L",NURFAC(2),NURPROG(2),NPRI,NSPOSN,NSPEC))
- +10 IF X=""
- SET X=NURSORT
- SET NURSORT=NURSORT+1
- SET ^TMP($JOB,"L",NURFAC(2),NURPROG(2),NPRI,NSPOSN,NSPEC)=X
- +11 SET ^TMP($JOB,"L1",X,NNM,DA,NURNODE4)=""
- +12 QUIT
- End DoDot:1
- +13 IF NURNEN=3
- if $GET(NURSORT)=""
- SET NURSORT=1
- Begin DoDot:1
- +14 NEW X
- SET X=$GET(^TMP($JOB,"L",NURFAC(2),NURPROG(2),NLOCN(1),NURSCATY,NSPEC))
- +15 IF X=""
- SET X=NURSORT
- SET NURSORT=NURSORT+1
- SET ^TMP($JOB,"L",NURFAC(2),NURPROG(2),NLOCN(1),NURSCATY,NSPEC)=X
- +16 SET ^TMP($JOB,"L1",X,NNM,DA,NURNODE4,NURNODE5)=""
- +17 QUIT
- End DoDot:1
- +18 IF NURNEN=4
- if $GET(NURSORT)=""
- SET NURSORT=1
- Begin DoDot:1
- +19 NEW X
- SET X=$GET(^TMP($JOB,"L",NURFAC(2),NURPROG(2),NLOCN(1),NPRI,NSPOSN))
- +20 IF X=""
- SET X=NURSORT
- SET NURSORT=NURSORT+1
- SET ^TMP($JOB,"L",NURFAC(2),NURPROG(2),NLOCN(1),NPRI,NSPOSN)=X
- +21 SET ^TMP($JOB,"L1",X,NSPEC,NNM,DA,NURNODE4)=""
- +22 QUIT
- End DoDot:1
- +23 QUIT
- CHKPOS ; SELECT ACTIVE POSITIONS
- +1 SET NURNEN(1)=0
- IF $PIECE(^NURSF(211.8,NURNODE4,1,NURNODE5,0),U)'>DT&('$PIECE(^(0),U,6)!($PIECE(^(0),U,6)'<DT))
- SET NURNEN(1)=1
- +2 QUIT