FHIPST3 ; HISC/REL - Move Delivery Points ;6/8/94 12:22
;;5.0;Dietetics;;Oct 11, 1995
K DP Q:$D(^FH(119.71,1,0))
W !!,"Create Facility File entries ..."
K DO,DD S DIC="^FH(119.71,",DIC(0)="L",X="MAIN KITCHEN",DIC("DR")="1///T" D FILE^DICN S PF=+Y
K DO,DD S DIC="^FH(119.73,",DIC(0)="L",X="COMMUNICATION OFFICE",DIC("DR")="1///T" D FILE^DICN S CF=+Y
K DD,DO S DIC="^FH(119.74,",DIC(0)="L",X="SUPPLEMENTAL FEEDINGS",DIC("DR")="1///S FDGS;2////^S X=PF" D FILE^DICN S SF=+Y
S ^FH(119.73,CF,1)=$G(^FH(119.9,1,1)),^FH(119.73,CF,2)=$G(^FH(119.9,1,2))
S X=$G(^FH(119.9,1,0)),$P(^FH(119.73,CF,2),"^",7,10)=$P(X,"^",5)_"^"_$P(X,"^",7)_"^"_$P(X,"^",9)_"^"_$P(X,"^",10)
S $P(^FH(119.74,SF,0),"^",4,5)=$P(X,"^",20)_"^"_$P(X,"^",21)
S $P(X,"^",12)="" S $P(^FH(119.71,PF,0),"^",2,7)=$P(X,"^",11,16)
F KKK=0:0 S KKK=$O(^FH(119.7,KKK)) Q:KKK<1 S X=$G(^(KKK,0)) D SET
S X=$G(^FH(119.9,1,0)),SP=$P(X,"^",4)_"^"_$P(X,"^",3)
F KKK=0:0 S KKK=$O(^FH(119.6,KKK)) Q:KKK<1 S X=$G(^(KKK,0)) D UPD
Q
SET S NAM=$P(X,"^",1),NAM=$E(NAM,1,27),SVC=$P(X,"^",4),DP(KKK,"PF")=PF,DP(KKK,"CF")=CF,DP(KKK,"S")=SF,DRSVC=$P(X,"^",5)
F X="T","C","D" S DP(KKK,X)=""
I SVC["T" K DD,DO S DIC="^FH(119.72,",DIC(0)="L",X=NAM_" TL",DIC("DR")="1///T;2////^S X=PF" D FILE^DICN S DP(KKK,"T")=+Y D PER
I SVC["C" K DD,DO S DIC="^FH(119.72,",DIC(0)="L",X=NAM_" CF",DIC("DR")="1///C;2////^S X=PF" D FILE^DICN S DP(KKK,"C")=+Y D PER
I SVC["D" S DP(KKK,"D")=1
S ^FH(119.7,KKK,4)=DP(KKK,"T")_"^"_DP(KKK,"C")_"^"_DP(KKK,"D")_"^"_DRSVC D ADD Q
PER Q:$O(^FH(119.7,KKK,"A",0))="" S LLL=+Y
S %X="^FH(119.7,KKK,""A"",",%Y="^FH(119.72,LLL,""A""," D %XY^%RCR
S $P(^FH(119.72,LLL,"A",0),"^",2)="119.7211P" Q
ADD Q:$O(^FH(119.7,KKK,"B",0))="" S LLL=$S(SVC["C":"C",1:"T"),LLL=DP(KKK,LLL) Q:'LLL
S %X="^FH(119.7,KKK,""B"",",%Y="^FH(119.72,LLL,""B""," D %XY^%RCR
S $P(^FH(119.72,LLL,"B",0),"^",2)="119.721P" Q
UPD ; Update Dietetic Wards
S DP=+$P(X,"^",3) S:'$D(DP(DP)) DP="" S $P(^FH(119.6,KKK,0),"^",15,16)=SP
I DP S SVC="" S:DP(DP,"T") SVC=SVC_"T" S:DP(DP,"C") SVC=SVC_"C" S:DP(DP,"D") SVC=SVC_"D"
I DP S $P(^FH(119.6,KKK,0),"^",5,10)=DP(DP,"T")_"^"_DP(DP,"C")_"^"_DP(DP,"D")_"^"_DP(DP,"CF")_"^"_DP(DP,"S")_"^"_SVC
S $P(^FH(119.6,KKK,0),"^",11,14)="3^7^14^3" Q
FHIPST3 ; HISC/REL - Move Delivery Points ;6/8/94 12:22
+1 ;;5.0;Dietetics;;Oct 11, 1995
+2 KILL DP
IF $DATA(^FH(119.71,1,0))
QUIT
+3 WRITE !!,"Create Facility File entries ..."
+4 KILL DO,DD
SET DIC="^FH(119.71,"
SET DIC(0)="L"
SET X="MAIN KITCHEN"
SET DIC("DR")="1///T"
DO FILE^DICN
SET PF=+Y
+5 KILL DO,DD
SET DIC="^FH(119.73,"
SET DIC(0)="L"
SET X="COMMUNICATION OFFICE"
SET DIC("DR")="1///T"
DO FILE^DICN
SET CF=+Y
+6 KILL DD,DO
SET DIC="^FH(119.74,"
SET DIC(0)="L"
SET X="SUPPLEMENTAL FEEDINGS"
SET DIC("DR")="1///S FDGS;2////^S X=PF"
DO FILE^DICN
SET SF=+Y
+7 SET ^FH(119.73,CF,1)=$GET(^FH(119.9,1,1))
SET ^FH(119.73,CF,2)=$GET(^FH(119.9,1,2))
+8 SET X=$GET(^FH(119.9,1,0))
SET $PIECE(^FH(119.73,CF,2),"^",7,10)=$PIECE(X,"^",5)_"^"_$PIECE(X,"^",7)_"^"_$PIECE(X,"^",9)_"^"_$PIECE(X,"^",10)
+9 SET $PIECE(^FH(119.74,SF,0),"^",4,5)=$PIECE(X,"^",20)_"^"_$PIECE(X,"^",21)
+10 SET $PIECE(X,"^",12)=""
SET $PIECE(^FH(119.71,PF,0),"^",2,7)=$PIECE(X,"^",11,16)
+11 FOR KKK=0:0
SET KKK=$ORDER(^FH(119.7,KKK))
IF KKK<1
QUIT
SET X=$GET(^(KKK,0))
DO SET
+12 SET X=$GET(^FH(119.9,1,0))
SET SP=$PIECE(X,"^",4)_"^"_$PIECE(X,"^",3)
+13 FOR KKK=0:0
SET KKK=$ORDER(^FH(119.6,KKK))
IF KKK<1
QUIT
SET X=$GET(^(KKK,0))
DO UPD
+14 QUIT
SET SET NAM=$PIECE(X,"^",1)
SET NAM=$EXTRACT(NAM,1,27)
SET SVC=$PIECE(X,"^",4)
SET DP(KKK,"PF")=PF
SET DP(KKK,"CF")=CF
SET DP(KKK,"S")=SF
SET DRSVC=$PIECE(X,"^",5)
+1 FOR X="T","C","D"
SET DP(KKK,X)=""
+2 IF SVC["T"
KILL DD,DO
SET DIC="^FH(119.72,"
SET DIC(0)="L"
SET X=NAM_" TL"
SET DIC("DR")="1///T;2////^S X=PF"
DO FILE^DICN
SET DP(KKK,"T")=+Y
DO PER
+3 IF SVC["C"
KILL DD,DO
SET DIC="^FH(119.72,"
SET DIC(0)="L"
SET X=NAM_" CF"
SET DIC("DR")="1///C;2////^S X=PF"
DO FILE^DICN
SET DP(KKK,"C")=+Y
DO PER
+4 IF SVC["D"
SET DP(KKK,"D")=1
+5 SET ^FH(119.7,KKK,4)=DP(KKK,"T")_"^"_DP(KKK,"C")_"^"_DP(KKK,"D")_"^"_DRSVC
DO ADD
QUIT
PER IF $ORDER(^FH(119.7,KKK,"A",0))=""
QUIT
SET LLL=+Y
+1 SET %X="^FH(119.7,KKK,""A"","
SET %Y="^FH(119.72,LLL,""A"","
DO %XY^%RCR
+2 SET $PIECE(^FH(119.72,LLL,"A",0),"^",2)="119.7211P"
QUIT
ADD IF $ORDER(^FH(119.7,KKK,"B",0))=""
QUIT
SET LLL=$SELECT(SVC["C":"C",1:"T")
SET LLL=DP(KKK,LLL)
IF 'LLL
QUIT
+1 SET %X="^FH(119.7,KKK,""B"","
SET %Y="^FH(119.72,LLL,""B"","
DO %XY^%RCR
+2 SET $PIECE(^FH(119.72,LLL,"B",0),"^",2)="119.721P"
QUIT
UPD ; Update Dietetic Wards
+1 SET DP=+$PIECE(X,"^",3)
IF '$DATA(DP(DP))
SET DP=""
SET $PIECE(^FH(119.6,KKK,0),"^",15,16)=SP
+2 IF DP
SET SVC=""
IF DP(DP,"T")
SET SVC=SVC_"T"
IF DP(DP,"C")
SET SVC=SVC_"C"
IF DP(DP,"D")
SET SVC=SVC_"D"
+3 IF DP
SET $PIECE(^FH(119.6,KKK,0),"^",5,10)=DP(DP,"T")_"^"_DP(DP,"C")_"^"_DP(DP,"D")_"^"_DP(DP,"CF")_"^"_DP(DP,"S")_"^"_SVC
+4 SET $PIECE(^FH(119.6,KKK,0),"^",11,14)="3^7^14^3"
QUIT
