PRSN9A.m

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 ---PRSN9A   1793     printed  Apr 09, 2024@21:29:07                                                                                                                                                                                                      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      ;