PRSN9A ;;WOIFO/PLT - RPC Nurs Location Extraction ; 08/14/2009 7:56 AM
;;4.0;PAID;**126**;Sep 21, 1995;Build 59
;;Per VHA Directive 2004-038, this routine should not be modified.
QUIT
;
;.ret - rpc return value with return value type: global array
;prsndt - rpc parameter 1 with type: literal date in format yyyymmdd
NURSLOC(RET,PRSNDT) ;remote procedure call- extract all active nurse locations
N PRSNA,PRSNB,PRSNC,PRSNE,PRSNF,PRSNSEQ,PRSNLOC,PRSNSITE,PRSNGLB
;convert yyyymmdd to fileman date
S PRSNDT=PRSNDT-17000000
;get active location of the date
;prsnloc(ien of file# 211.4)=^1-location name, ^2-instituion name
;^3-institution ien of file# 4 ^4-station # (field #99 of file #4)
K PRSNLOC D ACTIVLOC^PRSNUT01(.PRSNLOC,PRSNDT)
K ^TMP("PRSN",$J,"RPCLOC") S PRSNGLB=$NAME(^TMP("PRSN",$J,"RPCLOC"))
;assembly records
S (PRSNSEQ,PRSNA)=0 F S PRSNA=$O(PRSNLOC(PRSNA)) QUIT:'PRSNA S PRSNB=PRSNLOC(PRSNA),PRSNC=$G(^NURSF(211.4,PRSNA,1)) D
. ;location records
. S PRSNLOC=+^NURSF(211.4,PRSNA,0)_"^"_$P(PRSNB,U)_"^"_$P(PRSNB,U,3)_"^"_$P(PRSNB,U,2)_"^"_$P(PRSNC,U,5)_"^"_$S($P(PRSNC,U,6):$P(^NURSF(212.8,$P(PRSNC,U,6),0),U),1:"")
. S $P(PRSNLOC,U,10)=$P(PRSNB,U,4)
. S PRSNSEQ=PRSNSEQ+1,@PRSNGLB@(PRSNSEQ)=PRSNA_"^L^"_PRSNLOC
. ;ward records in mas ward multiple field #3 of file 211.4
. S PRSNE=0 F S PRSNE=$O(^NURSF(211.4,PRSNA,3,PRSNE)) QUIT:'PRSNE S PRSNF=^(PRSNE,0) D
.. S:PRSNF $P(PRSNLOC,U,7,8)=+PRSNF_"^"_$P(^DIC(42,+PRSNF,0),U)
.. S PRSNSEQ=PRSNSEQ+1,@PRSNGLB@(PRSNSEQ)=PRSNA_"^W^"_PRSNLOC
.. QUIT
. QUIT
;
;set the header node
S PRSNSITE=$P($G(^XMB(1,1,"XUS")),"^",17),PRSNSITE=$S(+PRSNSITE>0:$P($G(^DIC(4,PRSNSITE,99)),"^",1),1:"")
S @PRSNGLB@(0)=PRSNSITE_"^"_PRSNSEQ
S RET=$NAME(^TMP("PRSN",$J,"RPCLOC"))
QUIT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSN9A 1793 printed Nov 22, 2024@17:37:04 Page 2
PRSN9A ;;WOIFO/PLT - RPC Nurs Location Extraction ; 08/14/2009 7:56 AM
+1 ;;4.0;PAID;**126**;Sep 21, 1995;Build 59
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;.ret - rpc return value with return value type: global array
+6 ;prsndt - rpc parameter 1 with type: literal date in format yyyymmdd
NURSLOC(RET,PRSNDT) ;remote procedure call- extract all active nurse locations
+1 NEW PRSNA,PRSNB,PRSNC,PRSNE,PRSNF,PRSNSEQ,PRSNLOC,PRSNSITE,PRSNGLB
+2 ;convert yyyymmdd to fileman date
+3 SET PRSNDT=PRSNDT-17000000
+4 ;get active location of the date
+5 ;prsnloc(ien of file# 211.4)=^1-location name, ^2-instituion name
+6 ;^3-institution ien of file# 4 ^4-station # (field #99 of file #4)
+7 KILL PRSNLOC
DO ACTIVLOC^PRSNUT01(.PRSNLOC,PRSNDT)
+8 KILL ^TMP("PRSN",$JOB,"RPCLOC")
SET PRSNGLB=$NAME(^TMP("PRSN",$JOB,"RPCLOC"))
+9 ;assembly records
+10 SET (PRSNSEQ,PRSNA)=0
FOR
SET PRSNA=$ORDER(PRSNLOC(PRSNA))
if 'PRSNA
QUIT
SET PRSNB=PRSNLOC(PRSNA)
SET PRSNC=$GET(^NURSF(211.4,PRSNA,1))
Begin DoDot:1
+11 ;location records
+12 SET PRSNLOC=+^NURSF(211.4,PRSNA,0)_"^"_$PIECE(PRSNB,U)_"^"_$PIECE(PRSNB,U,3)_"^"_$PIECE(PRSNB,U,2)_"^"_$PIECE(PRSNC,U,5)_"^"_$SELECT($PIECE(PRSNC,U,6):$PIECE(^NURSF(212.8,$PIECE(PRSNC,U,6),0),U),1:"")
+13 SET $PIECE(PRSNLOC,U,10)=$PIECE(PRSNB,U,4)
+14 SET PRSNSEQ=PRSNSEQ+1
SET @PRSNGLB@(PRSNSEQ)=PRSNA_"^L^"_PRSNLOC
+15 ;ward records in mas ward multiple field #3 of file 211.4
+16 SET PRSNE=0
FOR
SET PRSNE=$ORDER(^NURSF(211.4,PRSNA,3,PRSNE))
if 'PRSNE
QUIT
SET PRSNF=^(PRSNE,0)
Begin DoDot:2
+17 if PRSNF
SET $PIECE(PRSNLOC,U,7,8)=+PRSNF_"^"_$PIECE(^DIC(42,+PRSNF,0),U)
+18 SET PRSNSEQ=PRSNSEQ+1
SET @PRSNGLB@(PRSNSEQ)=PRSNA_"^W^"_PRSNLOC
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 ;
+22 ;set the header node
+23 SET PRSNSITE=$PIECE($GET(^XMB(1,1,"XUS")),"^",17)
SET PRSNSITE=$SELECT(+PRSNSITE>0:$PIECE($GET(^DIC(4,PRSNSITE,99)),"^",1),1:"")
+24 SET @PRSNGLB@(0)=PRSNSITE_"^"_PRSNSEQ
+25 SET RET=$NAME(^TMP("PRSN",$JOB,"RPCLOC"))
+26 QUIT
+27 ;
