FHPRC6 ; HISC/REL/NCA - Edit Meal Production Diets ;2/26/96 10:04
;;5.5;DIETETICS;;Jan 28, 2005
R0 S DIC="^FH(116.1,",DIC(0)="AEQM" W ! D ^DIC K DIC G KIL:U[X!$D(DTOUT),R0:Y<1 S D0=+Y
R1 S DIC="^FH(116.1,D0,""RE"",",DIC(0)="AEQM" W ! D ^DIC K DIC G KIL:X[U!$D(DTOUT),R0:X="",R1:Y<1 S D1=+Y
Q:$O(^FH(116.1,D0,"RE",D1,"R",0))<1
R11 S DIC="^FH(116.1,D0,""RE"",D1,""R"",",DIC(0)="AEQM" W ! D ^DIC K DIC G KIL:X[U!$D(DTOUT),R1:X="",R11:Y<1 S CAT=+Y
S OLD=$P(^FH(116.1,D0,"RE",D1,"R",CAT,0),"^",2)
I $E(OLD,$L(OLD))=" " S OLD=$E(OLD,1,$L(OLD)-1)
S NEW=OLD D IN
R2 D LI R !!,"Action: ",Y:DTIME G:'$T KIL I "^"[Y S:OLD'=NEW $P(^FH(116.1,D0,"RE",D1,"R",CAT,0),"^",2)=NEW G R1
I Y["?" D IN G R2
S X=Y D TR^FH S Y=X
S Z=$E(Y,1),FLG=0 G AD:Z="+",DE:Z="-",MO
Q
AD S FHX1=$E(Y,2,999) F LL=1:1 Q:$P(FHX1," ",LL,99)="" S FHX2=$P(FHX1," ",LL),PD=$P(FHX2,";",1) D A1 Q:'$D(X)
W:'FLG " ok"
G R2
A1 D CK I X6<0 S FLG=1 Q
I X6 W *7,!?5," ",FHX2," already exists! Use Modify option." S FLG=1 Q
S X=NEW_" "_FHX2 S:$E(X,1)=" " X=$E(X,2,999) D EN2^FHPRC1 I $D(X) S NEW=X
Q
DE S FHX1=$E(Y,2,999) F LL=1:1 Q:$P(FHX1," ",LL,99)="" S FHX2=$P(FHX1," ",LL),PD=$P(FHX2,";",1) D D1
W:'FLG " ok"
G R2
D1 D CK I X6<0 S FLG=1 Q
I 'X6 W *7,!?5," ",FHX2," does not exist!" S FLG=1 Q
S X=$P(NEW," ",1,X6-1)_" "_$P(NEW," ",X6+1,999) S:$E(X,1)=" " X=$E(X,2,999) S:$E(X,$L(X))=" " X=$E(X,1,$L(X)-1)
D EN2^FHPRC1 I $D(X) S NEW=X
Q
MO S PD=$E(Y,1,2) D CK G:X6<0 R2
I 'X6 W *7," ",PD," does not exist!" G R2
S X=NEW,$P(X," ",X6)=Y I $L(X)>200 W *7,!!?5,"String Length >200." K X G R2
D EN2^FHPRC1 I $D(X) S NEW=X W " ok"
G R2
CK S:PD'?1U1UN PD="---" I '$D(^FH(116.2,"C",PD)) W *7,!?5," ",PD," Not a valid Production Diet code!" S X6=-1 Q
S X6=0 F K=1:1 S Z=$P(NEW," ",K) Q:Z="" I $E(Z,1,2)=PD S X6=K Q
Q
E1 W *7," Illegal Production Diet code" G R2
LI W !!,"Production Diets: " S X=NEW
L1 I $L(X)<61 W ?19,X Q
F N1=61:-1:1 Q:$E(X,N1)=" "
W ?19,$E(X,1,N1-1) S X=$E(X,N1+1,999) Q:X="" W ! G L1
IN W !!?5,"Enter + to add (example: +RG;C50)"
W !?5,"Enter -Production Diet to delete (example: -RG)"
W !?5,"Enter new code to modify (example: LS;C30)" Q
KIL G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHPRC6 2211 printed Apr 09, 2024@21:00:03 Page 2
FHPRC6 ; HISC/REL/NCA - Edit Meal Production Diets ;2/26/96 10:04
+1 ;;5.5;DIETETICS;;Jan 28, 2005
R0 SET DIC="^FH(116.1,"
SET DIC(0)="AEQM"
WRITE !
DO ^DIC
KILL DIC
if U[X!$DATA(DTOUT)
GOTO KIL
if Y<1
GOTO R0
SET D0=+Y
R1 SET DIC="^FH(116.1,D0,""RE"","
SET DIC(0)="AEQM"
WRITE !
DO ^DIC
KILL DIC
if X[U!$DATA(DTOUT)
GOTO KIL
if X=""
GOTO R0
if Y<1
GOTO R1
SET D1=+Y
+1 if $ORDER(^FH(116.1,D0,"RE",D1,"R",0))<1
QUIT
R11 SET DIC="^FH(116.1,D0,""RE"",D1,""R"","
SET DIC(0)="AEQM"
WRITE !
DO ^DIC
KILL DIC
if X[U!$DATA(DTOUT)
GOTO KIL
if X=""
GOTO R1
if Y<1
GOTO R11
SET CAT=+Y
+1 SET OLD=$PIECE(^FH(116.1,D0,"RE",D1,"R",CAT,0),"^",2)
+2 IF $EXTRACT(OLD,$LENGTH(OLD))=" "
SET OLD=$EXTRACT(OLD,1,$LENGTH(OLD)-1)
+3 SET NEW=OLD
DO IN
R2 DO LI
READ !!,"Action: ",Y:DTIME
if '$TEST
GOTO KIL
IF "^"[Y
if OLD'=NEW
SET $PIECE(^FH(116.1,D0,"RE",D1,"R",CAT,0),"^",2)=NEW
GOTO R1
+1 IF Y["?"
DO IN
GOTO R2
+2 SET X=Y
DO TR^FH
SET Y=X
+3 SET Z=$EXTRACT(Y,1)
SET FLG=0
if Z="+"
GOTO AD
if Z="-"
GOTO DE
GOTO MO
+4 QUIT
AD SET FHX1=$EXTRACT(Y,2,999)
FOR LL=1:1
if $PIECE(FHX1," ",LL,99)=""
QUIT
SET FHX2=$PIECE(FHX1," ",LL)
SET PD=$PIECE(FHX2,";",1)
DO A1
if '$DATA(X)
QUIT
+1 if 'FLG
WRITE " ok"
+2 GOTO R2
A1 DO CK
IF X6<0
SET FLG=1
QUIT
+1 IF X6
WRITE *7,!?5," ",FHX2," already exists! Use Modify option."
SET FLG=1
QUIT
+2 SET X=NEW_" "_FHX2
if $EXTRACT(X,1)=" "
SET X=$EXTRACT(X,2,999)
DO EN2^FHPRC1
IF $DATA(X)
SET NEW=X
+3 QUIT
DE SET FHX1=$EXTRACT(Y,2,999)
FOR LL=1:1
if $PIECE(FHX1," ",LL,99)=""
QUIT
SET FHX2=$PIECE(FHX1," ",LL)
SET PD=$PIECE(FHX2,";",1)
DO D1
+1 if 'FLG
WRITE " ok"
+2 GOTO R2
D1 DO CK
IF X6<0
SET FLG=1
QUIT
+1 IF 'X6
WRITE *7,!?5," ",FHX2," does not exist!"
SET FLG=1
QUIT
+2 SET X=$PIECE(NEW," ",1,X6-1)_" "_$PIECE(NEW," ",X6+1,999)
if $EXTRACT(X,1)=" "
SET X=$EXTRACT(X,2,999)
if $EXTRACT(X,$LENGTH(X))=" "
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
+3 DO EN2^FHPRC1
IF $DATA(X)
SET NEW=X
+4 QUIT
MO SET PD=$EXTRACT(Y,1,2)
DO CK
if X6<0
GOTO R2
+1 IF 'X6
WRITE *7," ",PD," does not exist!"
GOTO R2
+2 SET X=NEW
SET $PIECE(X," ",X6)=Y
IF $LENGTH(X)>200
WRITE *7,!!?5,"String Length >200."
KILL X
GOTO R2
+3 DO EN2^FHPRC1
IF $DATA(X)
SET NEW=X
WRITE " ok"
+4 GOTO R2
CK if PD'?1U1UN
SET PD="---"
IF '$DATA(^FH(116.2,"C",PD))
WRITE *7,!?5," ",PD," Not a valid Production Diet code!"
SET X6=-1
QUIT
+1 SET X6=0
FOR K=1:1
SET Z=$PIECE(NEW," ",K)
if Z=""
QUIT
IF $EXTRACT(Z,1,2)=PD
SET X6=K
QUIT
+2 QUIT
E1 WRITE *7," Illegal Production Diet code"
GOTO R2
LI WRITE !!,"Production Diets: "
SET X=NEW
L1 IF $LENGTH(X)<61
WRITE ?19,X
QUIT
+1 FOR N1=61:-1:1
if $EXTRACT(X,N1)=" "
QUIT
+2 WRITE ?19,$EXTRACT(X,1,N1-1)
SET X=$EXTRACT(X,N1+1,999)
if X=""
QUIT
WRITE !
GOTO L1
IN WRITE !!?5,"Enter + to add (example: +RG;C50)"
+1 WRITE !?5,"Enter -Production Diet to delete (example: -RG)"
+2 WRITE !?5,"Enter new code to modify (example: LS;C30)"
QUIT
KIL GOTO KILL^XUSCLEAN
