PRSNUT03 ;;WOIFO/JAH - Nurse Activity for VANOD Utilities;6/5/2009
;;4.0;PAID;**126,142**;Sep 21, 1995;Build 5
;;Per VHA Directive 6402, this routine should not be modified.
Q
;
PRIMLOC(IEN200) ; RETURN NURSES PRIMARY ASSIGMENT LOCATION
;
;FUNCTION RETURNS Nurses primary assigment from Nursing Service package
; piece value
; 1 ien of location from 211.4
; 2 .01 value which is pointer to 44
; 3 external value of .01 field (e.g., 4 WEST)
;
; INPUT:
; PRSIEN: IEN from New Person file (200)
;
Q:IEN200'>0 "0^Nurse not found"
;
N D0
S D0=$O(^NURSF(210,"B",IEN200,0))
Q:D0'>0 "0^Nurse not found"
;
; call returns external name of nurse location in X
;
N X,LOCI,LOCE
D EN2^NURSUT2
Q $$NLIEN^PRSNUT03(X)
;
NLIEN(NLE) ;
; INPUT:
; NLE - nurse location external name (without NUR prefix)
; OUTPUT:
; function returns 211.4 IEN ^ .01 pointer ^ external
;
N LOCP,LOCI,LOCE,PL
I NLE="" Q ""
;Patch PRS*4.0*142 adds the "O" flag to the FIND^DIC call to prevent incorrect lookups.
D FIND^DIC(211.4,,".01","MO","NUR "_NLE,,,,,"PL",)
S LOCP=$G(PL("DILIST",1,1))
S LOCI=$G(PL("DILIST",2,1))
S LOCE=$G(PL("DILIST","ID",1,.01))
Q LOCI_U_LOCP_U_LOCE
;
LOCNOD(LOC) ; given a location in 211.4 return the node necessary to find
; all the nurses in 211.8 with that primary location out of the
; "D" index on the primary assignment field.
N POINT44
S POINT44=+$G(^NURSF(211.4,LOC,0))
Q:POINT44'>0 -1
Q +$O(^NURSF(211.8,"B",POINT44,0))
;
PICKNURS(GROUP,VALUE) ; pick a nurse from a t&l or location
; INPUT:
; GROUP = T for T&L or N for Nurse Location
; VALUE = IEN (T&L 455.5 or Nurse Location 211.4)
; OUTPUT:
; function returns a Nurse file 450 (IEN^external Name)
;
Q:"T^N^"'[(GROUP_U) 0
Q:VALUE'>0 0
;
N DIC,X,Y,TLE,D,S1,S2,REFD,S3
S DIC("A")="Select Nurse: "
S DIC="^PRSPC("
S DIC(0)="AEQZ"
I GROUP="T" D
. S DIC("S")="I $$ISNURSE^PRSNUT01(Y)"
. S TLE=$P($G(^PRST(455.5,VALUE,0)),U)
. S D="ATL"_TLE
. D MIX^DIC1
E D
. S REFD=+$G(^NURSF(211.4,VALUE,0))
. S S3=""
. ;S DIC("S")="N VA200IEN,NAME I $$ISNURSE^PRSNUT01(Y) S VA200IEN=+$G(^PRSPC(+Y,200)) I VA200IEN S NAME=$P($G(^VA(200,VA200IEN,0)),U) I NAME'="""",$D(^NURSF(211.8,""D"",REFD,NAME,VA200IEN))"
. S DIC("S")="N VA200IEN I $$ISNURSE^PRSNUT01(Y) S VA200IEN=+$G(^PRSPC(+Y,200)) I VA200IEN,REFD=+$$PRIMLOC^PRSNUT03(VA200IEN)"
. D ^DIC
Q Y
;
DIV(GROUP,VALUE) ; Return the division of a location or a T&L unit
;
; INPUT:
; GROUP = T for T&L or N for Nurse Location
; VALUE = IEN (T&L 455.5 or Nurse Location 211.4)
; OUTPUT:
; Function returns division of input group
;
Q:"T^N^"'[(GROUP_U) 0
N DIV,STANUM,NLP,P4
I GROUP="N" D
. S NLP=+$G(^NURSF(211.4,VALUE,0))
. S P4=+$$GET1^DIQ(44,NLP,3,"I")
E D
. S P4=+$$GET1^DIQ(455.5,VALUE,20.5,"I")
S DIV=$$GET1^DIQ(4,P4,.01,"I")
S STANUM=$$GET1^DIQ(4,P4,99,"I")
Q DIV_U_STANUM_U_P4
;
ENTRYPNT ;
N DIVMAP,DIVS
D BLDMAP(.DIVMAP)
S DIVS=$$SELECT(.DIVMAP)
Q:DIVS=0
N DIR,DIRUT,SRT,Y,X,SHOW
S DIR(0)="SB^T:T&L UNIT;N:NURSE LOCATION"
S DIR("B")="T"
S DIR("A")="Select Sort: "
D ^DIR
Q:$D(DIRUT)
S SRT=Y
N DIR,Y,X
S DIR(0)="Y"
S DIR("B")="N"
S DIR("A")="Show Full Nurse Data"
D ^DIR
Q:$D(DIRUT)
S SHOWNURS=Y
N %ZIS,POP,IOP
S %ZIS="MQ"
D ^%ZIS
Q:POP
I $D(IO("Q")) D
. K IO("Q")
. N ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC
. S ZTDESC="PRSN SHOW ALL NURSES"
. S ZTRTN="ALNURLST^PRSNUT03(0,SRT,SHOWNURS)"
. S ZTSAVE("SHOWNURS")=""
. S ZTSAVE("SRT")=""
. S ZTSAVE("FLAG")=""
. S ZTSAVE("DIVMAP(")=""
. S ZTSAVE("DIVS")=""
. D ^%ZTLOAD
. I $D(ZTSK) S ZTREQ="@" W !,"Request "_ZTSK_" Queued."
E D
. D ALNURLST(0,SRT,SHOWNURS)
Q
ALNURLST(FLAG,SORT,SHOWNURS) ;List all Nurses in file 450
; INPUT:
; FLAG - set to true if you want to attempt to add the Nurse
; to file 200. this will also convert any numbers in
; the name from file 450 to letters
; SORT - (required) If "N" will sort by Nurse location, "T"
; report sorts by T&L unit.
; SHOWNURS - Set to true if you want to see the full info
; about a nurses role
;
Q:"T^N^"'[(SORT_U) 0
U IO
K ^TMP($J,"PRSN")
N N2CNT,NCNT
S (NCNT,N2CNT)=0
D GATHER
N STOP
D REPORT(.STOP)
D TOTAL(.STOP)
D ^%ZISC
Q
GATHER ;
N PRSIEN,X,IEN200,SSN,OUT,SSN200,NAME,ZNODE,TLE,NURTYP
N SRT1,SRT2,NL,SEPFLAG,NLE,NLDIV
S (PRSIEN)=0
F S PRSIEN=$O(^PRSPC(PRSIEN)) Q:PRSIEN'>0 D
. S X=$$ISNURSE^PRSNUT01(PRSIEN)
. Q:'X
. S SEPFLAG=$P($G(^PRSPC(PRSIEN,1)),U,33)
. Q:SEPFLAG="Y"
. S NCNT=NCNT+1
. S NURTYP=$P(X,U,2,4)
. I $G(FLAG) W @IOF,!!!
. S IEN200=$P($G(^PRSPC(PRSIEN,200)),U)
. S ZNODE=$G(^PRSPC(PRSIEN,0))
. S SSN=$P(ZNODE,U,9)
. S NAME=$P(ZNODE,U)
. S TLE=$P(ZNODE,U,8)
. I TLE="" S TLE="NONE"
. S (NL,NLE,NLDIV)="NONE"
. I IEN200>0 D
.. S N2CNT=N2CNT+1
.. S SSN200=$P($G(^VA(200,IEN200,1)),U,9)
.. S NL=$$PRIMLOC^PRSNUT03(IEN200)
.. S NLE=$P(NL,U,3)
.. I NLE="" S NLE="NONE"
.. I NL>0 D
... S NLDIV=$P(DIVMAP("NL",+NL),U,3)
.. E D
... S (NLDIV,NLE)="NONE"
. E D
.. I $G(FLAG) D ADDNRS
. I NLDIV'="NONE",DIVS'<0,DIVS'=NLDIV Q ;NOT ALL DIVS OR NOT THE DIV WE'RE LOOKING FOR
. S SRT1=$S($G(SORT)="N":NLE,1:TLE)
. S SRT2=$S($G(SORT)="N":TLE,1:NLE)
. S ^TMP($J,"PRSN",SRT1,SRT2,PRSIEN)=SSN_U_NAME_U_IEN200_U_$G(SSN200)_U_NLE_U_TLE
. S ^TMP($J,"PRSN",SRT1,SRT2,PRSIEN,1)=NURTYP
Q
REPORT(STOP) ;
;
;Print the data in the tmp array by the sort parameter
;
N PAGE,GIEN,PRSIEN,DAT,SD,NL,NTL,TL
S (PAGE,STOP)=0
S GROUP=""
D HDR
F S GROUP=$O(^TMP($J,"PRSN",GROUP)) Q:GROUP=""!STOP D
. W !?17,$S($G(SORT)="N":"NURSING LOCATION: ",1:"T&L UNIT: ")
. I SORT="N" D
.. S GIEN=$$NLIEN^PRSNUT03(GROUP)
. E D
.. S GIEN=$O(^PRST(455.5,"B",GROUP,0))
. S SD=$$DIV^PRSNUT03(SORT,+GIEN)
. W GROUP,!,?17,"STATION: ",$P(SD,U)," (",$P(SD,U,2),")"
. W !?12,"--------------------------------------------"
. S SRT2=""
. F S SRT2=$O(^TMP($J,"PRSN",GROUP,SRT2)) Q:SRT2=""!STOP D
.. S PRSIEN=0
.. F S PRSIEN=$O(^TMP($J,"PRSN",GROUP,SRT2,PRSIEN)) Q:PRSIEN'>0!STOP D
... S DAT=$G(^TMP($J,"PRSN",GROUP,SRT2,PRSIEN))
... S NURTYP=$G(^TMP($J,"PRSN",GROUP,SRT2,PRSIEN,1))
... S NAME=$P(DAT,U,2)
... S IEN200=$P(DAT,U,3)
... S NL=$P(DAT,U,5)
... S TL=$P(DAT,U,6)
... S SSN=$E($P(DAT,U,1),6,9)
... W !,NAME,?23,SSN,?28,PRSIEN,?35,IEN200
... W ?46,$S($G(SORT)="N":TL,1:NL)
... I $G(SHOWNURS) D
.... W !,?5,$P(NURTYP,U,1),?25,$P(NURTYP,U,2),?50,$P(NURTYP,U,3),!
... E D
.... S X=$P(NURTYP,U)
.... S NTL=$L(X)
.... I NTL>15 D
..... S DIWL=64
..... S DIWF="WC15"
..... K ^UTILITY($J,"W")
..... D ^DIWP,^DIWW K DIWL,DIWF
.... E D
..... I $X>62 W !
..... W ?63,X
... I (IOSL-5)<$Y S STOP=$$ASK^PRSLIB00() D HDR
... I $G(FLAG) S STOP=$$ASK^PRSLIB00()
Q
TOTAL(STOP) ;
W !,"ALL DONE" I STOP W ": User Aborted"
W !,"VA Nurse Count: ",NCNT,!,"Nurses with DUZ: ",N2CNT
Q
ADDNRS ;
; edit PAID 450 Employee name replaceing digits 0..9 with A..J
;
N NEWNAME
S NEWNAME=$TR(NAME,"0123456789","ABCDEFGHIJ")
W !,"NAME: ",NAME,!,"NEW: ",NEWNAME,!,"Y: ",Y,!,"Y(0): ",$G(Y(0))
N DIE,DR,DA
S DIE="^PRSPC(",DA=PRSIEN,DR=".01///^S X=NEWNAME" D ^DIE
;
;
; add PAID Nurse employees to file 200
;
N DIC,X,Y
K DD,DO
S DIC(0)="LZ",X=NEWNAME,DIC="^VA(200," D FILE^DICN
;
; edit ssn in 200
;
I +Y D
. S DIE="^VA(200,",DA=+Y,DR="9///^S X=SSN" D ^DIE
Q
HDR ;
W @IOF
S PAGE=PAGE+1
W ?68,"PAGE ",PAGE
W !," NAME",?21,"SSN",?26,"IEN 450",?35,"IEN 200"
W ?46,$S($G(SORT)="N":"T&L",1:"PRIM LOC")
I $G(SHOWNURS) D
. W !," NURSE ROLE"
E D
. W ?64,"NURSE TYPE"
W !,"======================================================================="
Q
;
BLDMAP(DIVMAP) ; BUILD A DIVISION MAP OF LOCATIONS
N DIVINFO,LIEN
S LIEN=0
F S LIEN=$O(^NURSF(211.4,LIEN)) Q:LIEN'>0 D
. S DIVINFO=$$DIV^PRSNUT03("N",LIEN)
. S DIVMAP("NL",LIEN)=DIVINFO
. S DIVMAP("IN",$P(DIVINFO,U,3))=$P(DIVINFO,U,1,2)
Q
;
SELECT(DM) ; Allow selection of one or all from division
N DIC,DUOUT,DTOUT,X,Y
S DIC="^DIC(4,",DIC(0)="AEQMZ"
S DIC("S")="I $D(DM(""IN"",+Y))"
S DIC("A")="Select Division or Return for All: "
D ^DIC
I $D(DUOUT)!$D(DTOUT) Q 0
Q +Y
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSNUT03 8609 printed Apr 09, 2024@21:30:15 Page 2
PRSNUT03 ;;WOIFO/JAH - Nurse Activity for VANOD Utilities;6/5/2009
+1 ;;4.0;PAID;**126,142**;Sep 21, 1995;Build 5
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
PRIMLOC(IEN200) ; RETURN NURSES PRIMARY ASSIGMENT LOCATION
+1 ;
+2 ;FUNCTION RETURNS Nurses primary assigment from Nursing Service package
+3 ; piece value
+4 ; 1 ien of location from 211.4
+5 ; 2 .01 value which is pointer to 44
+6 ; 3 external value of .01 field (e.g., 4 WEST)
+7 ;
+8 ; INPUT:
+9 ; PRSIEN: IEN from New Person file (200)
+10 ;
+11 if IEN200'>0
QUIT "0^Nurse not found"
+12 ;
+13 NEW D0
+14 SET D0=$ORDER(^NURSF(210,"B",IEN200,0))
+15 if D0'>0
QUIT "0^Nurse not found"
+16 ;
+17 ; call returns external name of nurse location in X
+18 ;
+19 NEW X,LOCI,LOCE
+20 DO EN2^NURSUT2
+21 QUIT $$NLIEN^PRSNUT03(X)
+22 ;
NLIEN(NLE) ;
+1 ; INPUT:
+2 ; NLE - nurse location external name (without NUR prefix)
+3 ; OUTPUT:
+4 ; function returns 211.4 IEN ^ .01 pointer ^ external
+5 ;
+6 NEW LOCP,LOCI,LOCE,PL
+7 IF NLE=""
QUIT ""
+8 ;Patch PRS*4.0*142 adds the "O" flag to the FIND^DIC call to prevent incorrect lookups.
+9 DO FIND^DIC(211.4,,".01","MO","NUR "_NLE,,,,,"PL",)
+10 SET LOCP=$GET(PL("DILIST",1,1))
+11 SET LOCI=$GET(PL("DILIST",2,1))
+12 SET LOCE=$GET(PL("DILIST","ID",1,.01))
+13 QUIT LOCI_U_LOCP_U_LOCE
+14 ;
LOCNOD(LOC) ; given a location in 211.4 return the node necessary to find
+1 ; all the nurses in 211.8 with that primary location out of the
+2 ; "D" index on the primary assignment field.
+3 NEW POINT44
+4 SET POINT44=+$GET(^NURSF(211.4,LOC,0))
+5 if POINT44'>0
QUIT -1
+6 QUIT +$ORDER(^NURSF(211.8,"B",POINT44,0))
+7 ;
PICKNURS(GROUP,VALUE) ; pick a nurse from a t&l or location
+1 ; INPUT:
+2 ; GROUP = T for T&L or N for Nurse Location
+3 ; VALUE = IEN (T&L 455.5 or Nurse Location 211.4)
+4 ; OUTPUT:
+5 ; function returns a Nurse file 450 (IEN^external Name)
+6 ;
+7 if "T^N^"'[(GROUP_U)
QUIT 0
+8 if VALUE'>0
QUIT 0
+9 ;
+10 NEW DIC,X,Y,TLE,D,S1,S2,REFD,S3
+11 SET DIC("A")="Select Nurse: "
+12 SET DIC="^PRSPC("
+13 SET DIC(0)="AEQZ"
+14 IF GROUP="T"
Begin DoDot:1
+15 SET DIC("S")="I $$ISNURSE^PRSNUT01(Y)"
+16 SET TLE=$PIECE($GET(^PRST(455.5,VALUE,0)),U)
+17 SET D="ATL"_TLE
+18 DO MIX^DIC1
End DoDot:1
+19 IF '$TEST
Begin DoDot:1
+20 SET REFD=+$GET(^NURSF(211.4,VALUE,0))
+21 SET S3=""
+22 ;S DIC("S")="N VA200IEN,NAME I $$ISNURSE^PRSNUT01(Y) S VA200IEN=+$G(^PRSPC(+Y,200)) I VA200IEN S NAME=$P($G(^VA(200,VA200IEN,0)),U) I NAME'="""",$D(^NURSF(211.8,""D"",REFD,NAME,VA200IEN))"
+23 SET DIC("S")="N VA200IEN I $$ISNURSE^PRSNUT01(Y) S VA200IEN=+$G(^PRSPC(+Y,200)) I VA200IEN,REFD=+$$PRIMLOC^PRSNUT03(VA200IEN)"
+24 DO ^DIC
End DoDot:1
+25 QUIT Y
+26 ;
DIV(GROUP,VALUE) ; Return the division of a location or a T&L unit
+1 ;
+2 ; INPUT:
+3 ; GROUP = T for T&L or N for Nurse Location
+4 ; VALUE = IEN (T&L 455.5 or Nurse Location 211.4)
+5 ; OUTPUT:
+6 ; Function returns division of input group
+7 ;
+8 if "T^N^"'[(GROUP_U)
QUIT 0
+9 NEW DIV,STANUM,NLP,P4
+10 IF GROUP="N"
Begin DoDot:1
+11 SET NLP=+$GET(^NURSF(211.4,VALUE,0))
+12 SET P4=+$$GET1^DIQ(44,NLP,3,"I")
End DoDot:1
+13 IF '$TEST
Begin DoDot:1
+14 SET P4=+$$GET1^DIQ(455.5,VALUE,20.5,"I")
End DoDot:1
+15 SET DIV=$$GET1^DIQ(4,P4,.01,"I")
+16 SET STANUM=$$GET1^DIQ(4,P4,99,"I")
+17 QUIT DIV_U_STANUM_U_P4
+18 ;
ENTRYPNT ;
+1 NEW DIVMAP,DIVS
+2 DO BLDMAP(.DIVMAP)
+3 SET DIVS=$$SELECT(.DIVMAP)
+4 if DIVS=0
QUIT
+5 NEW DIR,DIRUT,SRT,Y,X,SHOW
+6 SET DIR(0)="SB^T:T&L UNIT;N:NURSE LOCATION"
+7 SET DIR("B")="T"
+8 SET DIR("A")="Select Sort: "
+9 DO ^DIR
+10 if $DATA(DIRUT)
QUIT
+11 SET SRT=Y
+12 NEW DIR,Y,X
+13 SET DIR(0)="Y"
+14 SET DIR("B")="N"
+15 SET DIR("A")="Show Full Nurse Data"
+16 DO ^DIR
+17 if $DATA(DIRUT)
QUIT
+18 SET SHOWNURS=Y
+19 NEW %ZIS,POP,IOP
+20 SET %ZIS="MQ"
+21 DO ^%ZIS
+22 if POP
QUIT
+23 IF $DATA(IO("Q"))
Begin DoDot:1
+24 KILL IO("Q")
+25 NEW ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTUCI,ZTCPU,ZTPRI,ZTKIL,ZTSYNC
+26 SET ZTDESC="PRSN SHOW ALL NURSES"
+27 SET ZTRTN="ALNURLST^PRSNUT03(0,SRT,SHOWNURS)"
+28 SET ZTSAVE("SHOWNURS")=""
+29 SET ZTSAVE("SRT")=""
+30 SET ZTSAVE("FLAG")=""
+31 SET ZTSAVE("DIVMAP(")=""
+32 SET ZTSAVE("DIVS")=""
+33 DO ^%ZTLOAD
+34 IF $DATA(ZTSK)
SET ZTREQ="@"
WRITE !,"Request "_ZTSK_" Queued."
End DoDot:1
+35 IF '$TEST
Begin DoDot:1
+36 DO ALNURLST(0,SRT,SHOWNURS)
End DoDot:1
+37 QUIT
ALNURLST(FLAG,SORT,SHOWNURS) ;List all Nurses in file 450
+1 ; INPUT:
+2 ; FLAG - set to true if you want to attempt to add the Nurse
+3 ; to file 200. this will also convert any numbers in
+4 ; the name from file 450 to letters
+5 ; SORT - (required) If "N" will sort by Nurse location, "T"
+6 ; report sorts by T&L unit.
+7 ; SHOWNURS - Set to true if you want to see the full info
+8 ; about a nurses role
+9 ;
+10 if "T^N^"'[(SORT_U)
QUIT 0
+11 USE IO
+12 KILL ^TMP($JOB,"PRSN")
+13 NEW N2CNT,NCNT
+14 SET (NCNT,N2CNT)=0
+15 DO GATHER
+16 NEW STOP
+17 DO REPORT(.STOP)
+18 DO TOTAL(.STOP)
+19 DO ^%ZISC
+20 QUIT
GATHER ;
+1 NEW PRSIEN,X,IEN200,SSN,OUT,SSN200,NAME,ZNODE,TLE,NURTYP
+2 NEW SRT1,SRT2,NL,SEPFLAG,NLE,NLDIV
+3 SET (PRSIEN)=0
+4 FOR
SET PRSIEN=$ORDER(^PRSPC(PRSIEN))
if PRSIEN'>0
QUIT
Begin DoDot:1
+5 SET X=$$ISNURSE^PRSNUT01(PRSIEN)
+6 if 'X
QUIT
+7 SET SEPFLAG=$PIECE($GET(^PRSPC(PRSIEN,1)),U,33)
+8 if SEPFLAG="Y"
QUIT
+9 SET NCNT=NCNT+1
+10 SET NURTYP=$PIECE(X,U,2,4)
+11 IF $GET(FLAG)
WRITE @IOF,!!!
+12 SET IEN200=$PIECE($GET(^PRSPC(PRSIEN,200)),U)
+13 SET ZNODE=$GET(^PRSPC(PRSIEN,0))
+14 SET SSN=$PIECE(ZNODE,U,9)
+15 SET NAME=$PIECE(ZNODE,U)
+16 SET TLE=$PIECE(ZNODE,U,8)
+17 IF TLE=""
SET TLE="NONE"
+18 SET (NL,NLE,NLDIV)="NONE"
+19 IF IEN200>0
Begin DoDot:2
+20 SET N2CNT=N2CNT+1
+21 SET SSN200=$PIECE($GET(^VA(200,IEN200,1)),U,9)
+22 SET NL=$$PRIMLOC^PRSNUT03(IEN200)
+23 SET NLE=$PIECE(NL,U,3)
+24 IF NLE=""
SET NLE="NONE"
+25 IF NL>0
Begin DoDot:3
+26 SET NLDIV=$PIECE(DIVMAP("NL",+NL),U,3)
End DoDot:3
+27 IF '$TEST
Begin DoDot:3
+28 SET (NLDIV,NLE)="NONE"
End DoDot:3
End DoDot:2
+29 IF '$TEST
Begin DoDot:2
+30 IF $GET(FLAG)
DO ADDNRS
End DoDot:2
+31 ;NOT ALL DIVS OR NOT THE DIV WE'RE LOOKING FOR
IF NLDIV'="NONE"
IF DIVS'<0
IF DIVS'=NLDIV
QUIT
+32 SET SRT1=$SELECT($GET(SORT)="N":NLE,1:TLE)
+33 SET SRT2=$SELECT($GET(SORT)="N":TLE,1:NLE)
+34 SET ^TMP($JOB,"PRSN",SRT1,SRT2,PRSIEN)=SSN_U_NAME_U_IEN200_U_$GET(SSN200)_U_NLE_U_TLE
+35 SET ^TMP($JOB,"PRSN",SRT1,SRT2,PRSIEN,1)=NURTYP
End DoDot:1
+36 QUIT
REPORT(STOP) ;
+1 ;
+2 ;Print the data in the tmp array by the sort parameter
+3 ;
+4 NEW PAGE,GIEN,PRSIEN,DAT,SD,NL,NTL,TL
+5 SET (PAGE,STOP)=0
+6 SET GROUP=""
+7 DO HDR
+8 FOR
SET GROUP=$ORDER(^TMP($JOB,"PRSN",GROUP))
if GROUP=""!STOP
QUIT
Begin DoDot:1
+9 WRITE !?17,$SELECT($GET(SORT)="N":"NURSING LOCATION: ",1:"T&L UNIT: ")
+10 IF SORT="N"
Begin DoDot:2
+11 SET GIEN=$$NLIEN^PRSNUT03(GROUP)
End DoDot:2
+12 IF '$TEST
Begin DoDot:2
+13 SET GIEN=$ORDER(^PRST(455.5,"B",GROUP,0))
End DoDot:2
+14 SET SD=$$DIV^PRSNUT03(SORT,+GIEN)
+15 WRITE GROUP,!,?17,"STATION: ",$PIECE(SD,U)," (",$PIECE(SD,U,2),")"
+16 WRITE !?12,"--------------------------------------------"
+17 SET SRT2=""
+18 FOR
SET SRT2=$ORDER(^TMP($JOB,"PRSN",GROUP,SRT2))
if SRT2=""!STOP
QUIT
Begin DoDot:2
+19 SET PRSIEN=0
+20 FOR
SET PRSIEN=$ORDER(^TMP($JOB,"PRSN",GROUP,SRT2,PRSIEN))
if PRSIEN'>0!STOP
QUIT
Begin DoDot:3
+21 SET DAT=$GET(^TMP($JOB,"PRSN",GROUP,SRT2,PRSIEN))
+22 SET NURTYP=$GET(^TMP($JOB,"PRSN",GROUP,SRT2,PRSIEN,1))
+23 SET NAME=$PIECE(DAT,U,2)
+24 SET IEN200=$PIECE(DAT,U,3)
+25 SET NL=$PIECE(DAT,U,5)
+26 SET TL=$PIECE(DAT,U,6)
+27 SET SSN=$EXTRACT($PIECE(DAT,U,1),6,9)
+28 WRITE !,NAME,?23,SSN,?28,PRSIEN,?35,IEN200
+29 WRITE ?46,$SELECT($GET(SORT)="N":TL,1:NL)
+30 IF $GET(SHOWNURS)
Begin DoDot:4
+31 WRITE !,?5,$PIECE(NURTYP,U,1),?25,$PIECE(NURTYP,U,2),?50,$PIECE(NURTYP,U,3),!
End DoDot:4
+32 IF '$TEST
Begin DoDot:4
+33 SET X=$PIECE(NURTYP,U)
+34 SET NTL=$LENGTH(X)
+35 IF NTL>15
Begin DoDot:5
+36 SET DIWL=64
+37 SET DIWF="WC15"
+38 KILL ^UTILITY($JOB,"W")
+39 DO ^DIWP
DO ^DIWW
KILL DIWL,DIWF
End DoDot:5
+40 IF '$TEST
Begin DoDot:5
+41 IF $X>62
WRITE !
+42 WRITE ?63,X
End DoDot:5
End DoDot:4
+43 IF (IOSL-5)<$Y
SET STOP=$$ASK^PRSLIB00()
DO HDR
+44 IF $GET(FLAG)
SET STOP=$$ASK^PRSLIB00()
End DoDot:3
End DoDot:2
End DoDot:1
+45 QUIT
TOTAL(STOP) ;
+1 WRITE !,"ALL DONE"
IF STOP
WRITE ": User Aborted"
+2 WRITE !,"VA Nurse Count: ",NCNT,!,"Nurses with DUZ: ",N2CNT
+3 QUIT
ADDNRS ;
+1 ; edit PAID 450 Employee name replaceing digits 0..9 with A..J
+2 ;
+3 NEW NEWNAME
+4 SET NEWNAME=$TRANSLATE(NAME,"0123456789","ABCDEFGHIJ")
+5 WRITE !,"NAME: ",NAME,!,"NEW: ",NEWNAME,!,"Y: ",Y,!,"Y(0): ",$GET(Y(0))
+6 NEW DIE,DR,DA
+7 SET DIE="^PRSPC("
SET DA=PRSIEN
SET DR=".01///^S X=NEWNAME"
DO ^DIE
+8 ;
+9 ;
+10 ; add PAID Nurse employees to file 200
+11 ;
+12 NEW DIC,X,Y
+13 KILL DD,DO
+14 SET DIC(0)="LZ"
SET X=NEWNAME
SET DIC="^VA(200,"
DO FILE^DICN
+15 ;
+16 ; edit ssn in 200
+17 ;
+18 IF +Y
Begin DoDot:1
+19 SET DIE="^VA(200,"
SET DA=+Y
SET DR="9///^S X=SSN"
DO ^DIE
End DoDot:1
+20 QUIT
HDR ;
+1 WRITE @IOF
+2 SET PAGE=PAGE+1
+3 WRITE ?68,"PAGE ",PAGE
+4 WRITE !," NAME",?21,"SSN",?26,"IEN 450",?35,"IEN 200"
+5 WRITE ?46,$SELECT($GET(SORT)="N":"T&L",1:"PRIM LOC")
+6 IF $GET(SHOWNURS)
Begin DoDot:1
+7 WRITE !," NURSE ROLE"
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 WRITE ?64,"NURSE TYPE"
End DoDot:1
+10 WRITE !,"======================================================================="
+11 QUIT
+12 ;
BLDMAP(DIVMAP) ; BUILD A DIVISION MAP OF LOCATIONS
+1 NEW DIVINFO,LIEN
+2 SET LIEN=0
+3 FOR
SET LIEN=$ORDER(^NURSF(211.4,LIEN))
if LIEN'>0
QUIT
Begin DoDot:1
+4 SET DIVINFO=$$DIV^PRSNUT03("N",LIEN)
+5 SET DIVMAP("NL",LIEN)=DIVINFO
+6 SET DIVMAP("IN",$PIECE(DIVINFO,U,3))=$PIECE(DIVINFO,U,1,2)
End DoDot:1
+7 QUIT
+8 ;
SELECT(DM) ; Allow selection of one or all from division
+1 NEW DIC,DUOUT,DTOUT,X,Y
+2 SET DIC="^DIC(4,"
SET DIC(0)="AEQMZ"
+3 SET DIC("S")="I $D(DM(""IN"",+Y))"
+4 SET DIC("A")="Select Division or Return for All: "
+5 DO ^DIC
+6 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT 0
+7 QUIT +Y
+8 ;
