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

FHADR10.m

Go to the documentation of this file.
  1. FHADR10 ; HISC/NCA - Dietetic Equipment ;1/5/94 14:30
  1. ;;5.5;DIETETICS;;Jan 28, 2005
  1. EN1 ; Enter/Edit Dietetic Equipment
  1. D YR^FHADR1 G:'PRE KIL
  1. S X1=PRE,X2=-356 D C^%DTC S OLD=$E(X,1,4)_"400" I $O(^FH(117.3,PRE,"EQUI",0))<1 D S1
  1. K DIC,DIE W ! S DIE="^FH(117.3,",DA=PRE,DR="38:39"
  1. D ^DIE K DA,DIC,DIE,DR S OLD=PRE
  1. SET ; Set all three quarters with the Dietetic Equipment Data
  1. F QTR=2:1:4 S PRE=$E(OLD,1,4)_QTR_"00" D S1
  1. KIL G KILL^XUSCLEAN
  1. S1 S TIT="EQUI"
  1. I $O(^FH(117.3,OLD,TIT,0))>0 K ^FH(117.3,PRE,TIT) D
  1. .S $P(^FH(117.3,PRE,3),"^",1)=$P($G(^FH(117.3,OLD,3)),"^",1)
  1. .I '$D(^FH(117.3,PRE,TIT,0)) S ^(0)="^117.338P^^"
  1. .F K1=0:0 S K1=$O(^FH(117.3,OLD,TIT,K1)) Q:K1<1 S L1=$G(^(K1,0)) D
  1. ..S ^FH(117.3,PRE,TIT,K1,0)=L1,^FH(117.3,PRE,TIT,"B",+L1,K1)=""
  1. ..S Z=$G(^FH(117.3,PRE,TIT,0))
  1. ..S $P(^FH(117.3,PRE,TIT,0),"^",3,4)=K1_"^"_($P(Z,"^",4)+1)
  1. ..Q
  1. .Q
  1. Q
  1. EN2 ; Print the CMR Cost,Dietetic Equipment, and Brand
  1. D HDR
  1. S PRE=FHYR_"0000",X1=""
  1. F L1=PRE:0 S L1=$O(^FH(117.3,L1)) Q:L1<1!($E(L1,1,3)'=$E(PRE,1,3)) I $P($G(^FH(117.3,L1,3)),"^",1)'<1 S X1=L1
  1. I X1'="" S Z=$P($G(^FH(117.3,X1,3)),"^",1) W !,"CMR Cost",!?2,"Total",?46 S X=Z,X2="0$" D COMMA^%DTC W X
  1. W !!,"EQUIPMENT",?40,"BRAND",! S X1=""
  1. F L1=PRE:0 S L1=$O(^FH(117.3,L1)) Q:L1<1!($E(L1,1,3)'=$E(PRE,1,3)) I $P($G(^FH(117.3,L1,"EQUI",0)),"^",3)'="" S X1=L1
  1. Q:X1=""
  1. S L2=0 F S L2=$O(^FH(117.3,X1,"EQUI",L2)) Q:L2<1 D
  1. .S X=$G(^FH(117.3,X1,"EQUI",L2,0))
  1. .S Z=$P(X,"^",1),Z=$P($G(^FH(117.4,Z,0)),"^",1),BRD=$P(X,"^",2)
  1. .W !,Z,?40,BRD
  1. .Q
  1. Q
  1. HDR ; Print Heading for Dietetic Equipment
  1. D:$Y'<21 HDR^FHADRPT
  1. W !!!,"S E C T I O N VII E Q U I P M E N T",!!
  1. Q