- 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 Mar 13, 2025@20:57:58 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
