Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FHXMOV

FHXMOV.m

Go to the documentation of this file.
  1. FHXMOV ; HISC/NCA - Process Annual Report Movement ;4/8/94 09:03
  1. ;;5.5;DIETETICS;;Jan 28, 2005
  1. EN1 ; Move Data for Facility Profile in all four qtrs
  1. W !!,"Annual Report Data Conversion"
  1. 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
  1. 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
  1. W !!,"Removal of Dietetic Survey Entries"
  1. 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
  1. 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
  1. 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
  1. 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
  1. 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
  1. MOV ; Process Moving Data
  1. S FNOD=$E(PRE,1,4)
  1. I "^^^^^^^^^^"'[$P(STG,"^",2,12) S FHN(FNOD,1)=STG
  1. I "^^"'[$P(STG,"^",14,16) S FHN(FNOD,2)=$P(STG,"^",14,16)
  1. I "^^^"'[$P(STG1,"^",14,17) S FHN(FNOD,3)=$P(STG1,"^",14,17)
  1. I "^^^^^^"'[$P(STG2,"^",2,8) S FHN(FNOD,4)=$P(STG2,"^",2,8)
  1. I $P(STG2,"^",1)'="" S FHN(FNOD,5)=$P(STG2,"^",1)
  1. F TIT="AREA","DELV","EQUI","SPEC" D
  1. .I $O(^FH(117.3,PRE,TIT,0))>0 D
  1. ..I $O(FHN(FNOD,TIT,0))>0 K FHN(FNOD,TIT)
  1. ..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
  1. ..Q
  1. .Q
  1. F LST="SURV1","TEMP" D
  1. .S TRN=$S(LST="SURV1":"OVA",1:"TEM")
  1. .Q:'$D(^FH(117.3,PRE,LST,0))
  1. .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
  1. ..I '$D(^FH(117.3,PRE,TRN,0)) S ^FH(117.3,PRE,TRN,0)=$S(TRN="TEM":"^117.31^^",1:"^117.366^^")
  1. ..S XX=$TR(ZZ,"^"," "),J=1,Z1=""
  1. ..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
  1. ..Q:$D(^FH(117.3,PRE,TRN,LP,0))
  1. ..S Z=$G(^FH(117.3,PRE,TRN,0))
  1. ..S $P(^FH(117.3,PRE,TRN,0),"^",3,4)=LP_"^"_($P(Z,"^",4)+1)
  1. ..S ^FH(117.3,PRE,TRN,LP,0)=LP_"^"_Z1,^FH(117.3,PRE,TRN,"B",LP,LP)=""
  1. ..Q
  1. .Q
  1. Q
  1. CHK ; Check to store Data Moved
  1. 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)
  1. I "^^"[$P(STG,"^",14,16) S $P(^FH(117.3,PRE,0),"^",14,16)=$G(FHN(FNOD,2))
  1. I "^^^"[$P(STG1,"^",14,17) S $P(^FH(117.3,PRE,1),"^",14,17)=$G(FHN(FNOD,3))
  1. I "^^^^^^"[$P(STG2,"^",2,8) S $P(^FH(117.3,PRE,3),"^",2,8)=$G(FHN(FNOD,4))
  1. I $P(STG2,"^",1)="" S $P(^FH(117.3,PRE,3),"^",1)=$G(FHN(FNOD,5))
  1. F TIT="AREA","DELV","EQUI","SPEC" D
  1. .I $O(^FH(117.3,PRE,TIT,0))<1,$O(FHN(FNOD,TIT,0))>0 D
  1. ..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^^")
  1. ..F K2=0:0 S K2=$O(FHN(FNOD,TIT,K2)) Q:K2<1 S K3=$G(FHN(FNOD,TIT,K2)) D
  1. ...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))
  1. ...S $P(^FH(117.3,PRE,TIT,0),"^",3,4)=K2_"^"_($P(Z,"^",4)+1)
  1. ...Q
  1. ..Q
  1. .Q
  1. Q