- FHADR1 ; HISC/NCA - Dietetic Facility Profile ;1/23/98 15:03
- ;;5.5;DIETETICS;;Jan 28, 2005
- EN1 ; Enter/Edit Facility Data and Specialized Medical Programs
- S (FLG1,FLG2)=0 D YR G:'PRE KIL
- D GET G:Y<1 KIL S FHX1=+Y
- S ST=$G(^DIC(4,+FHX1,0)) Q:ST=""
- S X1=PRE,X2=-356 D C^%DTC S OLD=$E(X,1,4)_"400" I '$D(^FH(117.3,PRE,0)) D S1
- E1 W ! K DIR S DIR(0)="YAO",DIR("A")="Enter/Edit Facility Data? " D ^DIR G:$D(DIRUT)!($D(DIROUT)) KIL
- I 'Y K Y G E2
- S FLG1=1 D:FLG1 EDIT S FLG1=0
- E2 W ! K DIR S DIR(0)="YAO",DIR("A")="Enter/Edit Specialized Medical Programs? "
- D ^DIR I $D(DIRUT)!($D(DIROUT)) G KIL
- I 'Y K Y S OLD=PRE D SET G KIL
- S FLG2=1 D:FLG2 EDIT
- S OLD=PRE D SET
- KIL G KILL^XUSCLEAN
- EDIT ; Edit the Fields
- K DIC,DIE W ! S DIE="^FH(117.3,",DA=PRE
- L +^FH(117.3,PRE,0):0 I '$T W !?5,"Another user is editing this entry." G KIL
- I '$D(^FH(117.3,PRE,0)) D
- .S $P(^FH(117.3,PRE,0),"^",1)=PRE,^FH(117.3,"B",PRE,PRE)=""
- .S Z=$G(^FH(117.3,0)),$P(^FH(117.3,0),"^",3,4)=PRE_"^"_($P(Z,"^",4)+1)
- .S ZZ=$P($G(^FH(117.3,OLD,0)),"^",2,13)
- .I ZZ="" S $P(ZZ,"^",2,3)=$P(ST,"^",7)_"^"_$P($G(^DIC(4,+FHX1,"DIV")),"^",1)
- .S $P(^FH(117.3,PRE,0),"^",2,13)=ZZ
- .Q
- S DR=$S(FLG1:"2:11;13;51//Y;S:X'=""Y"" Y="""";52",1:"12;W !;53//Y;S:X'=""Y"" Y=""@1"";54;@1;55//Y;S:X'=""Y"" Y="""";56:57")
- D ^DIE L -^FH(117.3,PRE,0) K DA,DIC,DIE,DR,Z,ZZ Q
- SET ; Set all three quarters with the Facility Profile Data
- F QTR=2:1:4 S PRE=$E(OLD,1,4)_QTR_"00" D S1
- Q
- S1 ; Process Storage of Facility Profile Data
- Q:'$D(^FH(117.3,OLD,0))
- I '$D(^FH(117.3,PRE,0)) 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)
- S $P(^FH(117.3,PRE,0),"^",2,26)=$P($G(^FH(117.3,OLD,0)),"^",2,26)
- F TIT="AREA","DELV","SPEC" D
- .I $O(^FH(117.3,OLD,TIT,0))>0 K ^FH(117.3,PRE,TIT) D
- ..I '$D(^FH(117.3,PRE,TIT,0)) S ^(0)=$S(TIT="AREA":"^117.356S^^",TIT="DELV":"^117.313P^^",1:"^117.312P^^")
- ..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)),$P(^FH(117.3,PRE,TIT,0),"^",3,4)=K1_"^"_($P(Z,"^",4)+1)
- ...Q
- ..Q
- .Q
- Q
- GET ; Get the Facility Data from Institution file
- D SITE^FH
- K DIC S DIC="^DIC(4,",DIC(0)="AEMQ",DIC("A")="Enter Station Number: ",DIC("B")=SITE(1),D="D"
- W ! D MIX^DIC1 K DIC,SITE Q:"^"[X!($D(DTOUT)) Q:Y<1
- Q
- QR ; Read in Qtr and Year
- S (PRE,QTR)=0 D NOW^%DTC S NOW=%\1
- ;S YR=$E(NOW,2,3),S1=$E(NOW,4,5),QTR=$S(S1<4:1,S1<7:2,S1<10:3,1:4)
- S YR=$E(NOW,1,3)+1700,S1=$E(NOW,4,5),QTR=$S(S1<4:1,S1<7:2,S1<10:3,1:4)
- Q1 K %DT W !!,"Enter Qtr/Yr: "_QTR_"/"_YR_"// " R X:DTIME Q:'$T!(X["^")
- I X="" S X=$E(NOW,1,3)_"0"_QTR_"00"
- D ^%DT
- I $E(Y,6,7) W *7,?28," Do Not Enter Dates." G Q1
- ;I $E(Y,4,5)<1!($E(Y,4,5)>4)!($E(Y,1,3)>$E(NOW,1,3)) W *7," Answer Qtr 1-4 and Yr as Qtr/Yr.",!?28," Yr CANNOT be greater than now." G Q1
- I $E(Y,4,5)<1!($E(Y,4,5)>4)!($E(Y,1,3)>$E(NOW,1,3)) D G Q1
- .W *7," Answer Qtr 1-4 and Yr as 4 digit year, ie 2001."
- .W !?28," Example: 4/2001 for 4th quarter, year 2001."
- .W !?28," Yr CANNOT be greater than now."
- I $E(Y,4,5)>QTR&($E(Y,1,3)=$E(NOW,1,3)) W *7," Qtr/Yr must not be greater than default." G Q1
- S YR=$E(Y,2,3),QTR=$E(Y,5),PRE=$E(Y,1,5)_"00" Q
- YR ; Read in the Year
- W ! K %DT S PRE="",%DT="AEP",%DT("A")="Enter YR: "
- D ^%DT S:$D(DTOUT) X="^" Q:U[X G:Y<1 YR
- I $E(Y,1,3)>$E(DT,1,3) W *7," Do Not Enter Future Year." G YR
- I $E(Y,4,7)>0 W *7," Enter Year Only." G YR
- S Y=$E(Y,1,3)_"0100",PRE=Y Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHADR1 3577 printed Jan 18, 2025@02:47:39 Page 2
- FHADR1 ; HISC/NCA - Dietetic Facility Profile ;1/23/98 15:03
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- EN1 ; Enter/Edit Facility Data and Specialized Medical Programs
- +1 SET (FLG1,FLG2)=0
- DO YR
- if 'PRE
- GOTO KIL
- +2 DO GET
- if Y<1
- GOTO KIL
- SET FHX1=+Y
- +3 SET ST=$GET(^DIC(4,+FHX1,0))
- if ST=""
- QUIT
- +4 SET X1=PRE
- SET X2=-356
- DO C^%DTC
- SET OLD=$EXTRACT(X,1,4)_"400"
- IF '$DATA(^FH(117.3,PRE,0))
- DO S1
- E1 WRITE !
- KILL DIR
- SET DIR(0)="YAO"
- SET DIR("A")="Enter/Edit Facility Data? "
- DO ^DIR
- if $DATA(DIRUT)!($DATA(DIROUT))
- GOTO KIL
- +1 IF 'Y
- KILL Y
- GOTO E2
- +2 SET FLG1=1
- if FLG1
- DO EDIT
- SET FLG1=0
- E2 WRITE !
- KILL DIR
- SET DIR(0)="YAO"
- SET DIR("A")="Enter/Edit Specialized Medical Programs? "
- +1 DO ^DIR
- IF $DATA(DIRUT)!($DATA(DIROUT))
- GOTO KIL
- +2 IF 'Y
- KILL Y
- SET OLD=PRE
- DO SET
- GOTO KIL
- +3 SET FLG2=1
- if FLG2
- DO EDIT
- +4 SET OLD=PRE
- DO SET
- KIL GOTO KILL^XUSCLEAN
- EDIT ; Edit the Fields
- +1 KILL DIC,DIE
- WRITE !
- SET DIE="^FH(117.3,"
- SET DA=PRE
- +2 LOCK +^FH(117.3,PRE,0):0
- IF '$TEST
- WRITE !?5,"Another user is editing this entry."
- GOTO KIL
- +3 IF '$DATA(^FH(117.3,PRE,0))
- Begin DoDot:1
- +4 SET $PIECE(^FH(117.3,PRE,0),"^",1)=PRE
- SET ^FH(117.3,"B",PRE,PRE)=""
- +5 SET Z=$GET(^FH(117.3,0))
- SET $PIECE(^FH(117.3,0),"^",3,4)=PRE_"^"_($PIECE(Z,"^",4)+1)
- +6 SET ZZ=$PIECE($GET(^FH(117.3,OLD,0)),"^",2,13)
- +7 IF ZZ=""
- SET $PIECE(ZZ,"^",2,3)=$PIECE(ST,"^",7)_"^"_$PIECE($GET(^DIC(4,+FHX1,"DIV")),"^",1)
- +8 SET $PIECE(^FH(117.3,PRE,0),"^",2,13)=ZZ
- +9 QUIT
- End DoDot:1
- +10 SET DR=$SELECT(FLG1:"2:11;13;51//Y;S:X'=""Y"" Y="""";52",1:"12;W !;53//Y;S:X'=""Y"" Y=""@1"";54;@1;55//Y;S:X'=""Y"" Y="""";56:57")
- +11 DO ^DIE
- LOCK -^FH(117.3,PRE,0)
- KILL DA,DIC,DIE,DR,Z,ZZ
- QUIT
- SET ; Set all three quarters with the Facility Profile Data
- +1 FOR QTR=2:1:4
- SET PRE=$EXTRACT(OLD,1,4)_QTR_"00"
- DO S1
- +2 QUIT
- S1 ; Process Storage of Facility Profile Data
- +1 if '$DATA(^FH(117.3,OLD,0))
- QUIT
- +2 IF '$DATA(^FH(117.3,PRE,0))
- 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)
- +3 SET $PIECE(^FH(117.3,PRE,0),"^",2,26)=$PIECE($GET(^FH(117.3,OLD,0)),"^",2,26)
- +4 FOR TIT="AREA","DELV","SPEC"
- Begin DoDot:1
- +5 IF $ORDER(^FH(117.3,OLD,TIT,0))>0
- KILL ^FH(117.3,PRE,TIT)
- Begin DoDot:2
- +6 IF '$DATA(^FH(117.3,PRE,TIT,0))
- SET ^(0)=$SELECT(TIT="AREA":"^117.356S^^",TIT="DELV":"^117.313P^^",1:"^117.312P^^")
- +7 FOR K1=0:0
- SET K1=$ORDER(^FH(117.3,OLD,TIT,K1))
- if K1<1
- QUIT
- SET L1=$GET(^(K1,0))
- Begin DoDot:3
- +8 SET ^FH(117.3,PRE,TIT,K1,0)=L1
- SET ^FH(117.3,PRE,TIT,"B",+L1,K1)=""
- +9 SET Z=$GET(^FH(117.3,PRE,TIT,0))
- SET $PIECE(^FH(117.3,PRE,TIT,0),"^",3,4)=K1_"^"_($PIECE(Z,"^",4)+1)
- +10 QUIT
- End DoDot:3
- +11 QUIT
- End DoDot:2
- +12 QUIT
- End DoDot:1
- +13 QUIT
- GET ; Get the Facility Data from Institution file
- +1 DO SITE^FH
- +2 KILL DIC
- SET DIC="^DIC(4,"
- SET DIC(0)="AEMQ"
- SET DIC("A")="Enter Station Number: "
- SET DIC("B")=SITE(1)
- SET D="D"
- +3 WRITE !
- DO MIX^DIC1
- KILL DIC,SITE
- if "^"[X!($DATA(DTOUT))
- QUIT
- if Y<1
- QUIT
- +4 QUIT
- QR ; Read in Qtr and Year
- +1 SET (PRE,QTR)=0
- DO NOW^%DTC
- SET NOW=%\1
- +2 ;S YR=$E(NOW,2,3),S1=$E(NOW,4,5),QTR=$S(S1<4:1,S1<7:2,S1<10:3,1:4)
- +3 SET YR=$EXTRACT(NOW,1,3)+1700
- SET S1=$EXTRACT(NOW,4,5)
- SET QTR=$SELECT(S1<4:1,S1<7:2,S1<10:3,1:4)
- Q1 KILL %DT
- WRITE !!,"Enter Qtr/Yr: "_QTR_"/"_YR_"// "
- READ X:DTIME
- if '$TEST!(X["^")
- QUIT
- +1 IF X=""
- SET X=$EXTRACT(NOW,1,3)_"0"_QTR_"00"
- +2 DO ^%DT
- +3 IF $EXTRACT(Y,6,7)
- WRITE *7,?28," Do Not Enter Dates."
- GOTO Q1
- +4 ;I $E(Y,4,5)<1!($E(Y,4,5)>4)!($E(Y,1,3)>$E(NOW,1,3)) W *7," Answer Qtr 1-4 and Yr as Qtr/Yr.",!?28," Yr CANNOT be greater than now." G Q1
- +5 IF $EXTRACT(Y,4,5)<1!($EXTRACT(Y,4,5)>4)!($EXTRACT(Y,1,3)>$EXTRACT(NOW,1,3))
- Begin DoDot:1
- +6 WRITE *7," Answer Qtr 1-4 and Yr as 4 digit year, ie 2001."
- +7 WRITE !?28," Example: 4/2001 for 4th quarter, year 2001."
- +8 WRITE !?28," Yr CANNOT be greater than now."
- End DoDot:1
- GOTO Q1
- +9 IF $EXTRACT(Y,4,5)>QTR&($EXTRACT(Y,1,3)=$EXTRACT(NOW,1,3))
- WRITE *7," Qtr/Yr must not be greater than default."
- GOTO Q1
- +10 SET YR=$EXTRACT(Y,2,3)
- SET QTR=$EXTRACT(Y,5)
- SET PRE=$EXTRACT(Y,1,5)_"00"
- QUIT
- YR ; Read in the Year
- +1 WRITE !
- KILL %DT
- SET PRE=""
- SET %DT="AEP"
- SET %DT("A")="Enter YR: "
- +2 DO ^%DT
- if $DATA(DTOUT)
- SET X="^"
- if U[X
- QUIT
- if Y<1
- GOTO YR
- +3 IF $EXTRACT(Y,1,3)>$EXTRACT(DT,1,3)
- WRITE *7," Do Not Enter Future Year."
- GOTO YR
- +4 IF $EXTRACT(Y,4,7)>0
- WRITE *7," Enter Year Only."
- GOTO YR
- +5 SET Y=$EXTRACT(Y,1,3)_"0100"
- SET PRE=Y
- QUIT