FHXMOV ; HISC/NCA - Process Annual Report Movement ;4/8/94 09:03
;;5.5;DIETETICS;;Jan 28, 2005
EN1 ; Move Data for Facility Profile in all four qtrs
W !!,"Annual Report Data Conversion"
K FHN F PRE=0:0 S PRE=$O(^FH(117.3,PRE)) Q:PRE<1 S STG=$G(^(PRE,0)),STG1=$G(^(1)),STG2=$G(^(3)) D MOV
F FNOD=0:0 S FNOD=$O(FHN(FNOD)) Q:FNOD<1 F QTR=1:1:4 S PRE=FNOD_QTR_"00",STG=$G(^FH(117.3,PRE,0)),STG1=$G(^FH(117.3,PRE,1)),STG2=$G(^FH(117.3,PRE,3)) D CHK
W !!,"Removal of Dietetic Survey Entries"
K DA,DIK,DIU S DIU=117.334,DIU(0)="SD" D EN^DIU2 S DIK="^DD(117.3,",DA(1)=117.3,DA=34 D ^DIK
K DA,DIK,DIU S DIU=117.335,DIU(0)="SD" D EN^DIU2 S DIK="^DD(117.3,",DA(1)=117.3,DA=35 D ^DIK
K DA,DIK,DIU S DIU=117.336,DIU(0)="SD" D EN^DIU2 S DIK="^DD(117.3,",DA(1)=117.3,DA=36 D ^DIK
K DA,DIK,DIU S DIU=117.337,DIU(0)="SD" D EN^DIU2 S DIK="^DD(117.3,",DA(1)=117.3,DA=37 D ^DIK
K %,%H,%I,%T,DA,DIK,DIU,FHN,FNOD,I,J,K2,K3,LP,LST,PRE,STG,STG1,STG2,STR,TIT,TRN,QTR,X,XX,Z,Z1,ZZ Q
MOV ; Process Moving Data
S FNOD=$E(PRE,1,4)
I "^^^^^^^^^^"'[$P(STG,"^",2,12) S FHN(FNOD,1)=STG
I "^^"'[$P(STG,"^",14,16) S FHN(FNOD,2)=$P(STG,"^",14,16)
I "^^^"'[$P(STG1,"^",14,17) S FHN(FNOD,3)=$P(STG1,"^",14,17)
I "^^^^^^"'[$P(STG2,"^",2,8) S FHN(FNOD,4)=$P(STG2,"^",2,8)
I $P(STG2,"^",1)'="" S FHN(FNOD,5)=$P(STG2,"^",1)
F TIT="AREA","DELV","EQUI","SPEC" D
.I $O(^FH(117.3,PRE,TIT,0))>0 D
..I $O(FHN(FNOD,TIT,0))>0 K FHN(FNOD,TIT)
..S STR="" F K2=0:0 S K2=$O(^FH(117.3,PRE,TIT,K2)) Q:K2<1 S STR=$G(^(K2,0)),FHN(FNOD,TIT,K2)=STR
..Q
.Q
F LST="SURV1","TEMP" D
.S TRN=$S(LST="SURV1":"OVA",1:"TEM")
.Q:'$D(^FH(117.3,PRE,LST,0))
.F LP=0:0 S LP=$O(^FH(117.3,PRE,LST,LP)) Q:LP<1 S ZZ=$P($G(^(LP,0)),"^",2,25) I "^^^^^^^^^^^^^^^^^^^^^^^"'[ZZ D
..I '$D(^FH(117.3,PRE,TRN,0)) S ^FH(117.3,PRE,TRN,0)=$S(TRN="TEM":"^117.31^^",1:"^117.366^^")
..S XX=$TR(ZZ,"^"," "),J=1,Z1=""
..F I=1:1:6 S:Z1'="" Z1=Z1_"^" S Z1=Z1_$S($P(XX," ",J):"V"_$P(XX," ",J),1:"")_$S($P(XX," ",J+1):" G"_$P(XX," ",J+1),1:"")_$S($P(XX," ",J+2):" F"_$P(XX," ",J+2),1:"")_$S($P(XX," ",J+3):" P"_$P(XX," ",J+3),1:"") S J=J+4
..Q:$D(^FH(117.3,PRE,TRN,LP,0))
..S Z=$G(^FH(117.3,PRE,TRN,0))
..S $P(^FH(117.3,PRE,TRN,0),"^",3,4)=LP_"^"_($P(Z,"^",4)+1)
..S ^FH(117.3,PRE,TRN,LP,0)=LP_"^"_Z1,^FH(117.3,PRE,TRN,"B",LP,LP)=""
..Q
.Q
Q
CHK ; Check to store Data Moved
I STG="" S $P(^FH(117.3,PRE,0),"^",1)=PRE,^FH(117.3,"B",PRE,PRE)="",Z=$G(^FH(117.3,0)),$P(^FH(117.3,0),"^",3,4)=PRE_"^"_($P(Z,"^",4)+1),$P(^FH(117.3,PRE,0),"^",2,26)=$P($G(FHN(FNOD,1)),"^",2,26)
I "^^"[$P(STG,"^",14,16) S $P(^FH(117.3,PRE,0),"^",14,16)=$G(FHN(FNOD,2))
I "^^^"[$P(STG1,"^",14,17) S $P(^FH(117.3,PRE,1),"^",14,17)=$G(FHN(FNOD,3))
I "^^^^^^"[$P(STG2,"^",2,8) S $P(^FH(117.3,PRE,3),"^",2,8)=$G(FHN(FNOD,4))
I $P(STG2,"^",1)="" S $P(^FH(117.3,PRE,3),"^",1)=$G(FHN(FNOD,5))
F TIT="AREA","DELV","EQUI","SPEC" D
.I $O(^FH(117.3,PRE,TIT,0))<1,$O(FHN(FNOD,TIT,0))>0 D
..I '$D(^FH(117.3,PRE,TIT,0)) S ^FH(117.3,PRE,TIT,0)=$S(TIT="AREA":"^117.356S^^",TIT="DELV":"^117.313P^^",TIT="EQUI":"^117.338P^^",1:"^117.312P^^")
..F K2=0:0 S K2=$O(FHN(FNOD,TIT,K2)) Q:K2<1 S K3=$G(FHN(FNOD,TIT,K2)) D
...S ^FH(117.3,PRE,TIT,K2,0)=K3,^FH(117.3,PRE,TIT,"B",+K3,K2)="",Z=$G(^FH(117.3,PRE,TIT,0))
...S $P(^FH(117.3,PRE,TIT,0),"^",3,4)=K2_"^"_($P(Z,"^",4)+1)
...Q
..Q
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHXMOV 3350 printed Sep 23, 2025@19:31:44 Page 2
FHXMOV ; HISC/NCA - Process Annual Report Movement ;4/8/94 09:03
+1 ;;5.5;DIETETICS;;Jan 28, 2005
EN1 ; Move Data for Facility Profile in all four qtrs
+1 WRITE !!,"Annual Report Data Conversion"
+2 KILL FHN
FOR PRE=0:0
SET PRE=$ORDER(^FH(117.3,PRE))
if PRE<1
QUIT
SET STG=$GET(^(PRE,0))
SET STG1=$GET(^(1))
SET STG2=$GET(^(3))
DO MOV
+3 FOR FNOD=0:0
SET FNOD=$ORDER(FHN(FNOD))
if FNOD<1
QUIT
FOR QTR=1:1:4
SET PRE=FNOD_QTR_"00"
SET STG=$GET(^FH(117.3,PRE,0))
SET STG1=$GET(^FH(117.3,PRE,1))
SET STG2=$GET(^FH(117.3,PRE,3))
DO CHK
+4 WRITE !!,"Removal of Dietetic Survey Entries"
+5 KILL DA,DIK,DIU
SET DIU=117.334
SET DIU(0)="SD"
DO EN^DIU2
SET DIK="^DD(117.3,"
SET DA(1)=117.3
SET DA=34
DO ^DIK
+6 KILL DA,DIK,DIU
SET DIU=117.335
SET DIU(0)="SD"
DO EN^DIU2
SET DIK="^DD(117.3,"
SET DA(1)=117.3
SET DA=35
DO ^DIK
+7 KILL DA,DIK,DIU
SET DIU=117.336
SET DIU(0)="SD"
DO EN^DIU2
SET DIK="^DD(117.3,"
SET DA(1)=117.3
SET DA=36
DO ^DIK
+8 KILL DA,DIK,DIU
SET DIU=117.337
SET DIU(0)="SD"
DO EN^DIU2
SET DIK="^DD(117.3,"
SET DA(1)=117.3
SET DA=37
DO ^DIK
+9 KILL %,%H,%I,%T,DA,DIK,DIU,FHN,FNOD,I,J,K2,K3,LP,LST,PRE,STG,STG1,STG2,STR,TIT,TRN,QTR,X,XX,Z,Z1,ZZ
QUIT
MOV ; Process Moving Data
+1 SET FNOD=$EXTRACT(PRE,1,4)
+2 IF "^^^^^^^^^^"'[$PIECE(STG,"^",2,12)
SET FHN(FNOD,1)=STG
+3 IF "^^"'[$PIECE(STG,"^",14,16)
SET FHN(FNOD,2)=$PIECE(STG,"^",14,16)
+4 IF "^^^"'[$PIECE(STG1,"^",14,17)
SET FHN(FNOD,3)=$PIECE(STG1,"^",14,17)
+5 IF "^^^^^^"'[$PIECE(STG2,"^",2,8)
SET FHN(FNOD,4)=$PIECE(STG2,"^",2,8)
+6 IF $PIECE(STG2,"^",1)'=""
SET FHN(FNOD,5)=$PIECE(STG2,"^",1)
+7 FOR TIT="AREA","DELV","EQUI","SPEC"
Begin DoDot:1
+8 IF $ORDER(^FH(117.3,PRE,TIT,0))>0
Begin DoDot:2
+9 IF $ORDER(FHN(FNOD,TIT,0))>0
KILL FHN(FNOD,TIT)
+10 SET STR=""
FOR K2=0:0
SET K2=$ORDER(^FH(117.3,PRE,TIT,K2))
if K2<1
QUIT
SET STR=$GET(^(K2,0))
SET FHN(FNOD,TIT,K2)=STR
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 FOR LST="SURV1","TEMP"
Begin DoDot:1
+14 SET TRN=$SELECT(LST="SURV1":"OVA",1:"TEM")
+15 if '$DATA(^FH(117.3,PRE,LST,0))
QUIT
+16 FOR LP=0:0
SET LP=$ORDER(^FH(117.3,PRE,LST,LP))
if LP<1
QUIT
SET ZZ=$PIECE($GET(^(LP,0)),"^",2,25)
IF "^^^^^^^^^^^^^^^^^^^^^^^"'[ZZ
Begin DoDot:2
+17 IF '$DATA(^FH(117.3,PRE,TRN,0))
SET ^FH(117.3,PRE,TRN,0)=$SELECT(TRN="TEM":"^117.31^^",1:"^117.366^^")
+18 SET XX=$TRANSLATE(ZZ,"^"," ")
SET J=1
SET Z1=""
+19 FOR I=1:1:6
if Z1'=""
SET Z1=Z1_"^"
SET Z1=Z1_$SELECT($PIECE(XX," ",J):"V"_$PIECE(XX," ",J),1:"")_$SELECT($PIECE(XX," ",J+1):" G"_$PIECE(XX," ",J+1),1:"")_$SELECT($PIECE(XX," ",J+2):" F"_$PIECE(XX," ",J+2),1:"")_$SELECT($PIECE(XX," ",J+3):" P"_$PIECE(XX,"
",J+3),1:"")
SET J=J+4
+20 if $DATA(^FH(117.3,PRE,TRN,LP,0))
QUIT
+21 SET Z=$GET(^FH(117.3,PRE,TRN,0))
+22 SET $PIECE(^FH(117.3,PRE,TRN,0),"^",3,4)=LP_"^"_($PIECE(Z,"^",4)+1)
+23 SET ^FH(117.3,PRE,TRN,LP,0)=LP_"^"_Z1
SET ^FH(117.3,PRE,TRN,"B",LP,LP)=""
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
+26 QUIT
CHK ; Check to store Data Moved
+1 IF STG=""
SET $PIECE(^FH(117.3,PRE,0),"^",1)=PRE
SET ^FH(117.3,"B",PRE,PRE)=""
SET Z=$GET(^FH(117.3,0))
SET $PIECE(^FH(117.3,0),"^",3,4)=PRE_"^"_($PIECE(Z,"^",4)+1)
SET $PIECE(^FH(117.3,PRE,0),"^",2,26)=$PIECE($GET(FHN(FNOD,1)),"^",2,26)
+2 IF "^^"[$PIECE(STG,"^",14,16)
SET $PIECE(^FH(117.3,PRE,0),"^",14,16)=$GET(FHN(FNOD,2))
+3 IF "^^^"[$PIECE(STG1,"^",14,17)
SET $PIECE(^FH(117.3,PRE,1),"^",14,17)=$GET(FHN(FNOD,3))
+4 IF "^^^^^^"[$PIECE(STG2,"^",2,8)
SET $PIECE(^FH(117.3,PRE,3),"^",2,8)=$GET(FHN(FNOD,4))
+5 IF $PIECE(STG2,"^",1)=""
SET $PIECE(^FH(117.3,PRE,3),"^",1)=$GET(FHN(FNOD,5))
+6 FOR TIT="AREA","DELV","EQUI","SPEC"
Begin DoDot:1
+7 IF $ORDER(^FH(117.3,PRE,TIT,0))<1
IF $ORDER(FHN(FNOD,TIT,0))>0
Begin DoDot:2
+8 IF '$DATA(^FH(117.3,PRE,TIT,0))
SET ^FH(117.3,PRE,TIT,0)=$SELECT(TIT="AREA":"^117.356S^^",TIT="DELV":"^117.313P^^",TIT="EQUI":"^117.338P^^",1:"^117.312P^^")
+9 FOR K2=0:0
SET K2=$ORDER(FHN(FNOD,TIT,K2))
if K2<1
QUIT
SET K3=$GET(FHN(FNOD,TIT,K2))
Begin DoDot:3
+10 SET ^FH(117.3,PRE,TIT,K2,0)=K3
SET ^FH(117.3,PRE,TIT,"B",+K3,K2)=""
SET Z=$GET(^FH(117.3,PRE,TIT,0))
+11 SET $PIECE(^FH(117.3,PRE,TIT,0),"^",3,4)=K2_"^"_($PIECE(Z,"^",4)+1)
+12 QUIT
End DoDot:3
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 QUIT
