FHORC4.m

FHORC4 ; HISC/REL - Re-Assign Active Consults ;5/18/93  15:42 

 ;;5.5;DIETETICS;;Jan 28, 2005

 W !!,"This will re-assign all ACTIVE consults from one Clinician to another",!!

E1 K DIC S DIC="^VA(200,",DIC(0)="AEQM",DIC("A")="Select CURRENT Clinician: " W ! D ^DIC G KIL:U[X!$D(DTOUT),E1:Y<1 S OLD=+Y

E2 S DIC("A")="Select NEW Clinician: " W ! D ^DIC G KIL:U[X!$D(DTOUT),E2:Y<1 S NEW=+Y,N1=0,FHDFN=0

 S WRD="" I OLD=NEW W !!,"No change in Clinician!" G KIL

E3 S FHDFN=$O(^FHPT("ADRU",OLD,FHDFN)) G:FHDFN<1 E6 S ADM=0

E4 S ADM=$O(^FHPT("ADRU",OLD,FHDFN,ADM)) G:ADM<1 E3 S REQ=0

E5 S REQ=$O(^FHPT("ADRU",OLD,FHDFN,ADM,REQ)) G:REQ<1 E4

 I WRD,'$D(^FHPT("AW",WRD,FHDFN)) G E5

 S N1=N1+1 K ^FHPT("ADRU",OLD,FHDFN,ADM,REQ)

 S ^FHPT("ADRU",NEW,FHDFN,ADM,REQ)="",$P(^FHPT(FHDFN,"A",ADM,"DR",REQ,0),"^",5)=NEW G E5

E6 W !!,N1," Consults were transferred"

KIL K ADM,FHDFN,DFN,DIC,N1,NEW,OLD,REQ,WRD,X,Y Q

EN2 ; Entry point from Edit Ward Assignment

 W !!,"Since you have changed a ward assignment, do you wish to"

 W !,"re-assign all active consults from ",$P(^VA(200,OLD,0),"^",1)

 W !,"to ",$P(^VA(200,NEW,0),"^",1)," ? N// "

N2 R X:DTIME Q:'$T!(X["^")  S:X="" X="N" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G EN2

 Q:X'?1"Y".E  S (N1,FHDFN,DFN)=0,WRD=+DA D E3 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FHORC4   1302     printed  Apr 09, 2024@20:58:07                                                                                                                                                                                                      Page 2

FHORC4    ; HISC/REL - Re-Assign Active Consults ;5/18/93  15:42 

 +1       ;;5.5;DIETETICS;;Jan 28, 2005

 +2        WRITE !!,"This will re-assign all ACTIVE consults from one Clinician to another",!!

E1         KILL DIC

           SET DIC="^VA(200,"

           SET DIC(0)="AEQM"

           SET DIC("A")="Select CURRENT Clinician: "

           WRITE !

           DO ^DIC

           if U[X!$DATA(DTOUT)

               GOTO KIL

           if Y<1

               GOTO E1

           SET OLD=+Y

E2         SET DIC("A")="Select NEW Clinician: "

           WRITE !

           DO ^DIC

           if U[X!$DATA(DTOUT)

               GOTO KIL

           if Y<1

               GOTO E2

           SET NEW=+Y

           SET N1=0

           SET FHDFN=0

 +1        SET WRD=""

           IF OLD=NEW

               WRITE !!,"No change in Clinician!"

               GOTO KIL

E3         SET FHDFN=$ORDER(^FHPT("ADRU",OLD,FHDFN))

           if FHDFN<1

               GOTO E6

           SET ADM=0

E4         SET ADM=$ORDER(^FHPT("ADRU",OLD,FHDFN,ADM))

           if ADM<1

               GOTO E3

           SET REQ=0

E5         SET REQ=$ORDER(^FHPT("ADRU",OLD,FHDFN,ADM,REQ))

           if REQ<1

               GOTO E4

 +1        IF WRD

               IF '$DATA(^FHPT("AW",WRD,FHDFN))

                   GOTO E5

 +2        SET N1=N1+1

           KILL ^FHPT("ADRU",OLD,FHDFN,ADM,REQ)

 +3        SET ^FHPT("ADRU",NEW,FHDFN,ADM,REQ)=""

           SET $PIECE(^FHPT(FHDFN,"A",ADM,"DR",REQ,0),"^",5)=NEW

           GOTO E5

E6         WRITE !!,N1," Consults were transferred"

KIL        KILL ADM,FHDFN,DFN,DIC,N1,NEW,OLD,REQ,WRD,X,Y

           QUIT 

EN2       ; Entry point from Edit Ward Assignment

 +1        WRITE !!,"Since you have changed a ward assignment, do you wish to"

 +2        WRITE !,"re-assign all active consults from ",$PIECE(^VA(200,OLD,0),"^",1)

 +3        WRITE !,"to ",$PIECE(^VA(200,NEW,0),"^",1)," ? N// "

N2         READ X:DTIME

           if '$TEST!(X["^")

               QUIT 

           if X=""

               SET X="N"

           DO TR^FH

           IF $PIECE("YES",X,1)'=""

               IF $PIECE("NO",X,1)'=""

                   WRITE *7," Answer YES or NO"

                   GOTO EN2

 +1        if X'?1"Y".E

               QUIT 

           SET (N1,FHDFN,DFN)=0

           SET WRD=+DA

           DO E3

           QUIT