FHORC5.m

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 ---FHORC5   1306     printed  Mar 13, 2025@20:57:59                                                                                                                                                                                                      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