- FHMASE ; HISC/AAC - Multidivisional Dietetic Encounters ;10/14/03 13:17
- ;;5.5;DIETETICS;;Jan 28, 2005
- EN1 ; Enter/Edit Encounter Types
- S (DIC,DIE)="^FH(115.6,",DIC(0)="AEQLM",DIC("DR")=".01",DLAYGO=115.6 W ! D ^DIC K DIC,DLAYGO G KIL:"^"[X!$D(DTOUT),EN1:Y<1
- S DA=+Y,DR=$S(DA=1:2,DA=2:"2;3",1:".01;1:4;10;5:6;I X'=""Y"" S Y=99;7;8;99") S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=115.6 D ^DIE,KIL G EN1
- ;
- EN2 ; List Encounter Types
- W ! S L=0,DIC="^FH(115.6,",FLDS=".01,2,3,4,10,5,6,7,8,99",BY=".01"
- S (FR,TO)="",DHD="ENCOUNTER TYPES" D EN1^DIP,RSET Q
- ;
- EN3 ; Enter Dietetic Encounter
- W ! K DIR S FHN=0,DIR(0)="YAO",DIR("A")="Enter a NEW Encounter (Y/N)? " D ^DIR G:$D(DIROUT)!($D(DIRUT)) KIL K DIR,DIROUT,DIRUT
- I 'Y S FHN=1 G EN4
- ;
- EN30 ; Enter/Edit a Encounter
- D EN31 G:Y<1 KIL G EN3
- ;
- EN31 ; Enter a Encounter
- S FHN=0 K %DT S %DT="AETPX",%DT("A")="DATE/TIME OF ENCOUNTER: ",%DT("B")="TODAY",%DT(0)="-NOW" W ! D ^%DT K %DT S:$D(DTOUT) Y=0 Q:Y<1 S DTE=Y
- K DIC,DD,DO S DIC="^FHEN(",DIC(0)="L",DIC("DR")="1////^S X=DTE",DLAYGO=115.7
- A L +^FHEN(0) S DA=$P(^FHEN(0),"^",3)+1 I $D(^FHEN(DA)) S $P(^FHEN(0),"^",3)=DA L -^FHEN(0) G A
- S (X,DINUM)=DA D FILE^DICN L -^FHEN(0) S ASE=+Y,FHX4="" K DIC,DLAYGO,DINUM
- D EDIT Q
- ;
- EN4 ; Process Edit Encounter
- ;
- W ! K ^TMP($J,"ECTR"),%DT S %DT="AEPX",%DT("A")="Enter Date of Encounter you want to edit: " D ^%DT K %DT S:$D(DTOUT) Y=0 G:Y<1 KIL S X1=Y,(TIM,X1)=X1-.0001,(EDT,X2)=Y\1+.3,CTR=0
- A0 W !! K DIR S DIR(0)="SO^C:CLINICIAN;P:PATIENT",DIR("A")="CHOOSE CLINICIAN or PATIENT" D ^DIR K DIR G:$D(DIROUT)!($D(DIRUT)) KIL I Y?1"P" D PAT G:'DFN KIL D PR G:Y<1 KIL D ASK G KIL:Y<1,EN4
- A1 K DIC S DIC="^VA(200,",DIC(0)="AEQM",DIC("A")="Select CLINICIAN: " W ! D ^DIC K DIC G KIL:"^"[X!$D(DTOUT),A1:Y<1 S NAM=+Y D CLIN,PR G:Y<1 KIL D ASK G KIL:Y<1,EN4
- PR W ! S K1="" F CTR=0:0 S CTR=$O(^TMP($J,"ECTR",CTR)) Q:CTR<1 S X=$G(^(CTR,0)),K1=CTR W !,CTR," " S Y=$P(X,"^",2) X ^DD("DD") W Y," ",$P(X,"^",3) K Y
- I 'K1 W !?5,"No encounter on file on this date" S Y=0 Q
- W !!,"Select number you want: " R X:DTIME I '$T!("^"[X) S Y=0 Q
- I X'?1.N!(X<1)!(X>K1) W *7,!!,"Select only a number no greater than ",K1," or press ""^"" or a return to exit." G PR
- S ASE=$P($G(^TMP($J,"ECTR",+X,0)),"^",1),FHX4=$G(^FHEN(ASE,0))
- S FHCLK=$P($G(^TMP($J,"ECTR",+X,0)),"^",4) W !
- ;
- EDIT N FHX1 S DA=ASE K DIC,DIE S DIE="^FHEN(",DR="[FHMASE]" D ^DIE K DIC,DIE,DR
- S DA=ASE,X=^FHEN(DA,0)
- I '$P(X,"^",3)!('$P(X,"^",4)) S DIK="^FHEN(" D ^DIK W *7,!,"<encounter deleted>" K DIK,DA
- S Y=1 Q
- ;
- PAT ; Get Patient
- S ALL=1 D ^FHDPA Q:'DFN
- I $P($G(^DPT(DFN,.35)),"^",1) W *7,!!?5,"Patient has expired." G PAT
- I '$D(^FHEN("AP",DFN)) W !!,"No Encounter on file for this patient." G PAT
- F DTE=TIM:0 S DTE=$O(^FHEN("AP",DFN,DTE)) Q:DTE<1!(DTE>EDT) F ASE=0:0 S ASE=$O(^FHEN("AP",DFN,DTE,ASE)) Q:ASE<1 S Y=$P($G(^FHEN(ASE,0)),"^",4) I Y>2 D
- .S CTR=CTR+1,^TMP($J,"ECTR",CTR,0)=ASE_"^"_DTE_"^"_$P($G(^FH(115.6,+Y,0)),"^",1)_"^"_$P($G(^FHEN(ASE,0)),"^",13) Q
- Q
- CLIN ; Get Clinician
- S X1=$O(^FHEN("AT",X1)) Q:X1<1!(X1>X2)
- S ASE=0
- ;
- R1 S ASE=$O(^FHEN("AT",X1,ASE)) G:ASE="" CLIN
- S Y=$G(^FHEN(ASE,0)),E1=$P(Y,"^",3) I $P(Y,"^",4)>2,E1,E1=NAM S CTR=CTR+1,^TMP($J,"ECTR",CTR,0)=ASE_"^"_$P(Y,"^",2)_"^"_$P($G(^FH(115.6,+$P(Y,"^",4),0)),"^",1)_"^"_$P(Y,"^",13),DTE=$P(Y,"^",2)
- G R1
- ;
- ASK R !!,"Is this correct? Y// ",YN:DTIME I '$T!(YN["^") S Y=0 Q
- S:YN="" YN="Y" S X=YN D TR^FH S YN=X
- I $P("YES",YN,1)'="",$P("NO",YN,1)'="" W *7," Answer YES or NO" G ASK
- Q:YN?1"Y".E
- I FHCLK'=DUZ W !!,"You can ONLY DELETE an encounter that is entered by you.",! G EDIT
- ;
- E5 R !,"Want to delete encounter? N// ",YN:DTIME I '$T!(YN["^") S Y=0 Q
- S:YN="" YN="N" S X=YN D TR^FH S YN=X
- I $P("YES",YN,1)'="",$P("NO",YN,1)'="" W *7," Answer YES or NO" G E5
- Q:YN?1"N".E
- S DIK="^FHEN(",DA=ASE D ^DIK W *7,!,"<encounter deleted>" K DA,DIK S Y=1 Q
- ;
- CNT S FHX3=FHX3+$P($G(^FHEN(ASE,"P",0)),"^",4)
- S ST="" F LP=0:0 S LP=$O(^FHEN(ASE,"P",LP)) Q:LP<1 S ST=$G(^(LP,0)) I $P(ST,"^",3)'<1 S FHX3=FHX3+$P(ST,"^",3)
- Q
- ;
- RSET K %ZIS S IOP="" D ^%ZIS
- ;
- KIL K ^TMP($J,"ECTR") G KILL^XUSCLEAN
- ;
- FHMASE ; HISC/AAC - Multidivisional Dietetic Encounters ;10/14/03 13:17
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- EN1 ; Enter/Edit Encounter Types
- +1 SET (DIC,DIE)="^FH(115.6,"
- SET DIC(0)="AEQLM"
- SET DIC("DR")=".01"
- SET DLAYGO=115.6
- WRITE !
- DO ^DIC
- KILL DIC,DLAYGO
- IF "^"[X!$DATA(DTOUT)
- GOTO KIL
- IF Y<1
- GOTO EN1
- +2 SET DA=+Y
- SET DR=$SELECT(DA=1:2,DA=2:"2;3",1:".01;1:4;10;5:6;I X'=""Y"" S Y=99;7;8;99")
- IF $DATA(^XUSEC("FHMGR",DUZ))
- SET DIDEL=115.6
- DO ^DIE
- DO KIL
- GOTO EN1
- +3 ;
- EN2 ; List Encounter Types
- +1 WRITE !
- SET L=0
- SET DIC="^FH(115.6,"
- SET FLDS=".01,2,3,4,10,5,6,7,8,99"
- SET BY=".01"
- +2 SET (FR,TO)=""
- SET DHD="ENCOUNTER TYPES"
- DO EN1^DIP
- DO RSET
- QUIT
- +3 ;
- EN3 ; Enter Dietetic Encounter
- +1 WRITE !
- KILL DIR
- SET FHN=0
- SET DIR(0)="YAO"
- SET DIR("A")="Enter a NEW Encounter (Y/N)? "
- DO ^DIR
- IF $DATA(DIROUT)!($DATA(DIRUT))
- GOTO KIL
- KILL DIR,DIROUT,DIRUT
- +2 IF 'Y
- SET FHN=1
- GOTO EN4
- +3 ;
- EN30 ; Enter/Edit a Encounter
- +1 DO EN31
- IF Y<1
- GOTO KIL
- GOTO EN3
- +2 ;
- EN31 ; Enter a Encounter
- +1 SET FHN=0
- KILL %DT
- SET %DT="AETPX"
- SET %DT("A")="DATE/TIME OF ENCOUNTER: "
- SET %DT("B")="TODAY"
- SET %DT(0)="-NOW"
- WRITE !
- DO ^%DT
- KILL %DT
- IF $DATA(DTOUT)
- SET Y=0
- IF Y<1
- QUIT
- SET DTE=Y
- +2 KILL DIC,DD,DO
- SET DIC="^FHEN("
- SET DIC(0)="L"
- SET DIC("DR")="1////^S X=DTE"
- SET DLAYGO=115.7
- A LOCK +^FHEN(0)
- SET DA=$PIECE(^FHEN(0),"^",3)+1
- IF $DATA(^FHEN(DA))
- SET $PIECE(^FHEN(0),"^",3)=DA
- LOCK -^FHEN(0)
- GOTO A
- +1 SET (X,DINUM)=DA
- DO FILE^DICN
- LOCK -^FHEN(0)
- SET ASE=+Y
- SET FHX4=""
- KILL DIC,DLAYGO,DINUM
- +2 DO EDIT
- QUIT
- +3 ;
- EN4 ; Process Edit Encounter
- +1 ;
- +2 WRITE !
- KILL ^TMP($JOB,"ECTR"),%DT
- SET %DT="AEPX"
- SET %DT("A")="Enter Date of Encounter you want to edit: "
- DO ^%DT
- KILL %DT
- IF $DATA(DTOUT)
- SET Y=0
- IF Y<1
- GOTO KIL
- SET X1=Y
- SET (TIM,X1)=X1-.0001
- SET (EDT,X2)=Y\1+.3
- SET CTR=0
- A0 WRITE !!
- KILL DIR
- SET DIR(0)="SO^C:CLINICIAN;P:PATIENT"
- SET DIR("A")="CHOOSE CLINICIAN or PATIENT"
- DO ^DIR
- KILL DIR
- IF $DATA(DIROUT)!($DATA(DIRUT))
- GOTO KIL
- IF Y?1"P"
- DO PAT
- IF 'DFN
- GOTO KIL
- DO PR
- IF Y<1
- GOTO KIL
- DO ASK
- IF Y<1
- GOTO KIL
- GOTO EN4
- A1 KILL DIC
- SET DIC="^VA(200,"
- SET DIC(0)="AEQM"
- SET DIC("A")="Select CLINICIAN: "
- WRITE !
- DO ^DIC
- KILL DIC
- IF "^"[X!$DATA(DTOUT)
- GOTO KIL
- IF Y<1
- GOTO A1
- SET NAM=+Y
- DO CLIN
- DO PR
- IF Y<1
- GOTO KIL
- DO ASK
- IF Y<1
- GOTO KIL
- GOTO EN4
- PR WRITE !
- SET K1=""
- FOR CTR=0:0
- SET CTR=$ORDER(^TMP($JOB,"ECTR",CTR))
- IF CTR<1
- QUIT
- SET X=$GET(^(CTR,0))
- SET K1=CTR
- WRITE !,CTR," "
- SET Y=$PIECE(X,"^",2)
- XECUTE ^DD("DD")
- WRITE Y," ",$PIECE(X,"^",3)
- KILL Y
- +1 IF 'K1
- WRITE !?5,"No encounter on file on this date"
- SET Y=0
- QUIT
- +2 WRITE !!,"Select number you want: "
- READ X:DTIME
- IF '$TEST!("^"[X)
- SET Y=0
- QUIT
- +3 IF X'?1.N!(X<1)!(X>K1)
- WRITE *7,!!,"Select only a number no greater than ",K1," or press ""^"" or a return to exit."
- GOTO PR
- +4 SET ASE=$PIECE($GET(^TMP($JOB,"ECTR",+X,0)),"^",1)
- SET FHX4=$GET(^FHEN(ASE,0))
- +5 SET FHCLK=$PIECE($GET(^TMP($JOB,"ECTR",+X,0)),"^",4)
- WRITE !
- +6 ;
- EDIT NEW FHX1
- SET DA=ASE
- KILL DIC,DIE
- SET DIE="^FHEN("
- SET DR="[FHMASE]"
- DO ^DIE
- KILL DIC,DIE,DR
- +1 SET DA=ASE
- SET X=^FHEN(DA,0)
- +2 IF '$PIECE(X,"^",3)!('$PIECE(X,"^",4))
- SET DIK="^FHEN("
- DO ^DIK
- WRITE *7,!,"<encounter deleted>"
- KILL DIK,DA
- +3 SET Y=1
- QUIT
- +4 ;
- PAT ; Get Patient
- +1 SET ALL=1
- DO ^FHDPA
- IF 'DFN
- QUIT
- +2 IF $PIECE($GET(^DPT(DFN,.35)),"^",1)
- WRITE *7,!!?5,"Patient has expired."
- GOTO PAT
- +3 IF '$DATA(^FHEN("AP",DFN))
- WRITE !!,"No Encounter on file for this patient."
- GOTO PAT
- +4 FOR DTE=TIM:0
- SET DTE=$ORDER(^FHEN("AP",DFN,DTE))
- IF DTE<1!(DTE>EDT)
- QUIT
- FOR ASE=0:0
- SET ASE=$ORDER(^FHEN("AP",DFN,DTE,ASE))
- IF ASE<1
- QUIT
- SET Y=$PIECE($GET(^FHEN(ASE,0)),"^",4)
- IF Y>2
- Begin DoDot:1
- +5 SET CTR=CTR+1
- SET ^TMP($JOB,"ECTR",CTR,0)=ASE_"^"_DTE_"^"_$PIECE($GET(^FH(115.6,+Y,0)),"^",1)_"^"_$PIECE($GET(^FHEN(ASE,0)),"^",13)
- QUIT
- End DoDot:1
- +6 QUIT
- CLIN ; Get Clinician
- +1 SET X1=$ORDER(^FHEN("AT",X1))
- IF X1<1!(X1>X2)
- QUIT
- +2 SET ASE=0
- +3 ;
- R1 SET ASE=$ORDER(^FHEN("AT",X1,ASE))
- IF ASE=""
- GOTO CLIN
- +1 SET Y=$GET(^FHEN(ASE,0))
- SET E1=$PIECE(Y,"^",3)
- IF $PIECE(Y,"^",4)>2
- IF E1
- IF E1=NAM
- SET CTR=CTR+1
- SET ^TMP($JOB,"ECTR",CTR,0)=ASE_"^"_$PIECE(Y,"^",2)_"^"_$PIECE($GET(^FH(115.6,+$PIECE(Y,"^",4),0)),"^",1)_"^"_$PIECE(Y,"^",13)
- SET DTE=$PIECE(Y,"^",2)
- +2 GOTO R1
- +3 ;
- ASK READ !!,"Is this correct? Y// ",YN:DTIME
- IF '$TEST!(YN["^")
- SET Y=0
- QUIT
- +1 IF YN=""
- SET YN="Y"
- SET X=YN
- DO TR^FH
- SET YN=X
- +2 IF $PIECE("YES",YN,1)'=""
- IF $PIECE("NO",YN,1)'=""
- WRITE *7," Answer YES or NO"
- GOTO ASK
- +3 IF YN?1"Y".E
- QUIT
- +4 IF FHCLK'=DUZ
- WRITE !!,"You can ONLY DELETE an encounter that is entered by you.",!
- GOTO EDIT
- +5 ;
- E5 READ !,"Want to delete encounter? N// ",YN:DTIME
- IF '$TEST!(YN["^")
- SET Y=0
- QUIT
- +1 IF YN=""
- SET YN="N"
- SET X=YN
- DO TR^FH
- SET YN=X
- +2 IF $PIECE("YES",YN,1)'=""
- IF $PIECE("NO",YN,1)'=""
- WRITE *7," Answer YES or NO"
- GOTO E5
- +3 IF YN?1"N".E
- QUIT
- +4 SET DIK="^FHEN("
- SET DA=ASE
- DO ^DIK
- WRITE *7,!,"<encounter deleted>"
- KILL DA,DIK
- SET Y=1
- QUIT
- +5 ;
- CNT SET FHX3=FHX3+$PIECE($GET(^FHEN(ASE,"P",0)),"^",4)
- +1 SET ST=""
- FOR LP=0:0
- SET LP=$ORDER(^FHEN(ASE,"P",LP))
- IF LP<1
- QUIT
- SET ST=$GET(^(LP,0))
- IF $PIECE(ST,"^",3)'<1
- SET FHX3=FHX3+$PIECE(ST,"^",3)
- +2 QUIT
- +3 ;
- RSET KILL %ZIS
- SET IOP=""
- DO ^%ZIS
- +1 ;
- KIL KILL ^TMP($JOB,"ECTR")
- GOTO KILL^XUSCLEAN
- +1 ;
