- FHADR10 ; HISC/NCA - Dietetic Equipment ;1/5/94 14:30
- ;;5.5;DIETETICS;;Jan 28, 2005
- EN1 ; Enter/Edit Dietetic Equipment
- D YR^FHADR1 G:'PRE KIL
- 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
- K DIC,DIE W ! S DIE="^FH(117.3,",DA=PRE,DR="38:39"
- D ^DIE K DA,DIC,DIE,DR S OLD=PRE
- SET ; Set all three quarters with the Dietetic Equipment Data
- F QTR=2:1:4 S PRE=$E(OLD,1,4)_QTR_"00" D S1
- KIL G KILL^XUSCLEAN
- S1 S TIT="EQUI"
- I $O(^FH(117.3,OLD,TIT,0))>0 K ^FH(117.3,PRE,TIT) D
- .S $P(^FH(117.3,PRE,3),"^",1)=$P($G(^FH(117.3,OLD,3)),"^",1)
- .I '$D(^FH(117.3,PRE,TIT,0)) S ^(0)="^117.338P^^"
- .F K1=0:0 S K1=$O(^FH(117.3,OLD,TIT,K1)) Q:K1<1 S L1=$G(^(K1,0)) D
- ..S ^FH(117.3,PRE,TIT,K1,0)=L1,^FH(117.3,PRE,TIT,"B",+L1,K1)=""
- ..S Z=$G(^FH(117.3,PRE,TIT,0))
- ..S $P(^FH(117.3,PRE,TIT,0),"^",3,4)=K1_"^"_($P(Z,"^",4)+1)
- ..Q
- .Q
- Q
- EN2 ; Print the CMR Cost,Dietetic Equipment, and Brand
- D HDR
- S PRE=FHYR_"0000",X1=""
- 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
- 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
- W !!,"EQUIPMENT",?40,"BRAND",! S X1=""
- 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
- Q:X1=""
- S L2=0 F S L2=$O(^FH(117.3,X1,"EQUI",L2)) Q:L2<1 D
- .S X=$G(^FH(117.3,X1,"EQUI",L2,0))
- .S Z=$P(X,"^",1),Z=$P($G(^FH(117.4,Z,0)),"^",1),BRD=$P(X,"^",2)
- .W !,Z,?40,BRD
- .Q
- Q
- HDR ; Print Heading for Dietetic Equipment
- D:$Y'<21 HDR^FHADRPT
- W !!!,"S E C T I O N VII E Q U I P M E N T",!!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHADR10 1676 printed Feb 18, 2025@23:12:50 Page 2
- FHADR10 ; HISC/NCA - Dietetic Equipment ;1/5/94 14:30
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- EN1 ; Enter/Edit Dietetic Equipment
- +1 DO YR^FHADR1
- if 'PRE
- GOTO KIL
- +2 SET X1=PRE
- SET X2=-356
- DO C^%DTC
- SET OLD=$EXTRACT(X,1,4)_"400"
- IF $ORDER(^FH(117.3,PRE,"EQUI",0))<1
- DO S1
- +3 KILL DIC,DIE
- WRITE !
- SET DIE="^FH(117.3,"
- SET DA=PRE
- SET DR="38:39"
- +4 DO ^DIE
- KILL DA,DIC,DIE,DR
- SET OLD=PRE
- SET ; Set all three quarters with the Dietetic Equipment Data
- +1 FOR QTR=2:1:4
- SET PRE=$EXTRACT(OLD,1,4)_QTR_"00"
- DO S1
- KIL GOTO KILL^XUSCLEAN
- S1 SET TIT="EQUI"
- +1 IF $ORDER(^FH(117.3,OLD,TIT,0))>0
- KILL ^FH(117.3,PRE,TIT)
- Begin DoDot:1
- +2 SET $PIECE(^FH(117.3,PRE,3),"^",1)=$PIECE($GET(^FH(117.3,OLD,3)),"^",1)
- +3 IF '$DATA(^FH(117.3,PRE,TIT,0))
- SET ^(0)="^117.338P^^"
- +4 FOR K1=0:0
- SET K1=$ORDER(^FH(117.3,OLD,TIT,K1))
- if K1<1
- QUIT
- SET L1=$GET(^(K1,0))
- Begin DoDot:2
- +5 SET ^FH(117.3,PRE,TIT,K1,0)=L1
- SET ^FH(117.3,PRE,TIT,"B",+L1,K1)=""
- +6 SET Z=$GET(^FH(117.3,PRE,TIT,0))
- +7 SET $PIECE(^FH(117.3,PRE,TIT,0),"^",3,4)=K1_"^"_($PIECE(Z,"^",4)+1)
- +8 QUIT
- End DoDot:2
- +9 QUIT
- End DoDot:1
- +10 QUIT
- EN2 ; Print the CMR Cost,Dietetic Equipment, and Brand
- +1 DO HDR
- +2 SET PRE=FHYR_"0000"
- SET X1=""
- +3 FOR L1=PRE:0
- SET L1=$ORDER(^FH(117.3,L1))
- if L1<1!($EXTRACT(L1,1,3)'=$EXTRACT(PRE,1,3))
- QUIT
- IF $PIECE($GET(^FH(117.3,L1,3)),"^",1)'<1
- SET X1=L1
- +4 IF X1'=""
- SET Z=$PIECE($GET(^FH(117.3,X1,3)),"^",1)
- WRITE !,"CMR Cost",!?2,"Total",?46
- SET X=Z
- SET X2="0$"
- DO COMMA^%DTC
- WRITE X
- +5 WRITE !!,"EQUIPMENT",?40,"BRAND",!
- SET X1=""
- +6 FOR L1=PRE:0
- SET L1=$ORDER(^FH(117.3,L1))
- if L1<1!($EXTRACT(L1,1,3)'=$EXTRACT(PRE,1,3))
- QUIT
- IF $PIECE($GET(^FH(117.3,L1,"EQUI",0)),"^",3)'=""
- SET X1=L1
- +7 if X1=""
- QUIT
- +8 SET L2=0
- FOR
- SET L2=$ORDER(^FH(117.3,X1,"EQUI",L2))
- if L2<1
- QUIT
- Begin DoDot:1
- +9 SET X=$GET(^FH(117.3,X1,"EQUI",L2,0))
- +10 SET Z=$PIECE(X,"^",1)
- SET Z=$PIECE($GET(^FH(117.4,Z,0)),"^",1)
- SET BRD=$PIECE(X,"^",2)
- +11 WRITE !,Z,?40,BRD
- +12 QUIT
- End DoDot:1
- +13 QUIT
- HDR ; Print Heading for Dietetic Equipment
- +1 if $Y'<21
- DO HDR^FHADRPT
- +2 WRITE !!!,"S E C T I O N VII E Q U I P M E N T",!!
- +3 QUIT