- 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 Feb 18, 2025@23:22:07 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