FHXUTL ; HISC/NCA - OE/RR Post-Init Clean Up of 2.5 Protocols ;11/10/97 12:52
;;5.5;DIETETICS;;Jan 28, 2005
I +$$VERSION^XPDUTL("OR")'=3 W !,?10,"You do not have version 3 of Order Entry.",!,?10,"The Protocols will not be removed." Q
Q:'$D(^ORD(101,0))
S FHX="FHW"
S FHX=$O(^ORD(101,"B",FHX)) Q:FHX=""
S FHX1=$O(^ORD(101,"B",FHX,0)) Q:'FHX1
K ^TMP($J,"FHPRO")
; Clean up protocols
W !!,"Clean up 2.5 Dietetics Protocols..."
S FHX="FHW" F S FHX=$O(^ORD(101,"B",FHX)) Q:$E(FHX,1,3)'="FHW" F FHX1=0:0 S FHX1=$O(^ORD(101,"B",FHX,FHX1)) Q:FHX1<1 S:FHX'="FHWMAS" ^TMP($J,"FHPRO",FHX1)=FHX
F FHX="OR" F S FHX=$O(^ORD(101,"B",FHX)) Q:$E(FHX,1,2)'="OR" F FHX1=0:0 S FHX1=$O(^ORD(101,"B",FHX,FHX1)) Q:FHX1<1 I $E($P($G(^ORD(101,FHX1,0)),"^",1),1,2)="OR" D REMOV
F FHX="FHW" F S FHX=$O(^ORD(101,"B",FHX)) Q:$E(FHX,1,3)'="FHW" F FHX1=0:0 S FHX1=$O(^ORD(101,"B",FHX,FHX1)) Q:FHX1<1 I $E($P($G(^ORD(101,FHX1,0)),"^",1),1,3)="FHW" D REMOV
F FHX=0:0 S FHX=$O(^TMP($J,"FHPRO",FHX)) Q:FHX<1 S DA=FHX I DA S DIK="^ORD(101," D ^DIK W !,"Protocol ",$G(^TMP($J,"FHPRO",FHX))," Removed"
W !,"...Done"
K ^TMP($J,"FHPRO"),DA,DIC,DIK,FHX,FHX1,FHX3
Q
REMOV ; Check if FHW protocols is used as Items and delete them.
S DA(1)=FHX1
F FHX3=0:0 S FHX3=$O(^TMP($J,"FHPRO",FHX3)) Q:FHX3<1 S DA=$O(^ORD(101,DA(1),10,"B",FHX3,0)) I DA S DIK="^ORD(101,DA(1),10," D ^DIK W !,"Protocol ",$G(^TMP($J,"FHPRO",FHX3))," Removed From ",FHX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHXUTL 1450 printed Dec 13, 2024@01:55:48 Page 2
FHXUTL ; HISC/NCA - OE/RR Post-Init Clean Up of 2.5 Protocols ;11/10/97 12:52
+1 ;;5.5;DIETETICS;;Jan 28, 2005
+2 IF +$$VERSION^XPDUTL("OR")'=3
WRITE !,?10,"You do not have version 3 of Order Entry.",!,?10,"The Protocols will not be removed."
QUIT
+3 if '$DATA(^ORD(101,0))
QUIT
+4 SET FHX="FHW"
+5 SET FHX=$ORDER(^ORD(101,"B",FHX))
if FHX=""
QUIT
+6 SET FHX1=$ORDER(^ORD(101,"B",FHX,0))
if 'FHX1
QUIT
+7 KILL ^TMP($JOB,"FHPRO")
+8 ; Clean up protocols
+9 WRITE !!,"Clean up 2.5 Dietetics Protocols..."
+10 SET FHX="FHW"
FOR
SET FHX=$ORDER(^ORD(101,"B",FHX))
if $EXTRACT(FHX,1,3)'="FHW"
QUIT
FOR FHX1=0:0
SET FHX1=$ORDER(^ORD(101,"B",FHX,FHX1))
if FHX1<1
QUIT
if FHX'="FHWMAS"
SET ^TMP($JOB,"FHPRO",FHX1)=FHX
+11 FOR FHX="OR"
FOR
SET FHX=$ORDER(^ORD(101,"B",FHX))
if $EXTRACT(FHX,1,2)'="OR"
QUIT
FOR FHX1=0:0
SET FHX1=$ORDER(^ORD(101,"B",FHX,FHX1))
if FHX1<1
QUIT
IF $EXTRACT($PIECE($GET(^ORD(101,FHX1,0)),"^",1),1,2)="OR"
DO REMOV
+12 FOR FHX="FHW"
FOR
SET FHX=$ORDER(^ORD(101,"B",FHX))
if $EXTRACT(FHX,1,3)'="FHW"
QUIT
FOR FHX1=0:0
SET FHX1=$ORDER(^ORD(101,"B",FHX,FHX1))
if FHX1<1
QUIT
IF $EXTRACT($PIECE($GET(^ORD(101,FHX1,0)),"^",1),1,3)="FHW"
DO REMOV
+13 FOR FHX=0:0
SET FHX=$ORDER(^TMP($JOB,"FHPRO",FHX))
if FHX<1
QUIT
SET DA=FHX
IF DA
SET DIK="^ORD(101,"
DO ^DIK
WRITE !,"Protocol ",$GET(^TMP($JOB,"FHPRO",FHX))," Removed"
+14 WRITE !,"...Done"
+15 KILL ^TMP($JOB,"FHPRO"),DA,DIC,DIK,FHX,FHX1,FHX3
+16 QUIT
REMOV ; Check if FHW protocols is used as Items and delete them.
+1 SET DA(1)=FHX1
+2 FOR FHX3=0:0
SET FHX3=$ORDER(^TMP($JOB,"FHPRO",FHX3))
if FHX3<1
QUIT
SET DA=$ORDER(^ORD(101,DA(1),10,"B",FHX3,0))
IF DA
SET DIK="^ORD(101,DA(1),10,"
DO ^DIK
WRITE !,"Protocol ",$GET(^TMP($JOB,"FHPRO",FHX3))," Removed From ",FHX
+3 QUIT
