FHIPST2.m

FHIPST2	; HISC/REL - Move Room-Beds to Wards ;5/14/92  13:58

	;;5.0;Dietetics;;Oct 11, 1995

	Q:$D(^FH(119.6,"AR"))

	W !!,"Insert Ward names in File 119.6 ..."

	F KK=0:0 S KK=$O(^DIC(42,KK)) Q:KK<1  S X=$P($G(^(KK,0)),"^",1) D WRD

	W !!,"Move Room-Beds to Dietetic Wards ..."

	F KK=0:0 S KK=$O(^DG(405.4,KK)) Q:KK<1  I '$D(^FH(119.6,"AR",KK)) D SET

	Q

WRD	K ^FH(119.6,"B",KK) I '$G(^DIC(42,KK,"ORDER")) K ^FH(119.6,KK) Q

	S $P(^FH(119.6,KK,0),"^",1)=X S ^FH(119.6,"B",X,KK)=""

	S ^FH(119.6,KK,"W",0)="^119.63P^1^1",^FH(119.6,KK,"W",1,0)=KK,^FH(119.6,KK,"W","B",KK,1)="",^FH(119.6,"AW",KK,KK,1)=""

	Q

SET	F WRD=0:0 S WRD=$O(^DG(405.4,KK,"W",WRD)) Q:WRD<1  I $G(^DIC(42,WRD,"ORDER")) G S1

	W !?5,"No Active Ward found for ",$P(^DG(405.4,KK,0),"^",1)," in Room-Bed File (405.4)" Q

S1	I '$D(^FH(119.6,WRD,"R",0)) S ^(0)="^119.62P^^"

	S NX=$P(^FH(119.6,WRD,"R",0),"^",3)+1,$P(^(0),"^",3,4)=NX_"^"_NX

	S ^FH(119.6,WRD,"R",NX,0)=KK,^FH(119.6,WRD,"R","B",KK,NX)=""

	S ^FH(119.6,"AR",KK,WRD,NX)="" Q

FHIPST2   ; HISC/REL - Move Room-Beds to Wards ;5/14/92  13:58

 +1       ;;5.0;Dietetics;;Oct 11, 1995

 +2        IF $DATA(^FH(119.6,"AR"))

               QUIT 

 +3        WRITE !!,"Insert Ward names in File 119.6 ..."

 +4        FOR KK=0:0

               SET KK=$ORDER(^DIC(42,KK))

               IF KK<1

                   QUIT 

               SET X=$PIECE($GET(^(KK,0)),"^",1)

               DO WRD

 +5        WRITE !!,"Move Room-Beds to Dietetic Wards ..."

 +6        FOR KK=0:0

               SET KK=$ORDER(^DG(405.4,KK))

               IF KK<1

                   QUIT 

               IF '$DATA(^FH(119.6,"AR",KK))

                   DO SET

 +7        QUIT 

WRD        KILL ^FH(119.6,"B",KK)

           IF '$GET(^DIC(42,KK,"ORDER"))

               KILL ^FH(119.6,KK)

               QUIT 

 +1        SET $PIECE(^FH(119.6,KK,0),"^",1)=X

           SET ^FH(119.6,"B",X,KK)=""

 +2        SET ^FH(119.6,KK,"W",0)="^119.63P^1^1"

           SET ^FH(119.6,KK,"W",1,0)=KK

           SET ^FH(119.6,KK,"W","B",KK,1)=""

           SET ^FH(119.6,"AW",KK,KK,1)=""

 +3        QUIT 

SET        FOR WRD=0:0

               SET WRD=$ORDER(^DG(405.4,KK,"W",WRD))

               IF WRD<1

                   QUIT 

               IF $GET(^DIC(42,WRD,"ORDER"))

                   GOTO S1

 +1        WRITE !?5,"No Active Ward found for ",$PIECE(^DG(405.4,KK,0),"^",1)," in Room-Bed File (405.4)"

           QUIT 

S1         IF '$DATA(^FH(119.6,WRD,"R",0))

               SET ^(0)="^119.62P^^"

 +1        SET NX=$PIECE(^FH(119.6,WRD,"R",0),"^",3)+1

           SET $PIECE(^(0),"^",3,4)=NX_"^"_NX

 +2        SET ^FH(119.6,WRD,"R",NX,0)=KK

           SET ^FH(119.6,WRD,"R","B",KK,NX)=""

 +3        SET ^FH(119.6,"AR",KK,WRD,NX)=""

           QUIT