FHORC5 ; HISC/REL - Consult Management ;4/12/06 13:26
;;5.5;DIETETICS;**4,12**;Jan 28, 2005;Build 3
; 10/17/2007 BP/KAM FH*5.5*12 Rem Call 210883 Remove Old Clinician Field (#1)
EN9 ; Enter/Edit Ward Assignments
K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQM"
W ! D ^DIC G KIL:U[X!$D(DTOUT),EN9:Y<1 S OLD=$S($P(Y,"^",3):"",1:$P(^FH(119.6,+Y,0),"^",2))
; 10/17/2007 BP/KAM *12 Rem Call 210883 Removed field #1 in next line
S DA=+Y,DR="112" D ^DIE S NEW=$P(^FH(119.6,DA,0),"^",2) I 'NEW!('OLD) K OLD,NEW,X,Y G EN9
D:OLD'=NEW EN2^FHORC4 K OLD,NEW,X,Y G EN9
EN10 ; List Ward Assignments
W ! S L=0,DIC="^FH(119.6,",FLDS="[FHORWRD]",BY=".01"
S (FR,TO)="",DHD="NUTRITION LOCATION ASSIGNMENTS" D EN1^DIP,RSET Q
EN11 ; Enter/Edit Consult Types
S (DIC,DIE)="^FH(119.5,",DIC(0)="AEQLM",DIC("DR")=".01",DLAYGO=119.5
W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN11:Y<1
S DA=+Y,DR=".01:2;S FHA1=X;3;S Y=$S(FHA1=""Y"":4,1:5);4;5:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.5 D ^DIE K DA,DIE,DIDEL,DR,FHA1 G EN11
EN12 ; List Consult Types
W !!,"The list requires a 132 column printer.",!
W ! S L=0,DIC="^FH(119.5,",FLDS="[FHORCON]",BY=".01"
S (FR,TO)="",DHD="CONSULTATION TYPES" D EN1^DIP,RSET Q
RSET K %ZIS S IOP="" D ^%ZIS
KIL K %,%ZIS,IOP,BY,DA,DHD,DIC,DIE,DR,FLDS,FR,L,NEW,OLD,TO,X,Y Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORC5 1306 printed Nov 22, 2024@17:03:31 Page 2
FHORC5 ; HISC/REL - Consult Management ;4/12/06 13:26
+1 ;;5.5;DIETETICS;**4,12**;Jan 28, 2005;Build 3
+2 ; 10/17/2007 BP/KAM FH*5.5*12 Rem Call 210883 Remove Old Clinician Field (#1)
EN9 ; Enter/Edit Ward Assignments
+1 KILL DIC
SET (DIC,DIE)="^FH(119.6,"
SET DIC(0)="AEQM"
+2 WRITE !
DO ^DIC
if U[X!$DATA(DTOUT)
GOTO KIL
if Y<1
GOTO EN9
SET OLD=$SELECT($PIECE(Y,"^",3):"",1:$PIECE(^FH(119.6,+Y,0),"^",2))
+3 ; 10/17/2007 BP/KAM *12 Rem Call 210883 Removed field #1 in next line
+4 SET DA=+Y
SET DR="112"
DO ^DIE
SET NEW=$PIECE(^FH(119.6,DA,0),"^",2)
IF 'NEW!('OLD)
KILL OLD,NEW,X,Y
GOTO EN9
+5 if OLD'=NEW
DO EN2^FHORC4
KILL OLD,NEW,X,Y
GOTO EN9
EN10 ; List Ward Assignments
+1 WRITE !
SET L=0
SET DIC="^FH(119.6,"
SET FLDS="[FHORWRD]"
SET BY=".01"
+2 SET (FR,TO)=""
SET DHD="NUTRITION LOCATION ASSIGNMENTS"
DO EN1^DIP
DO RSET
QUIT
EN11 ; Enter/Edit Consult Types
+1 SET (DIC,DIE)="^FH(119.5,"
SET DIC(0)="AEQLM"
SET DIC("DR")=".01"
SET DLAYGO=119.5
+2 WRITE !
DO ^DIC
KILL DIC,DLAYGO
if U[X!$DATA(DTOUT)
GOTO KIL
if Y<1
GOTO EN11
+3 SET DA=+Y
SET DR=".01:2;S FHA1=X;3;S Y=$S(FHA1=""Y"":4,1:5);4;5:99"
if $DATA(^XUSEC("FHMGR",DUZ))
SET DIDEL=119.5
DO ^DIE
KILL DA,DIE,DIDEL,DR,FHA1
GOTO EN11
EN12 ; List Consult Types
+1 WRITE !!,"The list requires a 132 column printer.",!
+2 WRITE !
SET L=0
SET DIC="^FH(119.5,"
SET FLDS="[FHORCON]"
SET BY=".01"
+3 SET (FR,TO)=""
SET DHD="CONSULTATION TYPES"
DO EN1^DIP
DO RSET
QUIT
RSET KILL %ZIS
SET IOP=""
DO ^%ZIS
KIL KILL %,%ZIS,IOP,BY,DA,DHD,DIC,DIE,DR,FLDS,FR,L,NEW,OLD,TO,X,Y
QUIT
