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 ---[H[J[2J[HFHORC4 1302 printed Nov 22, 2024@17:03:30 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
