FHSEL2 ; HISC/REL/NCA/FAI - Tabulate Patient Preferences ;10/29/04 7:19
;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
;patch #5 - screen for cancelled guest meals.
S X="T",%DT="X" D ^%DT S DT=+Y
S FHP=$O(^FH(119.72,0)) I FHP'<1,$O(^FH(119.72,FHP))<1 S FHP=0 G D1
D0 R !!,"Select SERVICE POINT (or ALL): ",X:DTIME G:'$T!("^"[X) KIL D:X="all" TR^FH I X="ALL" S FHP=0
E K DIC S DIC="^FH(119.72,",DIC(0)="EMQ" D ^DIC G:Y<1 D0 S FHP=+Y
D1 R !!,"Tabulate By Menu Specific? N// ",D3:DTIME G:'$T!(D3="^") KIL
S:D3="" D3="N" S X=D3 D TR^FH S D3=X I $P("YES",D3,1)'="",$P("NO",D3,1)'="" W *7," Answer YES or NO" G D1
S D3=$E(D3,1) S:D3="Y" D3=D3="Y" I 'D3 S (D1,FHCY,FHDA)="" G R1
F1 S %DT("A")="Select Date: ",%DT="AEX" W ! D ^%DT G KIL:"^"[X!$D(DTOUT),F1:Y<1 S (X1,D1)=+Y
I D1<DT W *7," [ Must NOT be before TODAY ]" G F1
D E1^FHPRC1 I FHCY<1 W *7,!!,"No MENU CYCLE Defined for that Date!" G F1
I '$D(^FH(116,FHCY,"DA",FHDA,0)) W *7,!!,"MENU CYCLE DAY Not Defined for that Date!" G F1
R1 R !!,"Select MEAL (B,N,E or ALL): ",MEAL:DTIME G:'$T!("^"[MEAL) KIL S X=MEAL D TR^FH S MEAL=X S:$P("ALL",MEAL,1)="" MEAL="A"
I "BNEA"'[MEAL!(MEAL'?1U) W *7,!,"Select B for Breakfast, N for Noon, E for Evening or ALL for all meals" G R1
R2 R !!,"Break Down By Production Diets? N// ",SRT:DTIME G:'$T!(SRT="^") KIL S:SRT="" SRT="N" S X=SRT D TR^FH S SRT=X I $P("YES",SRT,1)'="",$P("NO",SRT,1)'="" W *7," Answer YES or NO" G R2
S SRT=$E(SRT,1),SRT=SRT="Y"
W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
I $D(IO("Q")) S FHPGM="Q1^FHSEL2",FHLST="D1^D3^FHP^FHCY^FHDA^MEAL^SRT" D EN2^FH G KIL
U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
Q1 ; Printing Tabulated Patient Preference
S FHMLSAV=MEAL
D NOW^%DTC S NOW=%,PG=0
I MEAL'="A" G Q2
F MEAL="B","N","E" D Q2
Q
Q2 K ^TMP($J),D G:'D3 Q3
S FHX1=^FH(116,FHCY,"DA",FHDA,0)
I $D(^FH(116.3,D1,0)) S X=^(0) F LL=2:1:4 I $P(X,"^",LL) S $P(FHX1,"^",LL)=$P(X,"^",LL)
S FHX1=$P(FHX1,"^",$F("BNE",MEAL)) I 'FHX1 Q
Q3 S:D1="" D1=NOW\1
S TIM=D1\1_$S(MEAL="B":".07",MEAL="N":".11",1:".17")
F WRD=0:0 S WRD=$O(^FH(119.6,WRD)) Q:WRD<1 S X=^(WRD,0) D D2 I D2'="" S WRDN=$P(X,"^",1) D W2
;process outpatient
;next recurring
S FHD1=D1-1
F FHK1=FHD1:0 S FHK1=$O(^FHPT("RM",FHK1)) Q:(FHK1'>0)!(FHK1>D1) D
.F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",FHK1,FHDFN)) Q:FHDFN'>0 D
..F FHKD=0:0 S FHKD=$O(^FHPT("RM",FHK1,FHDFN,FHKD)) Q:FHKD'>0 D
...S FHKDAT=^FHPT(FHDFN,"OP",FHKD,0)
...S (W1,FHW1)=$P(FHKDAT,U,3)
...S FHDIET=$P(FHKDAT,U,2),FHMEAL=$P(FHKDAT,U,4),FHSTAT=$P(FHKDAT,U,15)
...S:FHDIET="" FHDIET=$P(FHKDAT,U,7) S:FHDIET="" FHDIET=$P(FHKDAT,U,8)
...S:FHDIET="" FHDIET=$P(FHKDAT,U,9) S:FHDIET="" FHDIET=$P(FHKDAT,U,10)
...S:FHDIET="" FHDIET=$P(FHKDAT,U,11)
...I (FHMLSAV'="A"),(FHMEAL'=FHMLSAV) Q
...I FHSTAT="C" Q
...Q:'$D(^FH(119.6,FHW1,0))
...D W44
;next guest
F FHKD=D1:0 S FHKD=$O(^FHPT("GM",FHKD)) Q:(FHKD'>0)!(FHKD>(D1+1)) D
.F FHDFN=0:0 S FHDFN=$O(^FHPT("GM",FHKD,FHDFN)) Q:FHDFN'>0 D
..S FHKDAT=^FHPT(FHDFN,"GM",FHKD,0)
..S (W1,FHW1)=$P(FHKDAT,U,5)
..S FHDIET=$P(FHKDAT,U,6),FHMEAL=$P(FHKDAT,U,3)
..I $P(FHKDAT,U,9)="C" Q
..I (FHMLSAV'="A"),(FHMEAL'=FHMLSAV) Q
..Q:'$D(^FH(119.6,FHW1,0))
..D W44
;next SPECIAL
F FHKD=D1:0 S FHKD=$O(^FHPT("SM",FHKD)) Q:(FHKD'>0)!(FHKD>(D1+1)) D
.F FHDFN=0:0 S FHDFN=$O(^FHPT("SM",FHKD,FHDFN)) Q:FHDFN'>0 D
..S FHKDAT=^FHPT(FHDFN,"SM",FHKD,0)
..S (W1,FHW1)=$P(FHKDAT,U,3)
..S FHDIET=$P(FHKDAT,U,4),FHMEAL=$P(FHKDAT,U,9),FHSTAT=$P(FHKDAT,U,2)
..I (FHMLSAV'="A"),(FHMEAL'=FHMLSAV) Q
..I (FHSTAT="C")!(FHSTAT="D") Q
..Q:'$D(^FH(119.6,FHW1,0))
..D W44
;print report
G ^FHSEL3
KIL K ^TMP($J) G KILL^XUSCLEAN
W2 I $O(^FHPT("AW",WRD,0))<1 Q
F DFN=0:0 S DFN=$O(^FHPT("AW",WRD,DFN)) Q:DFN<1 S ADM=^(DFN) I ADM>0 D W3
Q
W3 S K2=0 Q:'$D(^FHPT(DFN,"A",ADM,0)) S X0=^(0)
S FHORD=$P(X0,"^",2),X1=$P(X0,"^",3) I FHORD<1 S A1=$O(^FHPT(DFN,"A",ADM,"AC",0)) Q:A1=""!(A1>NOW) D U1 Q:'FHORD G W4
I X1>1,X1'>TIM D U1 Q:'FHORD
I '$D(^FHPT(DFN,"A",ADM,"DI",FHORD,0)) D U1 Q:'FHORD
W4 S X=$G(^FHPT(DFN,"A",ADM,"DI",FHORD,0))
S TC=$P(X,"^",8) Q:TC="" S PD=$P(X,"^",13) Q:PD="" S:TC="D" TC="T" Q:'$D(S(TC)) S:D2[TC K2=1 S:K2 SP=S(TC)
S PD=$S('PD:"",$D(^FH(116.2,+PD,0)):$P(^(0),"^",2),1:"") Q:PD=""
I K2 F K=0:0 S K=$O(^FHPT(DFN,"P",K)) Q:K<1 S Z=^(K,0) D
.S FHMLZ2=$P(Z,U,2)
.I FHMLZ2'[MEAL Q
.S QTY=$P(Z,"^",3),Z=+Z
.Q:'$G(Z)
.S:'$D(^TMP($J,"P",Z,PD,SP)) ^TMP($J,"P",Z,PD,SP)=0 S ^(SP)=^(SP)+$S(QTY:QTY,1:1)
Q
;sets tmp global for outpatient data.
W44 S X=^FH(119.6,FHW1,0)
S (PD,TC)=""
S TC=$P(X,"^",5) S:TC="" TC=$P(X,U,6) Q:TC=""
I FHP,TC'=FHP Q
I $D(^FH(119.72,TC,0)) S SP=TC,TC=$P(^FH(119.72,TC,0),U,2)
S:$D(^FH(111,FHDIET,0)) PD=$P(^FH(111,FHDIET,0),U,5) Q:PD=""
S PD=$S('PD:"",$D(^FH(116.2,+PD,0)):$P(^(0),"^",2),1:"") Q:PD=""
F K=0:0 S K=$O(^FHPT(FHDFN,"P",K)) Q:K<1 S Z=^(K,0) D
.S FHMLZ2=$P(Z,U,2)
.I FHMLZ2'[MEAL Q
.S QTY=$P(Z,"^",3),Z=+Z
.Q:'$G(Z)
.S:'$D(^TMP($J,"P",Z,PD,SP)) ^TMP($J,"P",Z,PD,SP)=0 S ^(SP)=^(SP)+$S(QTY:QTY,1:1)
Q
D2 K S S D2=""
F L=5,6 S XX=$P(X,"^",L) I XX=FHP!('FHP) S:XX S($E("TC",L-4))=XX,D(XX)="",D2=D2_$E("TC",L-4)
Q
U1 S (A1,FHORD)=0 F K=0:0 S K=$O(^FHPT(DFN,"A",ADM,"AC",K)) Q:K<1!(K>TIM) S A1=K
Q:'A1 S X1=$P(^FHPT(DFN,"A",ADM,"AC",A1,0),"^",2) G U2:X1<1,U2:'$D(^FHPT(DFN,"A",ADM,"DI",X1,0)) S FHORD=X1 Q
U2 S X1="",A1=0
U3 S A1=$O(^FHPT(DFN,"A",ADM,"AC",A1)) G:A1="" U1 S X2=$P(^(A1,0),"^",2)
I X2<1 K ^FHPT(DFN,"A",ADM,"AC",A1) G U3
I '$D(^FHPT(DFN,"A",ADM,"DI",X2,0)) K ^FHPT(DFN,"A",ADM,"AC",A1) G U3
G U3
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHSEL2 5631 printed Dec 13, 2024@01:55 Page 2
FHSEL2 ; HISC/REL/NCA/FAI - Tabulate Patient Preferences ;10/29/04 7:19
+1 ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
+2 ;patch #5 - screen for cancelled guest meals.
+3 SET X="T"
SET %DT="X"
DO ^%DT
SET DT=+Y
+4 SET FHP=$ORDER(^FH(119.72,0))
IF FHP'<1
IF $ORDER(^FH(119.72,FHP))<1
SET FHP=0
GOTO D1
D0 READ !!,"Select SERVICE POINT (or ALL): ",X:DTIME
if '$TEST!("^"[X)
GOTO KIL
if X="all"
DO TR^FH
IF X="ALL"
SET FHP=0
+1 IF '$TEST
KILL DIC
SET DIC="^FH(119.72,"
SET DIC(0)="EMQ"
DO ^DIC
if Y<1
GOTO D0
SET FHP=+Y
D1 READ !!,"Tabulate By Menu Specific? N// ",D3:DTIME
if '$TEST!(D3="^")
GOTO KIL
+1 if D3=""
SET D3="N"
SET X=D3
DO TR^FH
SET D3=X
IF $PIECE("YES",D3,1)'=""
IF $PIECE("NO",D3,1)'=""
WRITE *7," Answer YES or NO"
GOTO D1
+2 SET D3=$EXTRACT(D3,1)
if D3="Y"
SET D3=D3="Y"
IF 'D3
SET (D1,FHCY,FHDA)=""
GOTO R1
F1 SET %DT("A")="Select Date: "
SET %DT="AEX"
WRITE !
DO ^%DT
if "^"[X!$DATA(DTOUT)
GOTO KIL
if Y<1
GOTO F1
SET (X1,D1)=+Y
+1 IF D1<DT
WRITE *7," [ Must NOT be before TODAY ]"
GOTO F1
+2 DO E1^FHPRC1
IF FHCY<1
WRITE *7,!!,"No MENU CYCLE Defined for that Date!"
GOTO F1
+3 IF '$DATA(^FH(116,FHCY,"DA",FHDA,0))
WRITE *7,!!,"MENU CYCLE DAY Not Defined for that Date!"
GOTO F1
R1 READ !!,"Select MEAL (B,N,E or ALL): ",MEAL:DTIME
if '$TEST!("^"[MEAL)
GOTO KIL
SET X=MEAL
DO TR^FH
SET MEAL=X
if $PIECE("ALL",MEAL,1)=""
SET MEAL="A"
+1 IF "BNEA"'[MEAL!(MEAL'?1U)
WRITE *7,!,"Select B for Breakfast, N for Noon, E for Evening or ALL for all meals"
GOTO R1
R2 READ !!,"Break Down By Production Diets? N// ",SRT:DTIME
if '$TEST!(SRT="^")
GOTO KIL
if SRT=""
SET SRT="N"
SET X=SRT
DO TR^FH
SET SRT=X
IF $PIECE("YES",SRT,1)'=""
IF $PIECE("NO",SRT,1)'=""
WRITE *7," Answer YES or NO"
GOTO R2
+1 SET SRT=$EXTRACT(SRT,1)
SET SRT=SRT="Y"
+2 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select LIST Printer: "
SET %ZIS="MQ"
DO ^%ZIS
KILL %ZIS,IOP
if POP
GOTO KIL
+3 IF $DATA(IO("Q"))
SET FHPGM="Q1^FHSEL2"
SET FHLST="D1^D3^FHP^FHCY^FHDA^MEAL^SRT"
DO EN2^FH
GOTO KIL
+4 USE IO
DO Q1
DO ^%ZISC
KILL %ZIS,IOP
GOTO KIL
Q1 ; Printing Tabulated Patient Preference
+1 SET FHMLSAV=MEAL
+2 DO NOW^%DTC
SET NOW=%
SET PG=0
+3 IF MEAL'="A"
GOTO Q2
+4 FOR MEAL="B","N","E"
DO Q2
+5 QUIT
Q2 KILL ^TMP($JOB),D
if 'D3
GOTO Q3
+1 SET FHX1=^FH(116,FHCY,"DA",FHDA,0)
+2 IF $DATA(^FH(116.3,D1,0))
SET X=^(0)
FOR LL=2:1:4
IF $PIECE(X,"^",LL)
SET $PIECE(FHX1,"^",LL)=$PIECE(X,"^",LL)
+3 SET FHX1=$PIECE(FHX1,"^",$FIND("BNE",MEAL))
IF 'FHX1
QUIT
Q3 if D1=""
SET D1=NOW\1
+1 SET TIM=D1\1_$SELECT(MEAL="B":".07",MEAL="N":".11",1:".17")
+2 FOR WRD=0:0
SET WRD=$ORDER(^FH(119.6,WRD))
if WRD<1
QUIT
SET X=^(WRD,0)
DO D2
IF D2'=""
SET WRDN=$PIECE(X,"^",1)
DO W2
+3 ;process outpatient
+4 ;next recurring
+5 SET FHD1=D1-1
+6 FOR FHK1=FHD1:0
SET FHK1=$ORDER(^FHPT("RM",FHK1))
if (FHK1'>0)!(FHK1>D1)
QUIT
Begin DoDot:1
+7 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("RM",FHK1,FHDFN))
if FHDFN'>0
QUIT
Begin DoDot:2
+8 FOR FHKD=0:0
SET FHKD=$ORDER(^FHPT("RM",FHK1,FHDFN,FHKD))
if FHKD'>0
QUIT
Begin DoDot:3
+9 SET FHKDAT=^FHPT(FHDFN,"OP",FHKD,0)
+10 SET (W1,FHW1)=$PIECE(FHKDAT,U,3)
+11 SET FHDIET=$PIECE(FHKDAT,U,2)
SET FHMEAL=$PIECE(FHKDAT,U,4)
SET FHSTAT=$PIECE(FHKDAT,U,15)
+12 if FHDIET=""
SET FHDIET=$PIECE(FHKDAT,U,7)
if FHDIET=""
SET FHDIET=$PIECE(FHKDAT,U,8)
+13 if FHDIET=""
SET FHDIET=$PIECE(FHKDAT,U,9)
if FHDIET=""
SET FHDIET=$PIECE(FHKDAT,U,10)
+14 if FHDIET=""
SET FHDIET=$PIECE(FHKDAT,U,11)
+15 IF (FHMLSAV'="A")
IF (FHMEAL'=FHMLSAV)
QUIT
+16 IF FHSTAT="C"
QUIT
+17 if '$DATA(^FH(119.6,FHW1,0))
QUIT
+18 DO W44
End DoDot:3
End DoDot:2
End DoDot:1
+19 ;next guest
+20 FOR FHKD=D1:0
SET FHKD=$ORDER(^FHPT("GM",FHKD))
if (FHKD'>0)!(FHKD>(D1+1))
QUIT
Begin DoDot:1
+21 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("GM",FHKD,FHDFN))
if FHDFN'>0
QUIT
Begin DoDot:2
+22 SET FHKDAT=^FHPT(FHDFN,"GM",FHKD,0)
+23 SET (W1,FHW1)=$PIECE(FHKDAT,U,5)
+24 SET FHDIET=$PIECE(FHKDAT,U,6)
SET FHMEAL=$PIECE(FHKDAT,U,3)
+25 IF $PIECE(FHKDAT,U,9)="C"
QUIT
+26 IF (FHMLSAV'="A")
IF (FHMEAL'=FHMLSAV)
QUIT
+27 if '$DATA(^FH(119.6,FHW1,0))
QUIT
+28 DO W44
End DoDot:2
End DoDot:1
+29 ;next SPECIAL
+30 FOR FHKD=D1:0
SET FHKD=$ORDER(^FHPT("SM",FHKD))
if (FHKD'>0)!(FHKD>(D1+1))
QUIT
Begin DoDot:1
+31 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("SM",FHKD,FHDFN))
if FHDFN'>0
QUIT
Begin DoDot:2
+32 SET FHKDAT=^FHPT(FHDFN,"SM",FHKD,0)
+33 SET (W1,FHW1)=$PIECE(FHKDAT,U,3)
+34 SET FHDIET=$PIECE(FHKDAT,U,4)
SET FHMEAL=$PIECE(FHKDAT,U,9)
SET FHSTAT=$PIECE(FHKDAT,U,2)
+35 IF (FHMLSAV'="A")
IF (FHMEAL'=FHMLSAV)
QUIT
+36 IF (FHSTAT="C")!(FHSTAT="D")
QUIT
+37 if '$DATA(^FH(119.6,FHW1,0))
QUIT
+38 DO W44
End DoDot:2
End DoDot:1
+39 ;print report
+40 GOTO ^FHSEL3
KIL KILL ^TMP($JOB)
GOTO KILL^XUSCLEAN
W2 IF $ORDER(^FHPT("AW",WRD,0))<1
QUIT
+1 FOR DFN=0:0
SET DFN=$ORDER(^FHPT("AW",WRD,DFN))
if DFN<1
QUIT
SET ADM=^(DFN)
IF ADM>0
DO W3
+2 QUIT
W3 SET K2=0
if '$DATA(^FHPT(DFN,"A",ADM,0))
QUIT
SET X0=^(0)
+1 SET FHORD=$PIECE(X0,"^",2)
SET X1=$PIECE(X0,"^",3)
IF FHORD<1
SET A1=$ORDER(^FHPT(DFN,"A",ADM,"AC",0))
if A1=""!(A1>NOW)
QUIT
DO U1
if 'FHORD
QUIT
GOTO W4
+2 IF X1>1
IF X1'>TIM
DO U1
if 'FHORD
QUIT
+3 IF '$DATA(^FHPT(DFN,"A",ADM,"DI",FHORD,0))
DO U1
if 'FHORD
QUIT
W4 SET X=$GET(^FHPT(DFN,"A",ADM,"DI",FHORD,0))
+1 SET TC=$PIECE(X,"^",8)
if TC=""
QUIT
SET PD=$PIECE(X,"^",13)
if PD=""
QUIT
if TC="D"
SET TC="T"
if '$DATA(S(TC))
QUIT
if D2[TC
SET K2=1
if K2
SET SP=S(TC)
+2 SET PD=$SELECT('PD:"",$DATA(^FH(116.2,+PD,0)):$PIECE(^(0),"^",2),1:"")
if PD=""
QUIT
+3 IF K2
FOR K=0:0
SET K=$ORDER(^FHPT(DFN,"P",K))
if K<1
QUIT
SET Z=^(K,0)
Begin DoDot:1
+4 SET FHMLZ2=$PIECE(Z,U,2)
+5 IF FHMLZ2'[MEAL
QUIT
+6 SET QTY=$PIECE(Z,"^",3)
SET Z=+Z
+7 if '$GET(Z)
QUIT
+8 if '$DATA(^TMP($JOB,"P",Z,PD,SP))
SET ^TMP($JOB,"P",Z,PD,SP)=0
SET ^(SP)=^(SP)+$SELECT(QTY:QTY,1:1)
End DoDot:1
+9 QUIT
+10 ;sets tmp global for outpatient data.
W44 SET X=^FH(119.6,FHW1,0)
+1 SET (PD,TC)=""
+2 SET TC=$PIECE(X,"^",5)
if TC=""
SET TC=$PIECE(X,U,6)
if TC=""
QUIT
+3 IF FHP
IF TC'=FHP
QUIT
+4 IF $DATA(^FH(119.72,TC,0))
SET SP=TC
SET TC=$PIECE(^FH(119.72,TC,0),U,2)
+5 if $DATA(^FH(111,FHDIET,0))
SET PD=$PIECE(^FH(111,FHDIET,0),U,5)
if PD=""
QUIT
+6 SET PD=$SELECT('PD:"",$DATA(^FH(116.2,+PD,0)):$PIECE(^(0),"^",2),1:"")
if PD=""
QUIT
+7 FOR K=0:0
SET K=$ORDER(^FHPT(FHDFN,"P",K))
if K<1
QUIT
SET Z=^(K,0)
Begin DoDot:1
+8 SET FHMLZ2=$PIECE(Z,U,2)
+9 IF FHMLZ2'[MEAL
QUIT
+10 SET QTY=$PIECE(Z,"^",3)
SET Z=+Z
+11 if '$GET(Z)
QUIT
+12 if '$DATA(^TMP($JOB,"P",Z,PD,SP))
SET ^TMP($JOB,"P",Z,PD,SP)=0
SET ^(SP)=^(SP)+$SELECT(QTY:QTY,1:1)
End DoDot:1
+13 QUIT
D2 KILL S
SET D2=""
+1 FOR L=5,6
SET XX=$PIECE(X,"^",L)
IF XX=FHP!('FHP)
if XX
SET S($EXTRACT("TC",L-4))=XX
SET D(XX)=""
SET D2=D2_$EXTRACT("TC",L-4)
+2 QUIT
U1 SET (A1,FHORD)=0
FOR K=0:0
SET K=$ORDER(^FHPT(DFN,"A",ADM,"AC",K))
if K<1!(K>TIM)
QUIT
SET A1=K
+1 if 'A1
QUIT
SET X1=$PIECE(^FHPT(DFN,"A",ADM,"AC",A1,0),"^",2)
if X1<1
GOTO U2
if '$DATA(^FHPT(DFN,"A",ADM,"DI",X1,0))
GOTO U2
SET FHORD=X1
QUIT
U2 SET X1=""
SET A1=0
U3 SET A1=$ORDER(^FHPT(DFN,"A",ADM,"AC",A1))
if A1=""
GOTO U1
SET X2=$PIECE(^(A1,0),"^",2)
+1 IF X2<1
KILL ^FHPT(DFN,"A",ADM,"AC",A1)
GOTO U3
+2 IF '$DATA(^FHPT(DFN,"A",ADM,"DI",X2,0))
KILL ^FHPT(DFN,"A",ADM,"AC",A1)
GOTO U3
+3 GOTO U3
